cgi.f

   1 #! /home/ygrek/work/forth/spf/spf4
   2 \ #! /usr/bin/spf4
   3
   4 REQUIRE ATTACH ~pinka/samples/2005/lib/append-file.f
   5 REQUIRE USER-TYPE ~ygrek/lib/typestr.f
   6 \ :NONAME S" wiki.err" ATTACH ; TO USER-TYPE \ no stdout
   7
   8 REQUIRE XSLTmm ~ac/lib/lin/xml/xslt.f
   9 REQUIRE XHTML ~ygrek/lib/xhtml/core.f
  10 REQUIRE DumpParams ~ac/lib/string/get_params.f
  11 REQUIRE EQUAL ~pinka/spf/string-equal.f
  12 REQUIRE NOT ~profit/lib/logic.f
  13 REQUIRE cat ~ygrek/lib/cat.f
  14 REQUIRE ALLOCATED ~pinka/lib/ext/basics.f
  15 REQUIRE NUMBER ~ygrek/lib/parse.f
  16 REQUIRE [env] ~ygrek/lib/env.f
  17 REQUIRE DateTime>PAD ~ygrek/lib/spec/unixdate.f
  18 REQUIRE FileLines=> ~ygrek/lib/filelines.f
  19 REQUIRE READ-FILE-EXACT ~pinka/lib/files-ext.f
  20
  21 : BACKSTRFREE ( s --> s \ <-- ) PRO BACK STRFREE TRACKING RESTB CONT ;
  22 : SEVALUATE BACKSTRFREE STR@ EVALUATE ;
  23 \ append s1 to s
  24 : SAPPEND ( s s1 -- s' ) OVER S+ ;
  25
  26 ALSO XMLSAFE
  27 ALSO XHTML
  28
  29 \ Every page
  30 : <page> ( `title -- )
  31    PRO
  32    xml-declaration
  33    doctype-strict
  34    xhtml
  35    << `head tag
  36      << `application/xhtml+xml;charset=utf-8 `content-type http-equiv >>
  37      << `title tag ( `title ) TYPE >>
  38 \     << `wiki.css link-stylesheet >>
  39    >>
  40
  41    `body tag
  42    CONT ;
  43
  44 : input ( `value `name `type -- ) %[ `type $$ `name $$ `value $$ ]% `input /atag ;
  45
  46 : render-edit ( a u -- )
  47   \ << `h1 tag S" Nota bene: Editing is disabled ('save' will ignore your changes)" TYPE >>
  48   %[ `POST `method $$ S" " `action $$ ]% `form atag
  49   `div tag
  50
  51   <<
  52     %[ `content `name $$ `25 `rows $$ `80 `cols $$ ]% `textarea atag
  53     ( a u ) TYPE
  54   >>
  55
  56   `save `button `submit input
  57 ;
  58
  59 : GetParamInt ( `str -- n ) GetParam NUMBER NOT IF 0 THEN ;
  60
  61 : process ( a u -- )
  62   `p tag TYPE ;
  63
  64 : main ( -- )
  65   S" Main" <page>
  66   `content GetParam DUP 0= IF 2DROP S" " render-edit ELSE process THEN
  67 ;
  68
  69 PREVIOUS
  70 PREVIOUS
  71
  72 : content:html S" Content-type: text/html" TYPE CR ;
  73 : content:xhtml S" Content-type: application/xhtml+xml" TYPE CR ;
  74 : content-length " Content-Length: {n}" STYPE CR ;
  75
  76 \ : comment PRO ." <!-- " CONT ." -->" ;
  77
  78 : get_post_params
  79   S" CONTENT_LENGTH" ENVIRONMENT? NOT IF EXIT THEN
  80   NUMBER NOT IF EXIT THEN
  81   ALLOCATED 2DUP H-STDIN READ-FILE-EXACT IF 2DROP ELSE GetParamsFromString THEN ;
  82   \ ALLOCATED 2DUP H-STDIN READ-FILE . NIP 2DUP TYPE CR GetParamsFromString ;
  83
  84 : get_get_params
  85   S" QUERY_STRING" ENVIRONMENT? IF GetParamsFromString THEN ;
  86
  87 : get_params
  88   `REQUEST_METHOD ENVIRONMENT? NOT IF EXIT THEN
  89    2DUP `POST CEQUAL IF 2DROP get_post_params EXIT THEN
  90    2DUP `GET  CEQUAL IF 2DROP get_get_params EXIT THEN
  91    2DROP ;
  92
  93 [UNDEFINED] WINAPI: [IF]
  94 : environ
  95   S" environ" symbol-lookup symbol-address @
  96   BEGIN
  97    DUP @
  98   WHILE
  99    DUP @ ASCIIZ> TYPE CR
 100    CELL+
 101   REPEAT
 102   DROP ;
 103 [ELSE]
 104
 105 WINAPI: GetEnvironmentStrings KERNEL32.DLL
 106
 107 : environ
 108   GetEnvironmentStrings
 109   BEGIN
 110    DUP B@
 111   WHILE
 112    ASCIIZ> 2DUP TYPE CR
 113    + 1+
 114   REPEAT
 115   DROP ;
 116
 117 [THEN]
 118
 119 : env ENVIRONMENT? NOT IF S" " THEN ;
 120
 121 : TAB 0x09 EMIT ;
 122
 123 : log_request
 124   LAMBDA{
 125   TIME&DATE DateTime>PAD TYPE TAB
 126   `REMOTE_ADDR env TYPE TAB
 127   `REQUEST_METHOD env TYPE TAB
 128   `SCRIPT_NAME env TYPE SPACE
 129   `QUERY_STRING env TYPE TAB
 130   `HTTP_USER_AGENT env TYPE
 131   } TYPE>STR BACKSTRFREE STR@ `request.log ATTACH-LINE-CATCH DROP ;
 132
 133 : headers
 134   content:xhtml
 135 \  S" Cache-Control: no-cache" TYPE CR
 136 ;
 137
 138 : content
 139   log_request
 140   get_params
 141   main
 142   CR ;
 143
 144 : index
 145   headers
 146   ['] content TYPE>STR DUP STRLEN content-length
 147   CR
 148   STYPE
 149   BYE ;
 150
 151 \ : index headers CR content ;
 152
 153 \ : REQUEST_METHOD S" GET" ;
 154 \ : QUERY_STRING S" page_name=MainPage" ;
 155
 156 \ ' TYPE1 TO USER-TYPE
 157
 158 : save ['] index MAINX ! `test.cgi SAVE ;
 159 \ save BYE
 160
 161 index