\ Copyright 2021 Bradley D. Nelson \ \ Licensed under the Apache License, Version 2.0 (the "License"); \ you may not use this file except in compliance with the License. \ You may obtain a copy of the License at \ \ http://www.apache.org/licenses/LICENSE-2.0 \ \ Unless required by applicable law or agreed to in writing, software \ distributed under the License is distributed on an "AS IS" BASIS, \ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. \ See the License for the specific language governing permissions and \ limitations under the License. ( Lazy loaded HTTP Daemon ) : httpd r| vocabulary httpd httpd definitions also sockets also internals 1 constant max-connections 2048 constant chunk-size create chunk chunk-size allot 0 value chunk-filled 256 constant body-chunk-size create body-chunk body-chunk-size allot 0 value body-1st-read 0 value body-read -1 value sockfd -1 value clientfd sockaddr httpd-port sockaddr client variable client-len : client-type ( a n -- ) clientfd write-file throw ; : client-read ( -- n ) 0 >r rp@ 1 clientfd read-file throw 1 <> throw ; : client-emit ( ch -- ) >r rp@ 1 client-type rdrop ; : client-cr 13 client-emit nl client-emit ; : server ( port -- ) httpd-port ->port! ." Listening on port " httpd-port ->port@ . cr AF_INET SOCK_STREAM 0 socket to sockfd ( sockfd SOL_SOCKET SO_REUSEADDR 1 >r rp@ 4 setsockopt rdrop throw ) sockfd non-block throw sockfd httpd-port sizeof(sockaddr_in) bind throw sockfd max-connections listen throw ; : upper ( ch -- ch ) dup [char] a >= over [char] z <= and if 95 and then ; : strcase= ( a n a n -- f ) >r swap r@ <> if rdrop 2drop 0 exit then r> for aft 2dup c@ upper swap c@ upper <> if 2drop 0 exit then 1+ swap 1+ swap then next 2drop -1 ; variable goal variable goal# : end< ( n -- f ) chunk-filled < ; : in@<> ( n ch -- f ) >r chunk + c@ r> <> ; : skipto ( n ch -- n ) >r begin dup r@ in@<> over end< and while 1+ repeat rdrop ; : skipover ( n ch -- n ) skipto 1+ ; : eat ( n ch -- n a n ) >r dup r> skipover swap 2dup - 1- >r chunk + r> ; : crnl= ( n -- f ) dup chunk + c@ 13 = swap 1+ chunk + c@ nl = and ; : header ( a n -- a n ) goal# ! goal ! 0 nl skipover begin dup end< while dup crnl= if drop chunk 0 exit then [char] : eat goal @ goal# @ strcase= if 1+ 13 eat rot drop exit then nl skipover repeat drop chunk 0 ; : content-length ( -- n ) s" Content-Length" header s>number? 0= if 0 then ; : body ( -- a n ) ( reads a part of body ) body-1st-read if body-read content-length >= if 0 0 exit then body-chunk body-chunk-size clientfd read-file throw dup +to body-read body-chunk swap exit then -1 to body-1st-read 0 to body-read 0 nl skipover begin dup end< while dup crnl= if 2 + chunk-filled over - swap chunk + swap dup +to body-read exit then nl skipover repeat drop chunk 0 ; : completed? ( -- f ) 0 begin dup end< while dup crnl= if drop -1 exit then nl skipover repeat drop 0 ; : read-headers 0 to body-1st-read 0 to chunk-filled begin completed? 0= while chunk chunk-filled + chunk-size chunk-filled - clientfd read-file throw +to chunk-filled repeat ; : handleClient clientfd close-file drop -1 to clientfd sockfd client client-len sockaccept dup 0< if drop 0 exit then to clientfd chunk chunk-size erase read-headers -1 ; : hasHeader ( a n -- f ) 2drop header 0 0 strcase= 0= ; : method ( -- a n ) 0 bl eat rot drop ; : path ( -- a n ) 0 bl skipover bl eat rot drop ; : send ( a n -- ) client-type ; : response ( mime$ result$ status -- ) s" HTTP/1.0 " client-type <# #s #> client-type bl client-emit client-type client-cr s" Content-type: " client-type client-type client-cr client-cr ; : ok-response ( mime$ -- ) s" OK" 200 response ; : bad-response ( -- ) s" text/plain" s" Bad Request" 400 response ; : notfound-response ( -- ) s" text/plain" s" Not Found" 404 response ; only forth definitions httpd | evaluate ;
Legal: site web personnel sans commerce / personal site without seling