+ list_donors
[sqlgg.git] / cgi.f
blobcd740421441a2dba26f62b01c3d88e645c5acb03
1 #! /usr/bin/spf4
2 \ #! /home/ygrek/work/forth/spf/spf4
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
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
17 ALSO XMLSAFE
18 ALSO XHTML
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 >>
32 `body tag
33 CONT ;
35 : input ( `value `name `type -- ) %[ `type $$ `name $$ `value $$ ]% `input /atag ;
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
41 `div tag
43 %[ `content `name $$ `25 `rows $$ `80 `cols $$ ]% `textarea atag
44 ( a u ) TYPE
48 `div tag
51 %[ `gen `name $$ ]% `select atag
52 << %[ `cxx `value $$ `selected 2DUP $$ ]% `option atag `C++ TYPE >>
53 << %[ `caml `value $$ ]% `option atag `OCaml TYPE >>
56 S" generate code " `button `submit input
60 20 1024 * CONSTANT limit
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
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
94 S" " render-edit ;
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
103 PREVIOUS
104 PREVIOUS
106 : env ENVIRONMENT? NOT IF S" " THEN ;
108 : TAB 0x09 EMIT ;
110 ALSO CGI
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 ;
122 : headers
123 content:xhtml
124 \ S" Cache-Control: no-cache" TYPE CR
127 : content
128 log_request
129 get-params
130 main
131 CR ;
133 : index
134 headers
135 ['] content TYPE>STR DUP STRLEN content-length
137 STYPE
138 BYE ;
140 PREVIOUS
142 \ : index headers CR content ;
144 \ : REQUEST_METHOD S" GET" ;
145 \ : QUERY_STRING S" page_name=MainPage" ;
147 \ ' TYPE1 TO USER-TYPE
149 : save ['] index MAINX ! `sql.cgi SAVE ;
150 save BYE
152 index