! Copyright (C) 2003, 2008 Slava Pestov. ! See http://factorcode.org/license.txt for BSD license. USING: assocs kernel namespaces io io.timeouts strings splitting threads sequences prettyprint io.server logging calendar http html.streams html.elements accessors math.parser combinators.lib tools.vocabs debugger continuations random combinators destructors io.encodings.8-bit fry classes words math rss json.writer ; IN: http.server ! path is a sequence of path component strings GENERIC: call-responder* ( path responder -- response ) : request-params ( request -- assoc ) dup method>> { { "GET" [ query>> ] } { "HEAD" [ query>> ] } { "POST" [ post-data>> ] } } case ; : ( body content-type -- response ) 200 >>code "Document follows" >>message swap >>content-type swap >>body ; : ( body -- response ) "text/plain" ; : ( body -- response ) "text/html" ; : ( body -- response ) "text/xml" ; : ( feed -- response ) '[ , feed>xml ] "text/xml" ; : ( obj -- response ) '[ , >json ] "application/json" ; TUPLE: trivial-responder response ; C: trivial-responder M: trivial-responder call-responder* nip response>> call ; : trivial-response-body ( code message -- )

[ number>string write bl ] [ write ] bi*

; : ( code message -- response ) 2dup '[ , , trivial-response-body ] swap >>message swap >>code ; : <400> ( -- response ) 400 "Bad request" ; : <404> ( -- response ) 404 "Not Found" ; SYMBOL: 404-responder [ <404> ] 404-responder set-global SYMBOL: base-paths : invert-slice ( slice -- slice' ) dup slice? [ [ seq>> ] [ from>> ] bi head-slice ] [ drop { } ] if ; : add-base-path ( path dispatcher -- ) [ invert-slice ] [ class word-name ] bi* base-paths get set-at ; : call-responder ( path responder -- response ) [ add-base-path ] [ call-responder* ] 2bi ; SYMBOL: link-hook : add-link-hook ( quot -- ) link-hook [ compose ] change ; inline : modify-query ( query -- query ) link-hook get call ; : base-path ( string -- path ) dup base-paths get at [ ] [ "No such responder: " swap append throw ] ?if ; : resolve-base-path ( string -- string' ) "$" ?head [ [ "/" split1 [ base-path [ "/" % % ] each "/" % ] dip % ] "" make ] when ; : link>string ( url query -- url' ) [ resolve-base-path ] [ modify-query ] bi* (link>string) ; : write-link ( url query -- ) link>string write ; SYMBOL: form-hook : add-form-hook ( quot -- ) form-hook [ compose ] change ; : hidden-form-field ( -- ) form-hook get call ; : absolute-redirect ( to query -- url ) #! Same host. request get clone swap [ >>query ] when* swap url-encode >>path [ modify-query ] change-query request-url ; : replace-last-component ( path with -- path' ) [ "/" last-split1 drop "/" ] dip 3append ; : relative-redirect ( to query -- url ) request get clone swap [ >>query ] when* swap [ '[ , replace-last-component ] change-path ] when* [ modify-query ] change-query request-url ; : derive-url ( to query -- url ) { { [ over "http://" head? ] [ link>string ] } { [ over "/" head? ] [ absolute-redirect ] } { [ over "$" head? ] [ [ resolve-base-path ] dip derive-url ] } [ relative-redirect ] } cond ; : ( to query code message -- response ) -rot derive-url "location" set-header ; \ DEBUG add-input-logging : ( to query -- response ) 301 "Moved Permanently" ; : ( to query -- response ) 307 "Temporary Redirect" ; : ( to query -- response ) request get method>> "POST" = [ ] [ ] if ; TUPLE: dispatcher default responders ; : new-dispatcher ( class -- dispatcher ) new 404-responder get >>default H{ } clone >>responders ; inline : ( -- dispatcher ) dispatcher new-dispatcher ; : find-responder ( path dispatcher -- path responder ) over empty? [ "" over responders>> at* [ nip ] [ drop default>> ] if ] [ over first over responders>> at* [ [ drop rest-slice ] dip ] [ drop default>> ] if ] if ; M: dispatcher call-responder* ( path dispatcher -- response ) find-responder call-responder ; TUPLE: vhost-dispatcher default responders ; : ( -- dispatcher ) 404-responder get H{ } clone vhost-dispatcher boa ; : find-vhost ( dispatcher -- responder ) request get host>> over responders>> at* [ nip ] [ drop default>> ] if ; M: vhost-dispatcher call-responder* ( path dispatcher -- response ) find-vhost call-responder ; : add-responder ( dispatcher responder path -- dispatcher ) pick responders>> set-at ; : add-main-responder ( dispatcher responder path -- dispatcher ) [ add-responder drop ] [ drop "" add-responder drop ] [ 2drop ] 3tri ; TUPLE: filter-responder responder ; M: filter-responder call-responder* responder>> call-responder ; SYMBOL: main-responder main-responder global [ drop 404-responder get-global ] cache drop SYMBOL: development-mode : http-error. ( error -- ) "Internal server error" [ development-mode get [ [ print-error nl :c ] with-html-stream ] [ 500 "Internal server error" trivial-response-body ] if ] simple-page ; : <500> ( error -- response ) 500 "Internal server error" swap '[ , http-error. ] >>body ; : do-response ( response -- ) dup write-response request get method>> "HEAD" = [ drop ] [ '[ , write-response-body ] [ http-error. ] recover ] if ; LOG: httpd-hit NOTICE : log-request ( request -- ) { method>> host>> path>> } map-exec-with httpd-hit ; SYMBOL: exit-continuation : exit-with exit-continuation get continue-with ; : with-exit-continuation ( quot -- ) '[ exit-continuation set @ ] callcc1 exit-continuation off ; : split-path ( string -- path ) "/" split harvest ; : init-request ( -- ) H{ } clone base-paths set [ ] link-hook set [ ] form-hook set ; : do-request ( request -- response ) [ init-request [ request set ] [ log-request ] [ path>> split-path main-responder get call-responder ] tri [ <404> ] unless* ] [ [ \ do-request log-error ] [ <500> ] bi ] recover ; : ?refresh-all ( -- ) development-mode get-global [ global [ refresh-all ] bind ] when ; : handle-client ( -- ) [ 1 minutes timeouts ?refresh-all read-request do-request do-response ] with-destructors ; : httpd ( port -- ) dup integer? [ internet-server ] when "http.server" latin1 [ handle-client ] with-server ; : httpd-main ( -- ) 8888 httpd ; MAIN: httpd-main