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