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 NOT ~profit/lib/logic.f
  11 REQUIRE DateTime>PAD ~ygrek/lib/spec/unixdate.f
  12 REQUIRE FileLines=> ~ygrek/lib/filelines.f
  13 REQUIRE BACKSTRFREE ~ygrek/lib/backstr.f
  14 REQUIRE StartAppWait ~ygrek/lib/linux/process.f
  15 REQUIRE content:html ~ygrek/lib/net/cgi.f
  16
  17 ALSO XMLSAFE
  18 ALSO XHTML
  19
  20 \ Every page
  21 : <page> ( `title -- )
  22    PRO
  23    xml-declaration
  24    doctype-strict
  25    xhtml
  26    << `head tag
  27      << `application/xhtml+xml;charset=utf-8 `content-type http-equiv >>
  28      << `title tag ( `title ) TYPE >>
  29 \     << `wiki.css link-stylesheet >>
  30    >>
  31
  32    `body tag
  33    CONT ;
  34
  35 : input ( `value `name `type -- ) %[ `type $$ `name $$ `value $$ ]% `input /atag ;
  36
  37 : render-edit ( a u -- )
  38   \ << `h1 tag S" Nota bene: Editing is disabled ('save' will ignore your changes)" TYPE >>
  39   %[ `post `method $$ S" " `action $$ ]% `form atag
  40   <<
  41    `div tag
  42
  43    %[ `content `name $$ `25 `rows $$ `80 `cols $$ ]% `textarea atag
  44    ( a u ) TYPE
  45   >>
  46
  47   <<
  48    `div tag
  49    CR
  50    <<
  51    %[ `gen `name $$ ]% `select atag
  52    << %[ `cxx `value $$ `selected 2DUP $$ ]% `option atag `C++ TYPE >>
  53    << %[ `caml `value $$ ]% `option atag `OCaml TYPE >>
  54    >>
  55
  56    S" generate code " `button `submit input
  57   >>
  58 ;
  59
  60 20 1024 * CONSTANT limit
  61
  62 : process ( a u -- )
  63   `p tag
  64   hrule
  65   << `h2 tag S" Input" TYPE >>
  66   DUP limit > IF DROP limit S" Input too long, truncated" TYPE CR THEN
  67   << `pre tag 2DUP TYPE >>
  68   hrule
  69         (( S" sql" DROP 0x1FF )) mkdir DROP
  70         ms@ { tick | src dst err gen }
  71   `gen GetParam S" caml" CEQUAL IF S" caml" ELSE S" cxx" THEN >STR TO gen
  72   tick " sql/{n}.in" -> src
  73   tick " sql/{n}.out" -> dst
  74   tick " sql/{n}.err" -> err
  75   \ src STR@ TYPE CR dst STR@ TYPE CR err STR@ TYPE CR
  76   src STR@ OCCUPY
  77   err STR@ dst STR@ src STR@ gen STR@
  78   " ./sqlgg.native -gen {s} {s} > {s} 2> {s}" STR@ StartAppWait DROP
  79   dst STR@ FILE
  80   << `h2 tag S" Output" TYPE >>
  81   << `pre tag TYPE >>
  82   hrule
  83   err STR@ FILE DUP 0= IF 2DROP EXIT THEN
  84   << `h2 tag S" Errors" TYPE >>
  85   << `pre tag TYPE >>
  86   hrule
  87   ;
  88
  89 : ask-input
  90   << `p tag
  91     S" Input SQL statements terminated with semicolon (;) each. " TYPE
  92     S" Use ? or @name for binding slots" TYPE
  93   >>
  94   S" " render-edit ;
  95
  96 : main ( -- )
  97   S" SQL Guided (code) generator" 2DUP <page>
  98         << `h1 tag `/p/sqlgg.html link-text >>
  99   `content GetParam DUP 0= IF 2DROP ask-input ELSE process THEN
 100   \ S" CREATE TABLE x (z INT);" process
 101 ;
 102
 103 PREVIOUS
 104 PREVIOUS
 105
 106 : env ENVIRONMENT? NOT IF S" " THEN ;
 107
 108 : TAB 0x09 EMIT ;
 109
 110 ALSO CGI
 111
 112 : log_request
 113   LAMBDA{
 114   TIME&DATE DateTime>PAD TYPE TAB
 115   `REMOTE_ADDR env TYPE TAB
 116   `REQUEST_METHOD env TYPE TAB
 117   `SCRIPT_NAME env TYPE SPACE
 118   `QUERY_STRING env TYPE TAB
 119   `HTTP_USER_AGENT env TYPE
 120   } TYPE>STR BACKSTRFREE STR@ `request.log ATTACH-LINE-CATCH DROP ;
 121
 122 : headers
 123   content:xhtml
 124 \  S" Cache-Control: no-cache" TYPE CR
 125 ;
 126
 127 : content
 128   log_request
 129   get-params
 130   main
 131   CR ;
 132
 133 : index
 134   headers
 135   ['] content TYPE>STR DUP STRLEN content-length
 136   CR
 137   STYPE
 138   BYE ;
 139
 140 PREVIOUS
 141
 142 \ : index headers CR content ;
 143
 144 \ : REQUEST_METHOD S" GET" ;
 145 \ : QUERY_STRING S" page_name=MainPage" ;
 146
 147 \ ' TYPE1 TO USER-TYPE
 148
 149 : save ['] index MAINX ! `sql.cgi SAVE ;
 150  save BYE
 151
 152 index