Diff for /gforth/httpd.fs between versions 1.4 and 1.10

version 1.4, 2000/04/09 20:57:25 version 1.10, 2001/11/11 22:33:31
Line 1 Line 1
 #! /usr/local/bin/gforth  #! /usr/local/bin/gforth
   
   \ Copyright (C) 2000 Free Software Foundation, Inc.
   
   \ This file is part of Gforth.
   
   \ Gforth is free software; you can redistribute it and/or
   \ modify it under the terms of the GNU General Public License
   \ as published by the Free Software Foundation; either version 2
   \ of the License, or (at your option) any later version.
   
   \ This program is distributed in the hope that it will be useful,
   \ but WITHOUT ANY WARRANTY; without even the implied warranty of
   \ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   \ GNU General Public License for more details.
   
   \ You should have received a copy of the GNU General Public License
   \ along with this program; if not, write to the Free Software
   \ Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111, USA.
   
 warnings off  warnings off
   
 include string.fs  require string.fs
   
 Variable url  Variable url
 Variable posted  Variable posted
Line 35  wordlist constant commands Line 53  wordlist constant commands
     r> 1+ +LOOP  url $!len      r> 1+ +LOOP  url $!len
     r> base ! ;      r> base ! ;
   
 : rework-? ( addr -- ) { url }  : rework-? ( addr -- )
     url $@ tuck '? scan tuck dup 0<> - url-args $! - url $!len ;      dup >r $@ '? $split url-args $! nip r> $!len ;
   
 : get-url  url get protocol get-rest  : get-url ( -- ) url get protocol get-rest
     url rework-? url rework-% >values ;      url rework-? url rework-% >values ;
   
 commands set-current  commands set-current
Line 84  Variable maxnum Line 102  Variable maxnum
       posted $!len  posted $@ infile-id read-file throw drop        posted $!len  posted $@ infile-id read-file throw drop
   THEN  only forth also  pop-file ;    THEN  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 ;  
 : <HTML> ( -- )  ." <HTML>" $> ;  
   
 \ Rework HTML directory                                26mar00py  \ Rework HTML directory                                26mar00py
   
 Variable htmldir  Variable htmldir
Line 132  Variable htmldir Line 133  Variable htmldir
         $4000 - $4000 +LOOP  drop          $4000 - $4000 +LOOP  drop
     free fd close-file throw throw ;      free fd close-file throw throw ;
   
   \ 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  : transparent: ( addr u -- ) Create  here over 1+ allot place
   DOES>  >r  >file    DOES>  >r  >file
   .connection    .connection
Line 169  s" text/plain" transparent: txt Line 179  s" text/plain" transparent: txt
   
 \ http errors                                          26mar00py  \ http errors                                          26mar00py
   
 : .server ." Server: Gforth httpd/0.1 ("  : .server ( -- )  ." Server: Gforth httpd/0.1 ("
     s" os-class" environment? IF  type  THEN  ." )" cr ;      s" os-class" environment? IF  type  THEN  ." )" cr ;
 : .ok   ." HTTP/1.1 200 OK" cr .server ;  : .ok  ( -- ) ." HTTP/1.1 200 OK" cr .server ;
 : html-error ( n addr u -- )  : html-error ( n addr u -- )
     ." HTTP/1.1 " 2 pick . 2dup type cr .server      ." HTTP/1.1 " 2 pick . 2dup type cr .server
     2 pick &405 = IF ." Allow: GET, HEAD, POST" cr  THEN  lastrequest      2 pick &405 = IF ." Allow: GET, HEAD, POST" cr  THEN
     ." <HTML><HEAD><TITLE>" 2 pick . 2dup type ." </TITLE></HEAD>" cr      lastrequest
       ." <HTML><HEAD><TITLE>" 2 pick . 2dup type
       ." </TITLE></HEAD>" cr
     ." <BODY><H1>" type drop ." </H1>" cr ;      ." <BODY><H1>" type drop ." </H1>" cr ;
 : .trailer ( -- )  : .trailer ( -- )
     ." <HR><ADDRESS>Gforth httpd 0.1</ADDRESS>" cr      ." <HR><ADDRESS>Gforth httpd 0.1</ADDRESS>" cr
     ." </BODY></HTML>" cr ;      ." </BODY></HTML>" cr ;
 : .nok  command? @ IF  &405 s" Method Not Allowed"  : .nok ( -- ) command? @ IF  &405 s" Method Not Allowed"
     ELSE  &400 s" Bad Request"  THEN  html-error      ELSE  &400 s" Bad Request"  THEN  html-error
     ." <P>Your browser sent a request that this server could not understand.</P>" cr      ." <P>Your browser sent a request that this server "
     ." <P>Invalid request in: <CODE>" error-stack cell+ 2@ swap type      ." could not understand.</P>" cr
       ." <P>Invalid request in: <CODE>"
       error-stack cell+ 2@ swap type
     ." </CODE></P>" cr .trailer ;      ." </CODE></P>" cr .trailer ;
 : .nofile  &404 s" Not Found" html-error  : .nofile ( -- ) &404 s" Not Found" html-error
     ." <P>The requested URL <CODE>" url $@ type      ." <P>The requested URL <CODE>" url $@ type
     ." </CODE> was not found on this server</P>" cr .trailer ;      ." </CODE> was not found on this server</P>" cr .trailer ;
   
 \ http server                                          26mar00py  \ http server                                          26mar00py
   
 : http  get-input  IF  .nok  ELSE  Defer redirect?  ( addr u -- addr' u' t / f )
     IF  url $@ 1 /string rework-htmldir  Defer redirect ( addr u -- )
   :noname 2drop false ; IS redirect?
   
   : http ( -- )  get-input  IF  .nok  ELSE
       IF  url $@ 1 /string 2dup redirect? IF  redirect 2drop  ELSE
           rework-htmldir
         dup 0< IF  drop .nofile          dup 0< IF  drop .nofile
         ELSE  .ok  2dup >mime mime search-wordlist          ELSE  .ok  2dup >mime mime search-wordlist
             0= IF  ['] txt  THEN  catch IF  maxnum off THEN              0= IF  ['] txt  THEN  catch IF  maxnum off THEN
         THEN  THEN  THEN  outfile-id flush-file throw ;          THEN  THEN  THEN  THEN  outfile-id flush-file throw ;
   
 : httpd  ( n -- )  maxnum !  : httpd  ( n -- )  maxnum !
   BEGIN  ['] http catch  maxnum @ 0= or  UNTIL ;    BEGIN  ['] http catch  maxnum @ 0= or  UNTIL ;
   
 script? [IF]  :noname &100 httpd bye ; is bootmessage  [THEN]  script? [IF]  :noname &100 httpd bye ; is bootmessage  [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 ;
   : <HTML> ( -- )  ." <HTML>" $> ;
   
   \ provide transparent proxying
   
   include ./proxy.fs

Removed from v.1.4  
changed lines
  Added in v.1.10


FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>