Menu
▾
▴
win32forth-cvs
Update of /cvsroot/win32forth/win32forth/apps/Internet/WebServer In directory sc8-pr-cvs9.sourceforge.net:/tmp/cvs-serv14911 Added Files: DSTR.F HTTP.F HTTPecho.f HTTPerr.F HTTPfile.F HTTPmime.F SCOOP.F WebServer.F sockserv.f Log Message: Jos: Added the webserver of Thomas Dixon --- NEW FILE: HTTPecho.f --- \ HTTP Server Component - Echo \ Tom Dixon \ This just repeats back the request when the url starts with /echo/ \ Usefull for debugging with httpreq : doEcho ( -- flag ) url [char] / scan [char] / skip 2dup [char] / scan nip - s" ECHO" istr= if with dstr reply free cr s" <HTML><BODY><PRE>" reply append request count reply append s" </PRE></BODY></HTML>" reply append endwith 200 code ! true else false then ; doURL doEcho http-done endwith --- NEW FILE: HTTPfile.F --- \ HTTP Server Component - Files \ Tom Dixon \ URL points to a file create webpath 256 allot s" c:\cprparse\" webpath place : chreplace ( newch oldch str len -- ) over + swap ?do dup i c@ = if over i c! then loop 2drop ; with httpreq : doURLFile ( -- flag ) webpath count hbuf place url [char] / scan [char] / skip 2dup [char] ? scan nip - hbuf +place [char] \ [char] / hbuf count chreplace hbuf count + 1- c@ [char] \ = if s" \index.html" hbuf +place then hbuf count r/o open-file if drop false exit then file ! hbuf count get-mediatype s" Content-Type: " type type cr cr true ; doURL doURLFile http-done endwith --- NEW FILE: HTTP.F --- \ Simple HTTP Server \ Tom Dixon needs SCOOP \ scopes needs DSTR \ dynamic strings needs sock \ socket library needs sockserv \ socket server extention needs HTTPerr \ http error codes \ Make the http request object scope httpreq with httpreq definitions \ Size of a request 2 cells with dstr size endwith 2 * + CONSTANT size \ Data members : code ( -- addr ) servdata ; : file ( -- addr ) servdata cell+ ; : request ( -- dstr ) servdata 2 cells + ; : reply ( -- dstr ) servdata with dstr size endwith + 2 cells + ; 1000 CONSTANT pktsize \ size of chunk to send create stopstr 4 c, 13 c, 10 c, 13 c, 10 c, create hbuf 256 allot \ temporary buffer 0 value urllist \ URL processing list defer next-req ' noop is next-req \ pass on to next request : freestrs ( -- ) \ free all strings and files with dstr request free reply free endwith file @ if file @ close-file drop 0 file ! then ; : -lf ( addr len -- addr len ) \ trim the last line feed dup if 2dup + 1- c@ 13 = if 1- then then ; : toline ( n str len -- str len ) \ get the nth line rot 0 ?do 10 scan 10 skip loop 2dup 10 scan nip - -lf ; : toarg ( n str len -- str len ) \ get the nth argument rot 0 ?do bl scan bl skip loop 2dup bl scan nip - ; : getparam ( arg line -- str len ) \ get a parameter from the header request with dstr count endwith toline toarg ; : param ( str len -- str len ) \ gets a HTTP header parameter with dstr request count 2swap search if bl scan bl skip 2dup 10 scan nip - -lf -trailing else 2drop s" " then endwith ; : url ( -- str len ) 1 0 getparam ; \ requested URL : (crcr?) ( dstr -- str len flag ) with dstr count endwith stopstr count search ; : crcr? ( -- str len flag ) request (crcr?) ; \ search for double cr : bodylen ( -- n ) \ size of body file @ if file @ file-size drop d>s else reply (crcr?) if nip 4 - else 2drop 0 then then ; : stdheader ( -- ) \ generate a standard header s" HTTP/1.1 " hbuf place code @ (.) hbuf +place s" " hbuf +place code @ err-code hbuf +place stopstr 1+ 2 hbuf +place s" Server: Win32forth " hbuf +place version# (.) hbuf +place s" " hbuf +place build# (.) hbuf +place stopstr 1+ 2 hbuf +place bodylen if s" Content-Length: " hbuf +place bodylen (.) hbuf +place then stopstr 1+ 2 hbuf +place hbuf count reply with dstr prepend endwith ; \ socket server vectors : http-connect ( -- ) freestrs ; : http-Close ( -- ) freestrs ; : http-write ( -- ) begin servsock sock-write? 0> while code @ reply with dstr count nip endwith >= if file @ if hbuf 256 file @ read-file drop dup if hbuf swap servsock sock-write drop else drop next-req exit then else next-req exit then else code @ pktsize reply with dstr mid endwith servsock sock-write code +! then repeat ; : http-done ( -- ) stdheader 0 code ! ['] http-write onWrite! ; : process ( -- ) urllist >r begin r@ while r@ cell+ @ execute if r> 2 cells + @ onWrite! exit then r> lrest >r repeat r@ drop ; : http-read ( -- ) begin servsock sock-read? 0> while hbuf 255 servsock sock-read hbuf swap request with dstr append endwith drop true repeat crcr? nip nip if 200 code ! ['] process onWrite! ['] noop onRead! then ; \ Start next request : connclose? ( -- flag ) s" Connection:" param s" close" istr= reply with dstr count endwith s" Content-Length:" search nip nip 0= or ; : next-request ( -- ) file @ if file @ close-file drop 0 file ! then connclose? if freestrs close-client exit then crcr? if 4 /string with dstr reply place reply count request place reply free endwith else with dstr request free endwith then ['] noop onWrite! ['] http-read onRead! ; ' next-request is next-req \ some simple IO overloading : type ( str len -- ) reply with dstr append endwith ; : cr ( -- ) stopstr count drop 2 type ; : emit ( n -- ) hbuf c! hbuf 1 type ; : space ( -- ) bl emit ; : . ( n -- ) (.) type ; : ." ( "str" -- ) [char] " parse type ; endwiths definitions \ Setup the initial vectors of a HTTP server : setup-http ( server -- ) serv-vecselect with httpreq ['] http-connect onConnect! ['] http-read onRead! ['] http-close onClose! ['] noop onWrite! endwith ; \ Define a HTTP Server : httpserver ( port <name> -- ) with httpreq size endwith swap sockserver ; \ This is how you add components to the http server : doURL ( <test-xt> <do-xt> -- ) node, ' , ' , with httpreq urllist cons to urllist endwith ; \ test-xt returns a flag if the compnent accepts the request. \ if accepted, do-xt will be called repetatively each time \ the server polls until 'http-done' is called by it. \ default behavior for HTTP server with httpreq : doNotFound ( -- ) 404 code ! s" <html><body>HTTP Error 404 - File or directory not found.</body></html>" type http-done ; doURL true doNotFound endwith \ extra functionality is added to the HTTP server through \ the 'doURL' function. See HTTPecho for a simple example. --- NEW FILE: HTTPerr.F --- \ HTTP Error Codes \ Thomas Dixon : err-code ( n -- err ) \ translates some of the many many error codes case 200 of s" OK" exit endof 201 of s" Created" exit endof 202 of s" Accepted" exit endof 203 of s" Non-Authoritative Information" exit endof 204 of s" No Content" exit endof 205 of s" Reset Content" exit endof 206 of s" Partial Content" exit endof 300 of s" Multiple Choices" exit endof 301 of s" Moved Permanently" exit endof 302 of s" Found" exit endof 303 of s" See Other" exit endof 304 of s" Not Modified" exit endof 305 of s" Use Proxy" exit endof 306 of s" (Unused)" exit endof 307 of s" Temporary Redirect" exit endof 400 of s" Bad Request" exit endof 401 of s" Unauthorized" exit endof 402 of s" Payment Required" exit endof 403 of s" Forbidden" exit endof 404 of s" Not Found" exit endof 405 of s" Method Not Allowed" exit endof 406 of s" Not Acceptable" exit endof 407 of s" Proxy Authentication Required" exit endof 408 of s" Request Timeout" exit endof 409 of s" Conflict" exit endof 410 of s" Gone" exit endof 411 of s" Length Required" exit endof 412 of s" Precondition Failed" exit endof 413 of s" Request Entity Too Large" exit endof 414 of s" Request-URI Too Long" exit endof 415 of s" Unsupported Media Type" exit endof 416 of s" Requested Range Not Satisfiable" exit endof 417 of s" Expectation Failed" exit endof 500 of s" Internal Sever Error" exit endof 501 of s" Not Implemented" exit endof 502 of s" Bad Gateway" exit endof 503 of s" Service Unavailable" exit endof 504 of s" Gateway Timeout" exit endof 505 of s" HTTP Version Not Supported" exit endof endcase s" Error" ; --- NEW FILE: WebServer.F --- \ HTTP Web Server \ Tom Dixon needs http needs httpecho needs httpmime needs httpfile \ Setup Server 80 httpserver http http setup-http http serv-init \ Run the Server : www-server begin http serv-poll 10 ms key? until ; --- NEW FILE: sockserv.f --- \ Socket Server \ Tom Dixon \ *! SockServer \ *T Socket Library Extension for Servers \ *Q Tom Dixon \ *P This library is built off of the socket library and provides some \ ** generic support for socket servers. The current implementation is \ ** asycronous, single-threaded and is select-based and does not use \ ** the poll() function. needs Sock.F \ Socket Library \ Re-Define the list library if it is not already in the system [DEFINED] cons NOT [IF] : cons ( node list -- list ) over ! ; : lrest ( list -- list ) @ ; [THEN] \ This value ought to be made into a user variable to give it better \ multithreaded support. 0 value sservdata 6 cells constant servuser \ structure: |link|sock|onconnect|onread|onwrite|onclose| \ *S Socket Event Vectors \ ** These words are used to define the behavior of the sockets on the \ ** server.\n \ ** Each event is defined as a word with no stack effects ( -- ).\n \ ** Defining these vectors applies to the currently active client \ ** connection. If you want to set the default behavior for incoming \ ** client connections, please see 'serv-vecselect'. : OnClose! ( xt -- ) \ *G This word stores a new closure behavior for the socket connection. sservdata 5 cells + ! ; : doOnClose ( -- ) sservdata 5 cells + @ execute ; : OnRead! ( xt -- ) \ *G This word stores a new read behavior for the socket connection. sservdata 3 cells + ! ; : doOnRead ( -- ) sservdata 3 cells + @ execute ; : OnWrite! ( xt -- ) \ *G This word stores a new write behavior for the socket connection. sservdata 4 cells + ! ; : doOnWrite ( -- ) sservdata 4 cells + @ execute ; : OnConnect! ( xt -- ) \ *G This word stores a new connection behavior for the socket. sservdata 2 cells + ! ; : doOnConnect ( -- ) sservdata 2 cells + @ execute ; \ *S Global Socket Data \ ** When a socket event is being processed, these words contain are to \ ** be used in obtaining specific information about the request. : servdata ( -- addr ) \ *G Returns a pointer to the user-defined data area associated with \ ** every request. The size of this user area is specified by the \ ** server. sservdata servuser + ; : servsock ( -- sock ) \ *G Returns the socket that the event has been triggered on. sservdata cell+ @ ; : close-client ( -- ) \ *G Closes the current socket at frees up the memory from the server. servsock sock-close drop 0 sservdata cell+ ! ; \ *S Socket Server Words \ ** A socket server is the listening server that takes requests, \ ** processes them, and closes them. : serv-vecselect ( server -- ) \ *G Selects the server for vector behavior. Directly after this word \ ** is called, default behaviors for the entire server can be specified. 4 cells + to sservdata ; : sockserver ( datasize p <name> -- ) \ *G This word defines a socket server on port "p" and the size of the \ ** user-defined data area per client. create here serv-vecselect 0 , 0 , , servuser + , servuser allot ['] noop onconnect! ['] noop onwrite! ['] noop onread! ['] noop onclose! ; : serv-init ( server -- ) \ *G Initializes the server and starts listening for requests. dup 2 cells + @ sock-create dup rot ! 5 swap sock-listen ; : serv-close ( server -- ) \ *G Closes the server - open requests are still able to execute, though. dup @ sock-close drop 0 swap ! ; : serv-accept ( server -- ) begin dup @ sock-accept? while dup @ sock-accept drop ?dup if over 3 cells + @ allocate throw to sservdata sservdata cell+ ! dup 4 cells + 2 cells + sservdata 2 cells + 4 cells cmove dup cell+ lrest sservdata swap cons drop dup cell+ sservdata cons drop >r doOnConnect r> then repeat drop ; : (serv-poll) ( server -- ) cell+ @ to sservdata begin sservdata while servsock sock-err? if close-client then servsock sock-closed? if doOnClose close-client then servsock sock-read? if doOnRead then servsock sock-write? if doOnWrite then sservdata lrest to sservdata repeat ; : (serv-cleanup) ( server -- ) cell+ to sservdata begin sservdata lrest while sservdata lrest cell+ @ 0= if sservdata lrest dup lrest sservdata swap cons drop free throw then sservdata lrest ?dup if to sservdata then repeat ; : serv-poll ( server -- ) \ *G The meat-and-potatoes function of the socket server. This \ ** word will deal with all incoming socket requests, poll through \ ** and process existing socket requests, and cleanup after closed \ ** requests. dup serv-accept dup >r (serv-poll) r> (serv-cleanup) ; \ *S Example Code \ ** This is a simple test of the socket server code. Typing in the \ ** word 'demo' will start the test. Any incoming request will simply \ ** be printed to the console. (Yes, it's not very useful, but it is \ ** a minmal example of use. Please see other examples that should \ ** be with this file). \ *E 256 8000 sockserver test \ ** test serv-vecselect \ ** :noname servdata 256 servsock sock-read servdata swap type ; \ ** onread! \ ** \ ** test serv-init \ ** : demo begin test serv-poll 10 ms key? until ; --- NEW FILE: HTTPmime.F --- \ Mime Types \ Thomas Dixon : get-mediatype ( addr len -- addr len ) \ media type MIME translation [char] . scan [char] . skip drop 3 2dup s" htm" ISTR= if 2drop s" text/html" exit then 2dup s" txt" ISTR= if 2drop s" text/plain" exit then 2dup s" jpg" ISTR= if 2drop s" image/jpeg" exit then 2dup s" gif" ISTR= if 2drop s" image/gif" exit then 2dup s" bmp" ISTR= if 2drop s" image/x-xbitmap" exit then 2dup s" doc" ISTR= if 2drop s" application/msword" exit then 2dup s" rtf" ISTR= if 2drop s" application/rtf" exit then 2dup s" zip" ISTR= if 2drop s" application/zip" exit then 2dup s" avi" ISTR= if 2drop s" video/avi" exit then 2dup s" mpg" ISTR= if 2drop s" video/mpeg" exit then 2dup s" mov" ISTR= if 2drop s" video/quicktime" exit then 2dup s" wav" ISTR= if 2drop s" audio/wav" exit then 2dup s" mal" ISTR= if 2drop s" message/RFC822" exit then 2dup s" mp3" ISTR= if 2drop s" audio/mp3" exit then 2drop s" text/plain" ; --- NEW FILE: SCOOP.F --- \ SCOOP = Scoped Component Polymorphic library \ Tom Dixon \ This is a few simple words to allow development of \ Components and objects. Should be pretty easy to \ port to whatever. \ *** List Library *** : cons ( node list -- list ) over ! ; : lrest ( list -- list ) @ ; : node, ( -- node ) here 0 , ; : lmap ( xt list -- ) begin dup while 2dup 2>r CELL+ swap execute 2r> lrest repeat 2drop ; \ *** Parsing Helpers *** : atoi ( str len -- n ) 0 0 2swap >number 2drop d>s ; : peek-word ( -- str len ) >in @ parse-word rot >in ! ; : skip-word ( -- ) parse-word 2drop ; : peek ( -- str len ) begin peek-word dup 0= while refill 0= if exit else 2drop then repeat ; \ *** Simple Scoped Polymorphism Library *** sys-warning-off : scope ( <name> -- ) wordlist value ; 0 value withlength : with ( <name> -- ) withlength 1+ to withlength ' execute >r get-order r> swap 1+ set-order ; IMMEDIATE : endwith ( -- ) withlength 0= if exit then get-order nip 1- set-order withlength 1- to withlength ; IMMEDIATE : endwiths ( -- ) withlength 0 ?do ['] endwith execute loop ; : disp-bind ( xt f -- ) 0> if execute exit then state @ if compile, else execute then ; : (dispatch) ( str len scope -- ) search-wordlist dup if disp-bind else drop then ; : dispatch ( scope -- ) peek rot search-wordlist dup if skip-word disp-bind else drop then ; \ *** Simple Object Extentions to Scopes *** : osize ( scope -- n ) s" size" rot (dispatch) ; : object: ( scope -- ) create dup , osize allot IMMEDIATE does> dup cell+ state @ if POSTPONE literal else swap then @ dispatch ; : array: ( n scope -- ) create dup , osize dup , * allot IMMEDIATE does> dup >r 2 cells + r@ cell+ @ state @ if POSTPONE literal POSTPONE * POSTPONE literal POSTPONE + else rot * + then r> @ dispatch ; sys-warning-on --- NEW FILE: DSTR.F --- \ Dynamic Strings \ Tom Dixon scope dstr with dstr definitions 2 cells CONSTANT size : null? @ 0= ; : count ( o -- str len ) dup @ swap cell+ @ ; : . ( o -- ) [char] " emit count type [char] " emit ; : free ( o -- ) dup >r @ dup if free then drop 0 0 r> 2! ; : (buf+) ( len o -- addr ) dup >r cell+ @ + r> dup null? if drop allocate throw else @ swap resize throw then ; : append ( str len o -- ) >r dup r@ (buf+) dup r@ ! r@ CELL+ @ + swap dup r> CELL+ +! cmove ; : prepend ( str len 0 -- ) >r dup r@ (buf+) dup r@ ! 2dup + r@ CELL+ @ cmove> r@ @ swap dup r> CELL+ +! cmove ; : place ( str len o -- ) dup free append ; : Left ( n o -- str len ) count rot min ; : Right ( n o -- str len ) count rot /string ; : Mid ( start len o -- str len ) rot swap Right rot min ; endwiths definitions |
×
Want the latest updates on software, tech news, and AI?
Get latest updates about software, tech news, and AI from SourceForge directly in your inbox once a month.
Thanks for helping keep SourceForge clean.
X