cgi.f

   1 #! /usr/bin/spf4
   2 \ #! /home/ygrek/work/forth/spf/spf4
   3
   4 REQUIRE ATTACH ~pinka/samples/2005/lib/append-file.f
   5 REQUIRE USER-TYPE ~ygrek/lib/typestr.f
   6 \ :NONAME 2DROP ; 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 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 CREATE-ANON-PIPE ~ygrek/lib/sys/pipe.f
  20
  21 : (sys) ( az -- x )
  22   (()) fork ?DUP
  23   IF
  24     NIP
  25     1 <( 0 0 )) waitpid
  26   ELSE
  27     \ FIXME
  28     >R
  29     S" /bin/sh" DROP DUP 2 <( S" -c" DROP R> 0 )) execlp \ no return
  30   THEN ;
  31
  32 : sys ( a u -- ) DROP (sys) DROP ;
  33
  34 : BACKSTRFREE ( s --> s \ <-- ) PRO BACK STRFREE TRACKING RESTB CONT ;
  35 : SEVALUATE BACKSTRFREE STR@ EVALUATE ;
  36 \ append s1 to s
  37 : SAPPEND ( s s1 -- s' ) OVER S+ ;
  38
  39 ALSO XMLSAFE
  40 ALSO XHTML
  41
  42 \ Every page
  43 : <page> ( `title -- )
  44    PRO
  45    xml-declaration
  46    doctype-strict
  47    xhtml
  48    << `head tag
  49      << `application/xhtml+xml;charset=utf-8 `content-type http-equiv >>
  50      << `title tag ( `title ) TYPE >>
  51 \     << `wiki.css link-stylesheet >>
  52    >>
  53
  54    `body tag
  55    CONT ;
  56
  57 : input ( `value `name `type -- ) %[ `type $$ `name $$ `value $$ ]% `input /atag ;
  58
  59 : render-edit ( a u -- )
  60   \ << `h1 tag S" Nota bene: Editing is disabled ('save' will ignore your changes)" TYPE >>
  61   %[ `POST `method $$ S" " `action $$ ]% `form atag
  62   `div tag
  63
  64   <<
  65     %[ `content `name $$ `25 `rows $$ `80 `cols $$ ]% `textarea atag
  66     ( a u ) TYPE
  67   >>
  68
  69   `save `button `submit input
  70 ;
  71
  72 : GetParamInt ( `str -- n ) GetParam NUMBER NOT IF 0 THEN ;
  73
  74 20 1024 * CONSTANT limit
  75
  76 : process ( a u -- )
  77   `p tag
  78   << `h2 tag S" Input" TYPE >>
  79   DUP limit > IF DROP limit S" Input too long, truncated" TYPE CR THEN
  80   << `pre tag 2DUP TYPE >>
  81   hrule
  82         (( S" sql" DROP 0x1FF )) mkdir DROP
  83         ms@ { tick | src dst err }
  84   tick " sql/{n}.in" -> src
  85   tick " sql/{n}.out" -> dst
  86   tick " sql/{n}.err" -> err
  87   \ src STR@ TYPE CR dst STR@ TYPE CR err STR@ TYPE CR
  88   src STR@ OCCUPY
  89   err STR@ dst STR@ src STR@ " ./sqlgg.native {s} > {s} 2> {s}" STR@ sys
  90   dst STR@ FILE
  91   << `h2 tag S" Output" TYPE >>
  92   << `pre tag TYPE >>
  93   hrule
  94   err STR@ FILE DUP 0= IF 2DROP EXIT THEN
  95   << `h2 tag S" Errors" TYPE >>
  96   << `pre tag TYPE >>
  97   hrule
  98   ;
  99
 100 : ask-input
 101   << `p tag
 102     S" Input SQL statements terminated with semicolon (;) each. " TYPE
 103     S" Use ? or @name for binding slots" TYPE
 104   >>
 105   S" " render-edit ;
 106
 107 : main ( -- )
 108   S" SQL to C++ code generator" 2DUP <page>
 109         << `h1 tag `/p/sqlgg.html link-text >>
 110   `content GetParam DUP 0= IF 2DROP ask-input ELSE process THEN
 111   \ S" CREATE TABLE x (z INT);" process
 112 ;
 113
 114 PREVIOUS
 115 PREVIOUS
 116
 117 : content:html S" Content-type: text/html" TYPE CR ;
 118 : content:xhtml S" Content-type: application/xhtml+xml" TYPE CR ;
 119 : content-length " Content-Length: {n}" STYPE CR ;
 120
 121 \ : comment PRO ." <!-- " CONT ." -->" ;
 122
 123 : get_post_params
 124   S" CONTENT_LENGTH" ENVIRONMENT? NOT IF EXIT THEN
 125   NUMBER NOT IF EXIT THEN
 126   ALLOCATED 2DUP H-STDIN READ-FILE-EXACT IF 2DROP ELSE GetParamsFromString THEN ;
 127   \ ALLOCATED 2DUP H-STDIN READ-FILE . NIP 2DUP TYPE CR GetParamsFromString ;
 128
 129 : get_get_params
 130   S" QUERY_STRING" ENVIRONMENT? IF GetParamsFromString THEN ;
 131
 132 : get_params
 133   `REQUEST_METHOD ENVIRONMENT? NOT IF EXIT THEN
 134    2DUP `POST CEQUAL IF 2DROP get_post_params EXIT THEN
 135    2DUP `GET  CEQUAL IF 2DROP get_get_params EXIT THEN
 136    2DROP ;
 137
 138 [UNDEFINED] WINAPI: [IF]
 139 : environ
 140   S" environ" symbol-lookup symbol-address @
 141   BEGIN
 142    DUP @
 143   WHILE
 144    DUP @ ASCIIZ> TYPE CR
 145    CELL+
 146   REPEAT
 147   DROP ;
 148 [ELSE]
 149
 150 WINAPI: GetEnvironmentStrings KERNEL32.DLL
 151
 152 : environ
 153   GetEnvironmentStrings
 154   BEGIN
 155    DUP B@
 156   WHILE
 157    ASCIIZ> 2DUP TYPE CR
 158    + 1+
 159   REPEAT
 160   DROP ;
 161
 162 [THEN]
 163
 164 : env ENVIRONMENT? NOT IF S" " THEN ;
 165
 166 : TAB 0x09 EMIT ;
 167
 168 : log_request
 169   LAMBDA{
 170   TIME&DATE DateTime>PAD TYPE TAB
 171   `REMOTE_ADDR env TYPE TAB
 172   `REQUEST_METHOD env TYPE TAB
 173   `SCRIPT_NAME env TYPE SPACE
 174   `QUERY_STRING env TYPE TAB
 175   `HTTP_USER_AGENT env TYPE
 176   } TYPE>STR BACKSTRFREE STR@ `request.log ATTACH-LINE-CATCH DROP ;
 177
 178 : headers
 179   content:xhtml
 180 \  S" Cache-Control: no-cache" TYPE CR
 181 ;
 182
 183 : content
 184   log_request
 185   get_params
 186   main
 187   CR ;
 188
 189 : index
 190   headers
 191   ['] content TYPE>STR DUP STRLEN content-length
 192   CR
 193   STYPE
 194   BYE ;
 195
 196 \ : index headers CR content ;
 197
 198 \ : REQUEST_METHOD S" GET" ;
 199 \ : QUERY_STRING S" page_name=MainPage" ;
 200
 201 \ ' TYPE1 TO USER-TYPE
 202
 203 : save ['] index MAINX ! `sql.cgi SAVE ;
 204  save BYE
 205
 206 index