\ 1991 include unix/socket.fs \ Helper words : +s ( addr1 u1 addr2 u2 -- addr3 u3 ) \ like s+ but prepend rather than append. 2swap s+ ; : str-count ( addr1 u1 addr2 u2 -- u3 ) \ Counts occurrences of addr2 within addr1. 2swap 0 >r begin 2over search while 2over nip /string r> 1+ >r repeat 2drop 2drop r> ; : exchange ( a1 a2 -- ) 2dup c@ swap c@ rot c! swap c! ; : reverse ( caddr u -- ) \ reverse a string 1- bounds begin 2dup > while 2dup exchange -1 /string repeat 2drop ; : sourcedir ( -- saddr su ) \ Returns the directory in which the file \ invoking the word finds itself \ relative to gforth's execution directory. \ Useful for specifying in which dir to find \ specific files (e.g., public/, views/). sourcefilename \ get the name of our file pad dup >r place \ copy the string so we don't r> count \ modify sourcefilename. 2dup reverse \ reverse and search for first / s" /" search if \ if found, reverse string to 2dup reverse \ strip the filename but keep dir. else 2drop \ no slash, s" ./" \ same dir execution. then ; : file-exists? ( addr u -- addr u bool ) 2dup file-status nip 0= ; : pubvar create 0 , 0 , ; \ Query params pubvar queryString : set-query-string ( addr u -- ) queryString 2! ; : get-query-string ( -- addr u ) queryString 2@ ; : add-to-query-string ( addr u -- ) get-query-string dup if \ If queryString isn't empty, add & before s" &" s+ then +s \ adding our new query values. set-query-string ; pubvar tmpQueryString : set-tmp-query-string ( addr u -- ) tmpQueryString 2! ; : get-tmp-query-string ( -- addr u ) tmpQueryString 2@ ; : add-to-tmp-query-string ( addr u -- ) get-tmp-query-string dup if \ If queryString isn't empty, add & before s" &" s+ then +s \ adding our new query values. set-tmp-query-string ; \ User-defined routing wordlist constant routes pubvar reqroute : set-requested-route ( addr u -- ) reqroute 2! ; : get-requested-route ( -- addr u ) reqroute 2@ ; : fuzzy-find-route ( xt -- xt' bool ) \ Takes an xt that accepts a name token \ and returns a bool. \ Traverse will run as long as xt \ returns true. \ Also takes the addr u of the requested \ route we're trying to validate. >r routes wordlist-id @ \ Store xt and specify wordlist begin dup while r@ over >r execute while r> @ repeat r> then rdrop ?dup if get-tmp-query-string \ Save our fuzzy vars to the request's add-to-query-string \ query real string. name>int \ Get the xt of the nt. -1 \ Return true. else 0 then ; : fuzzy-compare ( nt -- bool ) \ Takes a route name token and returns \ whether that route name fuzzy matches \ the requested url s" " set-tmp-query-string \ Reset tmp query string. name>string \ Get the string value of the NT. 2dup s" <" search if \ See if the route expects fuzzy matching. 2drop \ Drop search results. 2dup s" /" str-count >r \ Check to see if both routes have the same get-requested-route s" /" str-count \ number of / occurrences. r> = if 2dup s" <" str-count 0 do 2dup 2>r 2r@ 2dup s" <" search drop \ Get position of "<", swap drop - swap drop get-requested-route rot /string \ crop until there in the requested route, 2dup s" /" search if \ search for the next / or end of route, swap drop - else 2drop then \ ( 2dup 2r> 2swap 2>r 2>r \ (Store a copy of the real value of .) \ ) 2r@ 2dup s" <" search drop \ and replace <...> with the requested route word swap drop \ ( over over - 1+ 2r@ rot /string \ (Store the beginnings of user's <"match"> word.) 2dup s" >" search drop \ (Retrieve full <"match"> user word,) swap drop - s" =" s+ 2r> 2r> 2swap 2>r s+ \ (and associate it with the request value,) add-to-tmp-query-string \ (before saving it to the tmp query string.) \ ) - +s \ by prepending pre-< to route word 2r> s" >" search drop 1 /string \ and then by appending post-> to route word. s+ 2>r \ Save string progress, 2drop \ drop old string, 2r> \ set new string for start of next loop (or end). loop get-requested-route compare \ Check to see if the strings match. else 2drop \ Drop name>string. -1 \ Keep looping. then else 2drop \ Drop search results. 2drop \ Drop name>string. -1 \ Keep looping. then ; : fuzzy-match ( addr u -- xt bool ) set-requested-route ['] fuzzy-compare fuzzy-find-route ; : find-route ( addr u -- data ) 2dup 2>r routes search-wordlist if 2rdrop \ Exact match found. Drop the dup string. >body @ else 2r> fuzzy-match if \ Fuzzy match found. >body @ else 0 \ No match at all. then then ; : register-route ( data addr u -- ) 2dup routes search-wordlist if routes drop nip nip >body ! else routes get-current >r set-current \ switch definition word lists nextname create , r> set-current then ; \ Public directory pubvar public : set-public-path ( addr u -- ) public 2! ; : get-public-path ( -- addr u ) public 2@ ; sourcedir s" public" s+ set-public-path \ Views directory pubvar views : set-view-path ( addr u -- ) views 2! ; : get-view-path ( -- addr u ) views 2@ ; sourcedir s" views/" s+ set-view-path \ Needs that trailing slash \ Handling views pubvar viewoutput : set-view-output ( addr u -- ) viewoutput 2! ; : get-view-output ( -- addr u ) viewoutput 2@ ; : parse-view ( addr u -- ) \ Get string between <$ $> and invoke `evaluate`. \ Append to viewoutput as we go. \ There's probably a better way of doing this \ but it works for me. begin 2dup s" <$" search if 2over swap 2>r \ If there is a match for <$, save addr and u. swap >r dup >r \ Store the match and output anything that - \ comes before it. get-view-output +s set-view-output r> r> swap \ Then reinstate the match "<$...". 2dup s" $>" search if \ Check to see if there's a closing tag $>. 2 - \ Add the close tag to the search result. swap drop \ save the end position of $>. dup >r - \ Reduce the string to <$ ... $>. evaluate \ Run user's code (maybe a bad idea?). r> \ Retrieve our saved end position of $>. r> r> \ Retrive the addr u from start of loop iter. rot \ Bring end $> to stack top. over >r \ Store the real string's length. - \ Subtract end $> from u to get the pos from top r> swap \ that we'd like to strip away. Restore saved u. /string \ Drop top of the string until the end of $>. 0 \ Keep looping. else get-view-output +s \ No closing tag. Just save the full string. set-view-output 2rdrop \ And drop the stored addr and u 2drop \ as well as both the 2dup we made before 2drop \ searching twice. -1 \ Exit the loop. then else 2drop \ No match for <$. Drop the 2dup from before search. get-view-output +s set-view-output \ Save string as-is to view output -1 \ exit the loop then until ; : render-view ( addr u -- vaddr vu ) \ Accepts a view filename. Returns parsed contents. s" " set-view-output get-view-path +s file-exists? if slurp-file parse-view else exit \ Continue to 404, no view. then get-view-output ; : <$ ( -- ) ; \ Do nothing. : $> ( -- ) ; \ Do nothing. : $type ( addr u -- ) \ User-land word for outputing via views. get-view-output +s set-view-output ; : import ( -- ) \ User-land word for including other view files. get-view-path +s file-exists? if slurp-file parse-view else s" " then ; \ Request's Content-Type pubvar RequestContentType : set-content-type ( addr u -- ) RequestContentType 2! ; : get-content-type ( -- addr u ) RequestContentType 2@ ; : filetype: ( addr u "extension" -- ) \ takes a content-type and the extension create here over 1+ allot place does> count ; : get-filetype ( addr u -- caddr cu ) \ takes an extension, looks to find a definition find-name dup if name>int execute else drop s" text/plain" then ; s" text/plain" filetype: txt \ txt should always be defined s" text/html" filetype: html s" text/css" filetype: css s" text/javascript" filetype: js s" image/png" filetype: png s" image/gif" filetype: gif s" image/jpeg" filetype: jpg s" image/jpeg" filetype: jpeg s" image/x-icon" filetype: ico \ Internal request handling : HTTP/1.1 s" HTTP/1.1 " ; : response-status ( u -- addr u ) dup case \ get status code info 200 of s" OK" endof 404 of s" Not Found" endof endcase s\" \n" s+ rot s>d <# #s #> +s \ convert status code to string and prepend to info HTTP/1.1 +s ; \ prepend HTTP/1.1 : content-type ( addr u -- caddr cu ) s" Content-Type: " +s \ Prepend to the provided content type s\" \n\n" s+ ; \ Append 2 new lines : set-header ( u addr u -- raddr ru ) \ Accepts status code and content type string rot response-status \ Set response status 2swap content-type \ Set content-type s+ ; \ Join : read-request ( socket -- addr u ) pad 4096 read-socket ; : send-response ( addr u socket -- ) dup >r write-socket r> close-socket ; : store-query-string ( addr u -- raddr ru ) 2dup s" ?" search if 2dup 1 /string set-query-string \ Store query string (without leading "?"). swap drop - else s" " set-query-string \ Store empty query string (reset). 2drop then ; : requested-route ( addr u -- raddr ru ) bl scan 1- swap 1+ swap 2dup bl scan swap drop - \ get the space-separated route store-query-string ; \ strip and store the query, leave route : .extension ( addr u -- addr u ) 2dup reverse \ reverse the file name 2dup s" ." search \ search for the first occurance of "." if swap drop - \ remove the "." from the search results else s" txt" then 2dup reverse ; \ reverse reversed extension : serve-file-type ( addr u -- ) .extension get-filetype set-content-type ; : serve-file ( addr u -- addr u ) slurp-file ; : 404content-type txt ; : 404html s" 404"; : either-resolve ( addr u -- resolveaddr resolveu ) s" GET" search if s" html" get-filetype set-content-type \ reset the request's content-type requested-route 2dup find-route dup if >r 2drop r> \ keep xt, drop the route string execute \ execute the user's route handler else drop \ drop the null xt get-public-path +s \ see if route exists in public dir file-exists? if 2dup serve-file \ collect file contents 2swap serve-file-type \ set the file type else exit \ continue to 404 then then 200 get-content-type set-header +s rdrop exit then ; : or-404 ( addr u -- 404addr 404u ) 2drop 404 404content-type set-header 404html s+ ; : prepare-response ( addr u -- returnaddr returnu) either-resolve or-404 ; : start-server { server client } begin server 255 listen server accept-socket to client client read-request prepare-response client send-response again ; \ Userland : 1991: ( port -- ) create-server 0 start-server ; : /1991 ( " " -- ) bl word ' swap count register-route ;