Powered by ViewCVS 1.0-dev
| 1 : | pazsan | 1.1 | #! /usr/local/bin/gforth |
| 2 : | |||
| 3 : | anton | 1.26 | \ Copyright (C) 2000,2002,2003,2004,2006,2007,2008 Free Software Foundation, Inc. |
| 4 : | anton | 1.6 | |
| 5 : | \ This file is part of Gforth. | ||
| 6 : | |||
| 7 : | \ Gforth is free software; you can redistribute it and/or | ||
| 8 : | \ modify it under the terms of the GNU General Public License | ||
| 9 : | anton | 1.23 | \ as published by the Free Software Foundation, either version 3 |
| 10 : | anton | 1.6 | \ of the License, or (at your option) any later version. |
| 11 : | |||
| 12 : | \ This program is distributed in the hope that it will be useful, | ||
| 13 : | \ but WITHOUT ANY WARRANTY; without even the implied warranty of | ||
| 14 : | \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | ||
| 15 : | \ GNU General Public License for more details. | ||
| 16 : | |||
| 17 : | \ You should have received a copy of the GNU General Public License | ||
| 18 : | anton | 1.23 | \ along with this program. If not, see http://www.gnu.org/licenses/. |
| 19 : | anton | 1.6 | |
| 20 : | pazsan | 1.21 | \ This relies on inetd or xinetd: |
| 21 : | |||
| 22 : | \ To run the server on port 4444, do the following: | ||
| 23 : | |||
| 24 : | \ Add the following line to /etc/services: | ||
| 25 : | \ gforth 4444/tcp | ||
| 26 : | |||
| 27 : | \ If you use inetd, add the following line to /etc/inetd.conf: | ||
| 28 : | \ gforth stream tcp nowait.10000 wwwrun /usr/users/bernd/bin/httpd | ||
| 29 : | |||
| 30 : | \ If you use xinetd, create the folliwing service in /etc/xinetd.d: | ||
| 31 : | \ service gforth | ||
| 32 : | \ { | ||
| 33 : | \ socket_type = stream | ||
| 34 : | \ protocol = tcp | ||
| 35 : | \ wait = no | ||
| 36 : | \ user = wwwrun | ||
| 37 : | \ server = /home/bernd/bin/httpd | ||
| 38 : | \ } | ||
| 39 : | |||
| 40 : | \ If you want port 80, replace the service "gforth" with "http" | ||
| 41 : | |||
| 42 : | pazsan | 1.1 | warnings off |
| 43 : | |||
| 44 : | pazsan | 1.8 | require string.fs |
| 45 : | pazsan | 1.1 | |
| 46 : | pazsan | 1.21 | Variable DocumentRoot s" /srv/www/htdocs/" DocumentRoot $! |
| 47 : | Variable UserDir s" public_html/" UserDir $! | ||
| 48 : | pazsan | 1.11 | |
| 49 : | pazsan | 1.1 | Variable url |
| 50 : | pazsan | 1.4 | Variable posted |
| 51 : | Variable url-args | ||
| 52 : | pazsan | 1.1 | Variable protocol |
| 53 : | pazsan | 1.2 | Variable data |
| 54 : | pazsan | 1.4 | Variable active |
| 55 : | pazsan | 1.2 | Variable command? |
| 56 : | pazsan | 1.1 | |
| 57 : | : get ( addr -- ) name rot $! ; | ||
| 58 : | : get-rest ( addr -- ) source >in @ /string dup >in +! rot $! ; | ||
| 59 : | |||
| 60 : | pazsan | 1.4 | wordlist constant values |
| 61 : | wordlist constant commands | ||
| 62 : | pazsan | 1.1 | |
| 63 : | pazsan | 1.2 | : value: ( -- ) name |
| 64 : | pazsan | 1.1 | Forth definitions 2dup 1- nextname Variable |
| 65 : | pazsan | 1.2 | values set-current nextname here cell - Create , |
| 66 : | pazsan | 1.1 | DOES> @ get-rest ; |
| 67 : | pazsan | 1.2 | : >values values 1 set-order command? off ; |
| 68 : | pazsan | 1.1 | |
| 69 : | pazsan | 1.2 | \ HTTP protocol commands 26mar00py |
| 70 : | pazsan | 1.1 | |
| 71 : | pazsan | 1.4 | : rework-% ( add -- ) { url } base @ >r hex |
| 72 : | pazsan | 1.2 | 0 url $@len 0 ?DO |
| 73 : | url $@ drop I + c@ dup '% = IF | ||
| 74 : | drop 0. url $@ I 1+ /string | ||
| 75 : | 2 min dup >r >number r> swap - >r 2drop | ||
| 76 : | ELSE 0 >r THEN over url $@ drop + c! 1+ | ||
| 77 : | r> 1+ +LOOP url $!len | ||
| 78 : | r> base ! ; | ||
| 79 : | |||
| 80 : | pazsan | 1.5 | : rework-? ( addr -- ) |
| 81 : | dup >r $@ '? $split url-args $! nip r> $!len ; | ||
| 82 : | pazsan | 1.4 | |
| 83 : | pazsan | 1.5 | : get-url ( -- ) url get protocol get-rest |
| 84 : | pazsan | 1.4 | url rework-? url rework-% >values ; |
| 85 : | |||
| 86 : | pazsan | 1.2 | commands set-current |
| 87 : | |||
| 88 : | pazsan | 1.4 | : GET get-url data on active off ; |
| 89 : | : POST get-url data on active on ; | ||
| 90 : | : HEAD get-url data off active off ; | ||
| 91 : | pazsan | 1.2 | |
| 92 : | \ HTTP protocol values 26mar00py | ||
| 93 : | |||
| 94 : | values set-current | ||
| 95 : | |||
| 96 : | value: User-Agent: | ||
| 97 : | value: Pragma: | ||
| 98 : | value: Host: | ||
| 99 : | value: Accept: | ||
| 100 : | value: Accept-Encoding: | ||
| 101 : | value: Accept-Language: | ||
| 102 : | value: Accept-Charset: | ||
| 103 : | value: Via: | ||
| 104 : | value: X-Forwarded-For: | ||
| 105 : | value: Cache-Control: | ||
| 106 : | value: Connection: | ||
| 107 : | value: Referer: | ||
| 108 : | pazsan | 1.4 | value: Content-Type: |
| 109 : | value: Content-Length: | ||
| 110 : | pazsan | 1.11 | value: Keep-Alive: |
| 111 : | pazsan | 1.1 | |
| 112 : | definitions | ||
| 113 : | |||
| 114 : | Variable maxnum | ||
| 115 : | |||
| 116 : | : ?cr ( -- ) | ||
| 117 : | #tib @ 1 >= IF source 1- + c@ #cr = #tib +! THEN ; | ||
| 118 : | pazsan | 1.17 | : refill-loop ( -- flag ) base @ >r base off |
| 119 : | pazsan | 1.11 | BEGIN refill ?cr WHILE ['] interpret catch drop >in @ 0= UNTIL |
| 120 : | pazsan | 1.17 | true ELSE maxnum off false THEN r> base ! ; |
| 121 : | pazsan | 1.1 | : get-input ( -- flag ior ) |
| 122 : | pazsan | 1.3 | s" /nosuchfile" url $! s" HTTP/1.0" protocol $! |
| 123 : | pazsan | 1.2 | s" close" connection $! |
| 124 : | pazsan | 1.3 | infile-id push-file loadfile ! loadline off blk off |
| 125 : | pazsan | 1.2 | commands 1 set-order command? on ['] refill-loop catch |
| 126 : | pazsan | 1.11 | Keep-Alive $@ snumber? dup 0> IF nip THEN IF maxnum ! THEN |
| 127 : | pazsan | 1.4 | active @ IF s" " posted $! Content-Length $@ snumber? drop |
| 128 : | posted $!len posted $@ infile-id read-file throw drop | ||
| 129 : | THEN only forth also pop-file ; | ||
| 130 : | pazsan | 1.1 | |
| 131 : | \ Rework HTML directory 26mar00py | ||
| 132 : | |||
| 133 : | Variable htmldir | ||
| 134 : | |||
| 135 : | : rework-htmldir ( addr u -- addr' u' / ior ) | ||
| 136 : | anton | 1.16 | htmldir $! htmldir $@ compact-filename htmldir $!len drop |
| 137 : | anton | 1.12 | htmldir $@ s" ../" string-prefix? |
| 138 : | pazsan | 1.11 | IF -1 EXIT THEN \ can't access below current directory |
| 139 : | anton | 1.12 | htmldir $@ s" ~" string-prefix? |
| 140 : | pazsan | 1.11 | IF UserDir $@ htmldir dup $@ 2dup '/ scan '/ skip |
| 141 : | pazsan | 1.1 | nip - nip $ins |
| 142 : | pazsan | 1.11 | ELSE DocumentRoot $@ htmldir 0 $ins THEN |
| 143 : | pazsan | 1.1 | htmldir $@ 1- 0 max + c@ '/ = htmldir $@len 0= or |
| 144 : | IF s" index.html" htmldir dup $@len $ins THEN | ||
| 145 : | htmldir $@ file-status nip ?dup ?EXIT | ||
| 146 : | htmldir $@ ; | ||
| 147 : | |||
| 148 : | \ MIME type handling 26mar00py | ||
| 149 : | |||
| 150 : | : >mime ( addr u -- mime u' ) 2dup tuck over + 1- ?DO | ||
| 151 : | I c@ '. = ?LEAVE 1- -1 +LOOP /string ; | ||
| 152 : | |||
| 153 : | : >file ( addr u -- size fd ) | ||
| 154 : | r/o bin open-file throw >r | ||
| 155 : | r@ file-size throw drop | ||
| 156 : | ." Accept-Ranges: bytes" cr | ||
| 157 : | ." Content-Length: " dup 0 .r cr r> ; | ||
| 158 : | pazsan | 1.4 | : transparent ( size fd -- ) { fd } |
| 159 : | $4000 allocate throw swap dup 0 ?DO | ||
| 160 : | 2dup over swap $4000 min fd read-file throw type | ||
| 161 : | $4000 - $4000 +LOOP drop | ||
| 162 : | free fd close-file throw throw ; | ||
| 163 : | pazsan | 1.1 | |
| 164 : | pazsan | 1.5 | \ Keep-Alive handling 26mar00py |
| 165 : | |||
| 166 : | : .connection ( -- ) | ||
| 167 : | ." Connection: " | ||
| 168 : | anton | 1.12 | connection $@ s" Keep-Alive" str= maxnum @ 0> and |
| 169 : | pazsan | 1.5 | IF connection $@ type cr |
| 170 : | ." Keep-Alive: timeout=15, max=" maxnum @ 0 .r cr | ||
| 171 : | -1 maxnum +! ELSE ." close" cr maxnum off THEN ; | ||
| 172 : | |||
| 173 : | pazsan | 1.2 | : transparent: ( addr u -- ) Create here over 1+ allot place |
| 174 : | DOES> >r >file | ||
| 175 : | pazsan | 1.1 | .connection |
| 176 : | ." Content-Type: " r> count type cr cr | ||
| 177 : | pazsan | 1.2 | data @ IF transparent ELSE nip close-file throw THEN ; |
| 178 : | pazsan | 1.1 | |
| 179 : | \ mime types 26mar00py | ||
| 180 : | |||
| 181 : | pazsan | 1.2 | : mime-read ( addr u -- ) r/o open-file throw |
| 182 : | push-file loadfile ! 0 loadline ! blk off | ||
| 183 : | pazsan | 1.11 | BEGIN refill WHILE |
| 184 : | char '# <> >in off name nip 0<> and IF | ||
| 185 : | >in off name | ||
| 186 : | BEGIN >in @ >r name nip WHILE | ||
| 187 : | r> >in ! 2dup transparent: REPEAT | ||
| 188 : | 2drop rdrop | ||
| 189 : | THEN | ||
| 190 : | pazsan | 1.2 | REPEAT loadfile @ close-file pop-file throw ; |
| 191 : | |||
| 192 : | pazsan | 1.1 | : lastrequest |
| 193 : | ." Connection: close" cr maxnum off | ||
| 194 : | ." Content-Type: text/html" cr cr ; | ||
| 195 : | |||
| 196 : | wordlist constant mime | ||
| 197 : | mime set-current | ||
| 198 : | |||
| 199 : | pazsan | 1.2 | : shtml ( addr u -- ) lastrequest |
| 200 : | pazsan | 1.25 | data @ IF also forth included previous ELSE 2drop THEN ; |
| 201 : | pazsan | 1.1 | |
| 202 : | pazsan | 1.2 | s" application/pgp-signature" transparent: sig |
| 203 : | s" application/x-bzip2" transparent: bz2 | ||
| 204 : | s" application/x-gzip" transparent: gz | ||
| 205 : | pazsan | 1.21 | s" /etc/mime.types" ' mime-read catch [IF] 2drop |
| 206 : | \ no /etc/mime.types found on this machine, | ||
| 207 : | \ generating the most important types: | ||
| 208 : | s" text/html" transparent: html | ||
| 209 : | s" image/gif" transparent: gif | ||
| 210 : | s" image/png" transparent: png | ||
| 211 : | s" image/jpg" transparent: jpg | ||
| 212 : | [THEN] | ||
| 213 : | pazsan | 1.1 | |
| 214 : | definitions | ||
| 215 : | |||
| 216 : | pazsan | 1.2 | s" text/plain" transparent: txt |
| 217 : | pazsan | 1.1 | |
| 218 : | \ http errors 26mar00py | ||
| 219 : | |||
| 220 : | pazsan | 1.21 | : .server ( -- ) ." Server: Gforth httpd/1.0 (" |
| 221 : | pazsan | 1.2 | s" os-class" environment? IF type THEN ." )" cr ; |
| 222 : | pazsan | 1.5 | : .ok ( -- ) ." HTTP/1.1 200 OK" cr .server ; |
| 223 : | pazsan | 1.1 | : html-error ( n addr u -- ) |
| 224 : | pazsan | 1.2 | ." HTTP/1.1 " 2 pick . 2dup type cr .server |
| 225 : | pazsan | 1.5 | 2 pick &405 = IF ." Allow: GET, HEAD, POST" cr THEN |
| 226 : | lastrequest | ||
| 227 : | ." <HTML><HEAD><TITLE>" 2 pick . 2dup type | ||
| 228 : | ." </TITLE></HEAD>" cr | ||
| 229 : | pazsan | 1.1 | ." <BODY><H1>" type drop ." </H1>" cr ; |
| 230 : | : .trailer ( -- ) | ||
| 231 : | pazsan | 1.21 | ." <HR><ADDRESS>Gforth httpd 1.0</ADDRESS>" cr |
| 232 : | pazsan | 1.1 | ." </BODY></HTML>" cr ; |
| 233 : | pazsan | 1.5 | : .nok ( -- ) command? @ IF &405 s" Method Not Allowed" |
| 234 : | pazsan | 1.2 | ELSE &400 s" Bad Request" THEN html-error |
| 235 : | pazsan | 1.5 | ." <P>Your browser sent a request that this server " |
| 236 : | ." could not understand.</P>" cr | ||
| 237 : | ." <P>Invalid request in: <CODE>" | ||
| 238 : | error-stack cell+ 2@ swap type | ||
| 239 : | pazsan | 1.1 | ." </CODE></P>" cr .trailer ; |
| 240 : | pazsan | 1.5 | : .nofile ( -- ) &404 s" Not Found" html-error |
| 241 : | pazsan | 1.1 | ." <P>The requested URL <CODE>" url $@ type |
| 242 : | ." </CODE> was not found on this server</P>" cr .trailer ; | ||
| 243 : | |||
| 244 : | \ http server 26mar00py | ||
| 245 : | |||
| 246 : | pazsan | 1.9 | Defer redirect? ( addr u -- addr' u' t / f ) |
| 247 : | Defer redirect ( addr u -- ) | ||
| 248 : | :noname 2drop false ; IS redirect? | ||
| 249 : | |||
| 250 : | pazsan | 1.5 | : http ( -- ) get-input IF .nok ELSE |
| 251 : | pazsan | 1.9 | IF url $@ 1 /string 2dup redirect? IF redirect 2drop ELSE |
| 252 : | rework-htmldir | ||
| 253 : | pazsan | 1.1 | dup 0< IF drop .nofile |
| 254 : | ELSE .ok 2dup >mime mime search-wordlist | ||
| 255 : | pazsan | 1.2 | 0= IF ['] txt THEN catch IF maxnum off THEN |
| 256 : | pazsan | 1.9 | THEN THEN THEN THEN outfile-id flush-file throw ; |
| 257 : | pazsan | 1.1 | |
| 258 : | pazsan | 1.11 | : httpd ( n -- ) dup maxnum ! 0 <# #S #> Keep-Alive $! |
| 259 : | pazsan | 1.15 | maxnum @ 0 DO ['] http catch maxnum @ 0= or ?LEAVE LOOP ; |
| 260 : | pazsan | 1.1 | |
| 261 : | pazsan | 1.4 | script? [IF] :noname &100 httpd bye ; is bootmessage [THEN] |
| 262 : | pazsan | 1.5 | |
| 263 : | \ Use Forth as server-side script language 26mar00py | ||
| 264 : | |||
| 265 : | : $> ( -- ) | ||
| 266 : | BEGIN source >in @ /string s" <$" search 0= WHILE | ||
| 267 : | type cr refill 0= UNTIL EXIT THEN | ||
| 268 : | nip source >in @ /string rot - dup 2 + >in +! type ; | ||
| 269 : | : <HTML> ( -- ) ." <HTML>" $> ; | ||
| 270 : | pazsan | 1.9 | |
| 271 : | \ provide transparent proxying | ||
| 272 : | |||
| 273 : | pazsan | 1.10 | include ./proxy.fs |
|
CVS Admin Powered by ViewCVS 1.0-dev |
ViewCVS and CVS Help |