--- gforth/httpd.fs 2000/03/26 20:38:17 1.1 +++ gforth/httpd.fs 2000/04/12 20:53:46 1.5 @@ -5,42 +5,69 @@ warnings off include string.fs Variable url +Variable posted +Variable url-args Variable protocol +Variable data +Variable active +Variable command? : get ( addr -- ) name rot $! ; : get-rest ( addr -- ) source >in @ /string dup >in +! rot $! ; -Table constant http/1.0 +wordlist constant values +wordlist constant commands -: rest: ( -- ) name +: value: ( -- ) name Forth definitions 2dup 1- nextname Variable - http/1.0 set-current nextname here cell - Create , + values set-current nextname here cell - Create , DOES> @ get-rest ; +: >values values 1 set-order command? off ; -\ HTTP protocol 26mar00py +\ HTTP protocol commands 26mar00py -http/1.0 set-current - -: GET url get protocol get-rest ; -rest: User-Agent: -rest: Pragma: -rest: Host: -rest: Accept: -rest: Accept-Encoding: -rest: Accept-Language: -rest: Accept-Charset: -rest: Via: -rest: X-Forwarded-For: -rest: Cache-Control: -rest: Connection: -rest: Referer: +: rework-% ( add -- ) { url } base @ >r hex + 0 url $@len 0 ?DO + url $@ drop I + c@ dup '% = IF + drop 0. url $@ I 1+ /string + 2 min dup >r >number r> swap - >r 2drop + ELSE 0 >r THEN over url $@ drop + c! 1+ + r> 1+ +LOOP url $!len + r> base ! ; + +: rework-? ( addr -- ) + dup >r $@ '? $split url-args $! nip r> $!len ; + +: get-url ( -- ) url get protocol get-rest + url rework-? url rework-% >values ; + +commands set-current + +: GET get-url data on active off ; +: POST get-url data on active on ; +: HEAD get-url data off active off ; + +\ HTTP protocol values 26mar00py + +values set-current + +value: User-Agent: +value: Pragma: +value: Host: +value: Accept: +value: Accept-Encoding: +value: Accept-Language: +value: Accept-Charset: +value: Via: +value: X-Forwarded-For: +value: Cache-Control: +value: Connection: +value: Referer: +value: Content-Type: +value: Content-Length: definitions -s" close" connection $! -s" /nosuchfile" url $! -s" HTTP/1.0" protocol $! - Variable maxnum : ?cr ( -- ) @@ -49,26 +76,13 @@ Variable maxnum BEGIN refill ?cr WHILE interpret >in @ 0= UNTIL true ELSE maxnum off false THEN ; : get-input ( -- flag ior ) - infile-id push-file loadfile ! 0 loadline ! blk off - http/1.0 1 set-order ['] refill-loop catch - only forth also pop-file ; - -\ Keep-Alive handling 26mar00py - -: .connection ( -- ) - ." Connection: " - connection $@ s" Keep-Alive" compare 0= maxnum @ 0> and - IF connection $@ type cr - ." Keep-Alive: timeout=15, max=" maxnum @ 0 .r cr - -1 maxnum +! ELSE ." close" cr maxnum off THEN ; - -\ Use Forth as server-side script language 26mar00py - -: $> ( -- ) - BEGIN source >in @ /string s" <$" search 0= WHILE - type cr refill 0= UNTIL EXIT THEN - nip source >in @ /string rot - dup 2 + >in +! type ; -: ( -- ) ." " $> ; + s" /nosuchfile" url $! s" HTTP/1.0" protocol $! + s" close" connection $! + infile-id push-file loadfile ! loadline off blk off + commands 1 set-order command? on ['] refill-loop catch + active @ IF s" " posted $! Content-Length $@ snumber? drop + posted $!len posted $@ infile-id read-file throw drop + THEN only forth also pop-file ; \ Rework HTML directory 26mar00py @@ -95,18 +109,37 @@ Variable htmldir r@ file-size throw drop ." Accept-Ranges: bytes" cr ." Content-Length: " dup 0 .r cr r> ; -: transparent ( size fd -- ) >r - dup allocate throw swap - over swap r@ read-file throw over swap type - free r> close-file throw throw ; +: transparent ( size fd -- ) { fd } + $4000 allocate throw swap dup 0 ?DO + 2dup over swap $4000 min fd read-file throw type + $4000 - $4000 +LOOP drop + free fd close-file throw throw ; -: transparent: Create ," DOES> >r >file +\ Keep-Alive handling 26mar00py + +: .connection ( -- ) + ." Connection: " + connection $@ s" Keep-Alive" compare 0= maxnum @ 0> and + IF connection $@ type cr + ." Keep-Alive: timeout=15, max=" maxnum @ 0 .r cr + -1 maxnum +! ELSE ." close" cr maxnum off THEN ; + +: transparent: ( addr u -- ) Create here over 1+ allot place + DOES> >r >file .connection ." Content-Type: " r> count type cr cr - transparent ; + data @ IF transparent ELSE nip close-file throw THEN ; \ mime types 26mar00py +: mime-read ( addr u -- ) r/o open-file throw + push-file loadfile ! 0 loadline ! blk off + BEGIN refill WHILE name + BEGIN >in @ >r name nip WHILE + r> >in ! 2dup transparent: REPEAT + 2drop rdrop + REPEAT loadfile @ close-file pop-file throw ; + : lastrequest ." Connection: close" cr maxnum off ." Content-Type: text/html" cr cr ; @@ -114,51 +147,62 @@ Variable htmldir wordlist constant mime mime set-current -: shtml ( addr u -- ) lastrequest included ; +: shtml ( addr u -- ) lastrequest + data @ IF included ELSE 2drop THEN ; -transparent: html text/html" -transparent: gif image/gif" -transparent: jpg image/jpeg" -transparent: png image/png" -transparent: gz application/x-gzip" -transparent: bz2 application/x-bzip2" -transparent: exe application/octet-stream" -transparent: class application/octet-stream" -transparent: sig application/pgp-signature" -transparent: txt text/plain" +s" application/pgp-signature" transparent: sig +s" application/x-bzip2" transparent: bz2 +s" application/x-gzip" transparent: gz +s" /etc/mime.types" mime-read definitions -lastxt @ Alias txt +s" text/plain" transparent: txt \ http errors 26mar00py -: .ok ." HTTP/1.1 200 OK" cr ; +: .server ( -- ) ." Server: Gforth httpd/0.1 (" + s" os-class" environment? IF type THEN ." )" cr ; +: .ok ( -- ) ." HTTP/1.1 200 OK" cr .server ; : html-error ( n addr u -- ) - ." HTTP/1.1 " 2 pick . 2dup type cr lastrequest - ." " 2 pick . 2dup type ." " cr + ." HTTP/1.1 " 2 pick . 2dup type cr .server + 2 pick &405 = IF ." Allow: GET, HEAD, POST" cr THEN + lastrequest + ." " 2 pick . 2dup type + ." " cr ."

" type drop ."

" cr ; : .trailer ( -- ) ."
Gforth httpd 0.1
" cr ." " cr ; -: .nok &400 s" Bad Request" html-error - ."

Your browser sent a request that this server could not understand.

" cr - ."

Invalid request in: " error-stack cell+ 2@ swap type +: .nok ( -- ) command? @ IF &405 s" Method Not Allowed" + ELSE &400 s" Bad Request" THEN html-error + ."

Your browser sent a request that this server " + ." could not understand.

" cr + ."

Invalid request in: " + error-stack cell+ 2@ swap type ."

" cr .trailer ; -: .nofile &404 s" Not Found" html-error +: .nofile ( -- ) &404 s" Not Found" html-error ."

The requested URL " url $@ type ." was not found on this server

" cr .trailer ; \ http server 26mar00py -: http get-input IF .nok ELSE +: http ( -- ) get-input IF .nok ELSE IF url $@ 1 /string rework-htmldir dup 0< IF drop .nofile ELSE .ok 2dup >mime mime search-wordlist - IF catch IF maxnum off THEN ELSE txt THEN + 0= IF ['] txt THEN catch IF maxnum off THEN THEN THEN THEN outfile-id flush-file throw ; : httpd ( n -- ) maxnum ! - BEGIN http maxnum @ 0= UNTIL ; + BEGIN ['] http catch maxnum @ 0= or UNTIL ; + +script? [IF] :noname &100 httpd bye ; is bootmessage [THEN] -( script? [IF] ) &100 httpd bye ( [THEN] ) +\ Use Forth as server-side script language 26mar00py + +: $> ( -- ) + BEGIN source >in @ /string s" <$" search 0= WHILE + type cr refill 0= UNTIL EXIT THEN + nip source >in @ /string rot - dup 2 + >in +! type ; +: ( -- ) ." " $> ;