main.f

   1 \ forthwiki
   2
   3 REQUIRE ATTACH ~pinka/samples/2005/lib/append-file.f
   4 REQUIRE USER-TYPE ~ygrek/lib/typestr.f
   5 \ :NONAME S" wiki.err" ATTACH ; TO USER-TYPE \ no stdout
   6
   7 REQUIRE XSLTmm ~ac/lib/lin/xml/xslt.f
   8 REQUIRE XHTML ~ygrek/lib/xhtml/core.f
   9 REQUIRE DumpParams ~ac/lib/string/get_params.f
  10 REQUIRE EQUAL ~pinka/spf/string-equal.f
  11 REQUIRE NOT ~profit/lib/logic.f
  12 REQUIRE cat ~ygrek/lib/cat.f
  13 REQUIRE ALLOCATED ~pinka/lib/ext/basics.f
  14 REQUIRE NUMBER ~ygrek/lib/parse.f
  15 REQUIRE [env] ~ygrek/lib/env.f
  16 REQUIRE DateTime>PAD ~ygrek/lib/spec/unixdate.f
  17 REQUIRE FileLines=> ~ygrek/lib/filelines.f
  18 REQUIRE READ-FILE-EXACT ~pinka/lib/files-ext.f
  19 REQUIRE STRAPPEND ~ygrek/lib/str.f
  20 REQUIRE BACKSTR@ ~ygrek/lib/backstr.f
  21 REQUIRE CGI ~ygrek/lib/net/cgi.f
  22 REQUIRE XHTML-EXTRA ~ygrek/lib/xhtml/extra.f
  23
  24 S" storage.f" INCLUDED
  25 S" convert.f" INCLUDED
  26
  27 2048 VALUE next-exn-id
  28 : exception ( `text -- id ) 2DROP next-exn-id DUP 1+ TO next-exn-id ;
  29 : exception: ( "name" -- ) PICK-NAME exception CONSTANT ;
  30
  31 exception: #forbidden
  32
  33 : ENVIR ENVIRONMENT? NOT IF S" " THEN ;
  34
  35 : EMIT-URLENCODED ( c -- ) '%' EMIT BASE @ >R HEX S>D <# # # #> TYPE R> BASE ! ;
  36
  37 \ as per RFC 1738
  38 : URLENCODE-CHAR ( c -- )
  39   SP@ 1 RE" [a-zA-Z0-9$_.+!*'(),-]" re_match? IF EMIT ELSE EMIT-URLENCODED THEN ;
  40
  41 : urlencode ( a u -- s ) LAMBDA{ BOUNDS DO I C@ URLENCODE-CHAR LOOP } TYPE>STR ;
  42
  43 : param: ( a u "name" -- )
  44   PARSE-NAME 2OVER 2OVER
  45   " : #{s} S{''} {s}{''} ;" STREVALUATE
  46   " : ${s} S{''} {s}{''} GetParam ;" STREVALUATE ;
  47
  48 `action param: action
  49 `page_name param: name
  50 `special param: special
  51
  52 ALSO XMLSAFE
  53 ALSO XHTML
  54
  55 \ Every page
  56 : <page> ( `title -- )
  57    PRO
  58    xml-declaration
  59    doctype-strict
  60    xhtml
  61    << `head tag
  62      << `application/xhtml+xml;charset=utf-8 `content-type http-equiv >>
  63      << `title tag ( `title ) TYPE S"  :: ForthWiki" TYPE >>
  64      << `wiki.css link-stylesheet >>
  65    >>
  66
  67    `body tag
  68    CONT ;
  69
  70 \ ugly?
  71 : +urlencoded ( a u s -- s' ) -ROT urlencode STRAPPEND ;
  72 : page-url ( `name -- s ) #name " ?{s}=" +urlencoded ;
  73 : page-action-url ( `action `name -- s ) page-url -ROT #action " &{s}=" +urlencoded STRAPPEND ;
  74 : page-version-url ( n `name -- s ) page-url SWAP `version " &{s}={n}" STRAPPEND ;
  75 : special-url ( `name -- s ) #special " ?{s}=" +urlencoded ;
  76
  77 : link-page ( `name -- ) 2DUP page-url link-s TYPE ;
  78 : link-page-action ( `text `action `name -- ) page-action-url link-s TYPE ;
  79 : link-special ( `name -- ) 2DUP special-url link-s TYPE ;
  80 : link-version-tag ( n `name --> \ <-- ) PRO page-version-url link-s CONT ;
  81
  82 \ wrap wiki page
  83 : <wiki> ( `name -- )
  84   PRO
  85   [env] `name env!
  86   `name env@ <page>
  87   << `pagename :span `name env@ TYPE >>
  88   hrule
  89   << `toolbar :div
  90     `View `view `name env@ link-page-action
  91     `Edit `edit `name env@ link-page-action
  92     `History `history `name env@ link-page-action
  93   >>
  94   hrule
  95   << `warning :div
  96     S" This wiki is experimental. Expect your changes to be lost some day." TYPE
  97   >>
  98   << `quick :div
  99     ul
 100     << li `MainPage link-page >>
 101     << li `Rules link-page >>
 102     << li `catalog link-special >>
 103   >>
 104   << `page-sep-left :div >>
 105   << `page :div CONT >>
 106   << `page-sep-bottom :div >>
 107   << `footer :div S" version 0" TYPE >> ;
 108
 109 : render-not-found ( `name -- )
 110   [env] `name env!
 111   `name env@ " No such article : {s}" STYPE CR
 112   S" Do you wish to " TYPE `create `edit `name env@ page-action-url BACKSTR@ link-text S"  it?" TYPE ;
 113
 114 \ continue only if such page exists
 115 \ render not-found page if no such page
 116 \ : notfound|| ( `name --> `name \ <-- )
 117 \   PRO
 118 \   2DUP storage::exists IF CONT ELSE render-not-found THEN ;
 119
 120 : render-edit ( a u -- )
 121   \ << `h1 tag S" Nota bene: Editing is disabled ('save' will ignore your changes)" TYPE >>
 122   $name page-url BACKSTR@ form-post
 123   `div tag
 124   `save #action `hidden input
 125   $name #name `hidden input
 126   ms@ " {n}" BACKSTR@ `page_time `hidden input
 127
 128   <<
 129   %[ `content `name $$ `25 `rows $$ `80 `cols $$ ]% `textarea atag
 130   ( a u ) TYPE
 131   >>
 132
 133   `div tag
 134   CR
 135   S$ |S" 3 DUP *" EVALUATE| TYPE S" " `answer `text input
 136   CR CR
 137   `SAVE `button `submit input
 138   `PREVIEW `button `submit input ;
 139
 140 : render-show { a u version | h -- }
 141   version 0 = IF S" latest" TYPE CR a u storage::get-xml-latest ELSE " version: {#version}" STYPE CR a u version storage::get-xml-version THEN ( h ? )
 142   IF -> h
 143    `content h HASH@ convert::xml2html FORTH::STYPE
 144    h del-hash
 145   ELSE
 146    version 0 = IF a u render-not-found ELSE a u 0 RECURSE THEN
 147   THEN ;
 148
 149 : edit-page-latest ( `name -- )
 150   storage::get-xml-latest IF
 151   { h | s }
 152   `content h HASH@ convert::xml2wiki -> s
 153   s STR@ render-edit
 154   s STRFREE
 155   h del-hash
 156   ELSE
 157    S" " render-edit
 158   THEN ;
 159
 160 : render-history ( -- )
 161   ul
 162   $name storage::get-versions ['] < list::sorted
 163   LAMBDA{ li DUP $name link-version-tag . } list::free-with ;
 164
 165 : render-preview ( a u -- )
 166   << `h3 tag `Preview TYPE >>
 167   2DUP convert::wiki2xml BACKSTR@ convert::xml2html FORTH::STYPE
 168        render-edit ;
 169
 170 : render-tarpit
 171   `REMOTE_ADDR ENVIR " {s} is a bot" BACKSTR@ `wiki.log ATTACH-LINE-CATCH DROP
 172   #forbidden THROW
 173   << `h1 tag S" Please learn Forth language before editing ForthWiki" TYPE >> ;
 174
 175 : wiki-save ( -- )
 176   `button GetParam `PREVIEW CEQUAL IF `content GetParam render-preview EXIT THEN
 177   `button GetParam `SAVE CEQUAL IF
 178   ( `page_time GetParam NUMBER IF
 179       ms@ - ABS 4000 < IF render-tarpit EXIT THEN)
 180       `answer GetParam FINE-HEAD FINE-TAIL `9 CEQUAL NOT IF render-tarpit EXIT THEN
 181       `content GetParam convert::wiki2xml BACKSTR@ $name storage::store
 182   THEN
 183   $name 0 render-show ;
 184
 185 \ : wiki-save1 ( -- )
 186 \  `Save <wiki>
 187 \  S" Editing is disabled for unauthorized visitors!" TYPE ;
 188
 189 : GetParamInt ( `str -- n ) GetParam NUMBER NOT IF 0 THEN ;
 190
 191 : wiki-article ( -- )
 192   $name <wiki>
 193   $action `edit CEQUAL IF $name edit-page-latest EXIT THEN
 194   $action `save CEQUAL IF wiki-save EXIT THEN
 195   $action `history CEQUAL IF render-history EXIT THEN
 196   $name `version GetParamInt render-show ;
 197
 198 : special-page-catalog
 199   S" :: Catalog" <page>
 200   ul
 201   storage::all=> li link-page ;
 202
 203 : wiki-main ( -- )
 204   $special `catalog CEQUAL IF special-page-catalog EXIT THEN
 205   S" :: Default" <page>
 206   S" Go to " TYPE `MainPage link-page CR
 207   S" Or browse all articles : " TYPE `catalog link-special CR
 208 (  hrule
 209   `article 0 render-show
 210   hrule
 211   `Rules 0 render-show
 212   hrule)
 213 \  S" Or browse articles extracted from the wiki.forth.org.ru database :" TYPE CR
 214 \  `data -1 ITERATE-FILES
 215 \    NIP IF 2DROP ELSE
 216 \    RE" (.*)\.xml" re_match? IF \1 link-page CR THEN THEN
 217 ;
 218
 219 PREVIOUS
 220 PREVIOUS
 221
 222 : TAB 0x09 EMIT ;
 223
 224 : log_request
 225   LAMBDA{
 226   TIME&DATE DateTime>PAD TYPE TAB
 227   `REMOTE_ADDR ENVIR TYPE TAB
 228   `REQUEST_METHOD ENVIR TYPE TAB
 229   `SCRIPT_NAME ENVIR TYPE SPACE
 230   `QUERY_STRING ENVIR TYPE TAB
 231   `HTTP_USER_AGENT ENVIR TYPE
 232   } TYPE>STR BACKSTR@ `wiki.log ATTACH-LINE-CATCH DROP ;
 233
 234 ALSO CGI
 235
 236 : headers
 237   content:xhtml
 238   S" Cache-Control: no-cache" TYPE CR ;
 239
 240 : content
 241   log_request
 242   get-params
 243   $name EMPTY? IF wiki-main ELSE wiki-article THEN
 244   CR ;
 245
 246 : index
 247   ['] content TYPE>STR-CATCH ( s exn )
 248   DUP
 249   IF
 250     NIP
 251     content:text
 252     #forbidden = IF 403 status " Forbidden" ELSE " Internal error" THEN
 253   ELSE
 254     DROP
 255     headers
 256     DUP STRLEN content-length
 257   THEN
 258   CR STYPE
 259   BYE ;
 260
 261 PREVIOUS
 262
 263 \ : index headers CR content BYE ;
 264
 265 \ : REQUEST_METHOD S" GET" ;
 266 \ : QUERY_STRING S" page_name=MainPage" ;
 267
 268 \ ' TYPE1 TO USER-TYPE
 269
 270 : save ['] index MAINX ! `wiki.cgi SAVE ;
 271