[BACK]Return to httpd.fs CVS log [TXT] [DIR] Up to [gforth] / gforth
File:  [gforth] / gforth / httpd.fs
Revision 1.1: download - view: text, annotated - select for diffs
Sun Mar 26 20:38:17 2000 UTC (24 years, 1 month ago) by pazsan
Branches: MAIN
CVS tags: HEAD
Added a tiny web server as example

    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>