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