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