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 REQUIRE XHTML-EXTRA ~ygrek/lib/xhtml/extra.f
  17
  18 ALSO XMLSAFE
  19 ALSO XHTML
  20
  21 \ Every page
  22 : <page> ( `title -- )
  23    PRO
  24    xml-declaration
  25    doctype-strict
  26    xhtml
  27    << `head tag
  28      << `application/xhtml+xml;charset=utf-8 `content-type http-equiv >>
  29      << `title tag ( `title ) TYPE >>
  30 \     << `wiki.css link-stylesheet >>
  31    >>
  32
  33    `body tag
  34    CONT ;
  35
  36 : sdiv ( `style --> \ <-- ) PRO %[ `style $$ ]% `div atag CONT ;
  37 : option ( `value `name -- ) 2SWAP %[ `value $$ ]% `option atag TYPE ;
  38
  39 : render-edit ( a u -- )
  40   \ << `h1 tag S" Nota bene: Editing is disabled ('save' will ignore your changes)" TYPE >>
  41   S" " form-post
  42   <<
  43    S" float:left; margin: 0 1em 1em 0" sdiv
  44
  45    %[ `content `name $$ `25 `rows $$ `80 `cols $$ ]% `textarea atag
  46    ( a u ) TYPE
  47   >>
  48
  49   << S" float:left; padding: 0 1em; background-color: #eee; border: 1px solid green" sdiv
  50     << `h3 tag S" Example" TYPE >>
  51     << `pre tag
  52 " CREATE TABLE t1 (x INT, name TEXT);
  53 CREATE TABLE t2 (y INT, name TEXT);
  54 CREATE TABLE t3 (z INT, r INT);
  55
  56 SELECT *, y+z AS q FROM t1
  57   JOIN t2 USING (name)
  58   JOIN t3 ON x = r
  59 WHERE x = @val;" STYPE
  60     >>
  61   >>
  62
  63   <<
  64    S" clear:left" sdiv
  65
  66 (
  67   << `div tag S" Output query parameters substitution :" TYPE
  68    <<
  69     %[ `params `name $$ ]% `select atag
  70     `input S" As is" option
  71     `named S" Only named" option
  72     `unnamed S" Only unnamed" option
  73    >>
  74   >>
  75 )
  76
  77    <<
  78    %[ `gen `name $$ ]% `select atag
  79    `cxx `C++ option
  80    `csharp `C# option
  81    `java `Java option
  82    `caml `OCaml option
  83    `xml  `XML option
  84    >>
  85
  86    S" generate code " `button `submit input
  87   >>
  88 ;
  89
  90 20 1024 * CONSTANT limit
  91
  92 : gen-param ( `s -- `s2 )
  93   2DUP `caml CEQUAL IF EXIT THEN
  94   2DUP `xml  CEQUAL IF EXIT THEN
  95   2DUP `java CEQUAL IF EXIT THEN
  96   2DUP `csharp CEQUAL IF EXIT THEN
  97   2DROP `cxx ;
  98
  99 : process ( a u -- )
 100   `p tag
 101   hrule
 102   << `h2 tag S" Input" TYPE >>
 103   DUP limit > IF DROP limit S" Input too long, truncated" TYPE CR THEN
 104   << `pre tag 2DUP TYPE >>
 105   hrule
 106         (( S" sql" DROP 0x1FF )) mkdir DROP
 107         ms@ { tick | src dst err gen }
 108   `gen GetParam gen-param >STR TO gen
 109   tick " sql/{n}.in" -> src
 110   tick " sql/{n}.out" -> dst
 111   tick " sql/{n}.err" -> err
 112   \ src STR@ TYPE CR dst STR@ TYPE CR err STR@ TYPE CR
 113   src STR@ OCCUPY
 114   err STR@ dst STR@ src STR@ gen STR@
 115   " ./sqlgg.native -gen {s} {s} > {s} 2> {s}" STR@ StartAppWait DROP
 116   dst STR@ FILE
 117   << `h2 tag S" Output" TYPE >>
 118   << `pre tag TYPE >>
 119   hrule
 120   err STR@ FILE DUP 0= IF 2DROP EXIT THEN
 121   << `h2 tag S" Errors" TYPE >>
 122   << `pre tag TYPE >>
 123   hrule
 124   ;
 125
 126 : ask-input
 127   << `p tag
 128     S" Input SQL statements terminated with semicolon (;) each. " TYPE
 129     S" Use ? or @name for binding slots" TYPE
 130   >>
 131   S" " render-edit ;
 132
 133 : main ( -- )
 134   S" SQL Guided (code) generator" 2DUP <page>
 135         << `h1 tag `/p/sqlgg/ link-text >>
 136   `content GetParam DUP 0= IF 2DROP ask-input ELSE process THEN
 137   \ S" CREATE TABLE x (z INT);" process
 138 ;
 139
 140 PREVIOUS
 141 PREVIOUS
 142
 143 : env ENVIRONMENT? NOT IF S" " THEN ;
 144
 145 : TAB 0x09 EMIT ;
 146
 147 ALSO CGI
 148
 149 : log_request
 150   LAMBDA{
 151   TIME&DATE DateTime>PAD TYPE TAB
 152   `REMOTE_ADDR env TYPE TAB
 153   `REQUEST_METHOD env TYPE TAB
 154   `SCRIPT_NAME env TYPE SPACE
 155   `QUERY_STRING env TYPE TAB
 156   `HTTP_USER_AGENT env TYPE
 157   } TYPE>STR BACKSTRFREE STR@ `request.log ATTACH-LINE-CATCH DROP ;
 158
 159 : headers
 160   content:xhtml
 161 \  S" Cache-Control: no-cache" TYPE CR
 162 ;
 163
 164 : content
 165   log_request
 166   get-params
 167   main
 168   CR ;
 169
 170 : index
 171   headers
 172   ['] content TYPE>STR DUP STRLEN content-length
 173   CR
 174   STYPE
 175   BYE ;
 176
 177 PREVIOUS
 178
 179 \ : index headers CR content ;
 180
 181 \ : REQUEST_METHOD S" GET" ;
 182 \ : QUERY_STRING S" page_name=MainPage" ;
 183
 184 \ ' TYPE1 TO USER-TYPE
 185
 186 : save
 187   ['] index MAINX !
 188   `sql.cgi SAVE
 189   `sql.cgi.o DELETE-FILE DROP
 190   `sql.cgi.ld DELETE-FILE DROP
 191 ;
 192
 193 save BYE
 194