Annotation of gforth/httpd.fs, revision 1.1
1.1 ! pazsan 1: #! /usr/local/bin/gforth
! 2:
! 3: warnings off
! 4:
! 5: include string.fs
! 6:
! 7: Variable url
! 8: Variable protocol
! 9:
! 10: : get ( addr -- ) name rot $! ;
! 11: : get-rest ( addr -- ) source >in @ /string dup >in +! rot $! ;
! 12:
! 13: Table constant http/1.0
! 14:
! 15: : rest: ( -- ) name
! 16: Forth definitions 2dup 1- nextname Variable
! 17: http/1.0 set-current nextname here cell - Create ,
! 18: DOES> @ get-rest ;
! 19:
! 20: \ HTTP protocol 26mar00py
! 21:
! 22: http/1.0 set-current
! 23:
! 24: : GET url get protocol get-rest ;
! 25: rest: User-Agent:
! 26: rest: Pragma:
! 27: rest: Host:
! 28: rest: Accept:
! 29: rest: Accept-Encoding:
! 30: rest: Accept-Language:
! 31: rest: Accept-Charset:
! 32: rest: Via:
! 33: rest: X-Forwarded-For:
! 34: rest: Cache-Control:
! 35: rest: Connection:
! 36: rest: Referer:
! 37:
! 38: definitions
! 39:
! 40: s" close" connection $!
! 41: s" /nosuchfile" url $!
! 42: s" HTTP/1.0" protocol $!
! 43:
! 44: Variable maxnum
! 45:
! 46: : ?cr ( -- )
! 47: #tib @ 1 >= IF source 1- + c@ #cr = #tib +! THEN ;
! 48: : refill-loop ( -- flag )
! 49: BEGIN refill ?cr WHILE interpret >in @ 0= UNTIL
! 50: true ELSE maxnum off false THEN ;
! 51: : get-input ( -- flag ior )
! 52: infile-id push-file loadfile ! 0 loadline ! blk off
! 53: http/1.0 1 set-order ['] refill-loop catch
! 54: only forth also pop-file ;
! 55:
! 56: \ Keep-Alive handling 26mar00py
! 57:
! 58: : .connection ( -- )
! 59: ." Connection: "
! 60: connection $@ s" Keep-Alive" compare 0= maxnum @ 0> and
! 61: IF connection $@ type cr
! 62: ." Keep-Alive: timeout=15, max=" maxnum @ 0 .r cr
! 63: -1 maxnum +! ELSE ." close" cr maxnum off THEN ;
! 64:
! 65: \ Use Forth as server-side script language 26mar00py
! 66:
! 67: : $> ( -- )
! 68: BEGIN source >in @ /string s" <$" search 0= WHILE
! 69: type cr refill 0= UNTIL EXIT THEN
! 70: nip source >in @ /string rot - dup 2 + >in +! type ;
! 71: : <HTML> ( -- ) ." <HTML>" $> ;
! 72:
! 73: \ Rework HTML directory 26mar00py
! 74:
! 75: Variable htmldir
! 76:
! 77: : rework-htmldir ( addr u -- addr' u' / ior )
! 78: htmldir $!
! 79: htmldir $@ 1 min s" ~" compare 0=
! 80: IF s" /.html-data" htmldir dup $@ 2dup '/ scan
! 81: nip - nip $ins
! 82: ELSE s" /usr/local/httpd/htdocs/" htmldir 0 $ins THEN
! 83: htmldir $@ 1- 0 max + c@ '/ = htmldir $@len 0= or
! 84: IF s" index.html" htmldir dup $@len $ins THEN
! 85: htmldir $@ file-status nip ?dup ?EXIT
! 86: htmldir $@ ;
! 87:
! 88: \ MIME type handling 26mar00py
! 89:
! 90: : >mime ( addr u -- mime u' ) 2dup tuck over + 1- ?DO
! 91: I c@ '. = ?LEAVE 1- -1 +LOOP /string ;
! 92:
! 93: : >file ( addr u -- size fd )
! 94: r/o bin open-file throw >r
! 95: r@ file-size throw drop
! 96: ." Accept-Ranges: bytes" cr
! 97: ." Content-Length: " dup 0 .r cr r> ;
! 98: : transparent ( size fd -- ) >r
! 99: dup allocate throw swap
! 100: over swap r@ read-file throw over swap type
! 101: free r> close-file throw throw ;
! 102:
! 103: : transparent: Create ," DOES> >r >file
! 104: .connection
! 105: ." Content-Type: " r> count type cr cr
! 106: transparent ;
! 107:
! 108: \ mime types 26mar00py
! 109:
! 110: : lastrequest
! 111: ." Connection: close" cr maxnum off
! 112: ." Content-Type: text/html" cr cr ;
! 113:
! 114: wordlist constant mime
! 115: mime set-current
! 116:
! 117: : shtml ( addr u -- ) lastrequest included ;
! 118:
! 119: transparent: html text/html"
! 120: transparent: gif image/gif"
! 121: transparent: jpg image/jpeg"
! 122: transparent: png image/png"
! 123: transparent: gz application/x-gzip"
! 124: transparent: bz2 application/x-bzip2"
! 125: transparent: exe application/octet-stream"
! 126: transparent: class application/octet-stream"
! 127: transparent: sig application/pgp-signature"
! 128: transparent: txt text/plain"
! 129:
! 130: definitions
! 131:
! 132: lastxt @ Alias txt
! 133:
! 134: \ http errors 26mar00py
! 135:
! 136: : .ok ." HTTP/1.1 200 OK" cr ;
! 137: : html-error ( n addr u -- )
! 138: ." HTTP/1.1 " 2 pick . 2dup type cr lastrequest
! 139: ." <HTML><HEAD><TITLE>" 2 pick . 2dup type ." </TITLE></HEAD>" cr
! 140: ." <BODY><H1>" type drop ." </H1>" cr ;
! 141: : .trailer ( -- )
! 142: ." <HR><ADDRESS>Gforth httpd 0.1</ADDRESS>" cr
! 143: ." </BODY></HTML>" cr ;
! 144: : .nok &400 s" Bad Request" html-error
! 145: ." <P>Your browser sent a request that this server could not understand.</P>" cr
! 146: ." <P>Invalid request in: <CODE>" error-stack cell+ 2@ swap type
! 147: ." </CODE></P>" cr .trailer ;
! 148: : .nofile &404 s" Not Found" html-error
! 149: ." <P>The requested URL <CODE>" url $@ type
! 150: ." </CODE> was not found on this server</P>" cr .trailer ;
! 151:
! 152: \ http server 26mar00py
! 153:
! 154: : http get-input IF .nok ELSE
! 155: IF url $@ 1 /string rework-htmldir
! 156: dup 0< IF drop .nofile
! 157: ELSE .ok 2dup >mime mime search-wordlist
! 158: IF catch IF maxnum off THEN ELSE txt THEN
! 159: THEN THEN THEN outfile-id flush-file throw ;
! 160:
! 161: : httpd ( n -- ) maxnum !
! 162: BEGIN http maxnum @ 0= UNTIL ;
! 163:
! 164: ( script? [IF] ) &100 httpd bye ( [THEN] )
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to httpd.fs CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [gforth] / gforth