! See http://factorcode.org/license.txt for BSD license.
USING: assocs http kernel math math.parser namespaces sequences
io io.sockets io.streams.string io.files io.timeouts strings
- splitting calendar continuations assocs.lib io.encodings.binary ;
-splitting continuations calendar vectors hashtables
-accessors ;
++splitting calendar continuations accessors vectors io.encodings.binary ;
IN: http.client
- : parse-host ( url -- host port )
- #! Extract the host name and port number from an HTTP URL.
- ":" split1 [ string>number ] [ 80 ] if* ;
+ : parse-url ( url -- resource host port )
+ "http://" ?head [ "Only http:// supported" throw ] unless
+ "/" split1 [ "/" swap append ] [ "/" ] if*
+ swap parse-host ;
- SYMBOL: domain
+ <PRIVATE
- : parse-url ( url -- host resource )
- dup "https://" head? [
- "ssl not yet supported: " swap append throw
- ] when "http://" ?head drop
- "/" split1 [ "/" swap append ] [ "/" ] if*
- >r dup empty? [ drop domain get ] [ dup domain set ] if r> ;
+ : store-path ( request path -- request )
+ "?" split1 >r >>path r> dup [ query>assoc ] when >>query ;
- : parse-response ( line -- code )
- "HTTP/" ?head [ " " split1 nip ] when
- " " split1 drop string>number [
- "Premature end of stream" throw
- ] unless* ;
+ ! This is all pretty complex because it needs to handle
+ ! HTTP redirects, which might be absolute or relative
+ : request-with-url ( url request -- request )
+ clone dup "request" set
+ swap parse-url >r >r store-path r> >>host r> >>port ;
- : read-response ( -- code header )
- #! After sending a GET or POST we read a response line and
- #! header.
- flush readln parse-response read-header ;
+ DEFER: (http-request)
- : crlf "\r\n" write ;
+ : absolute-redirect ( url -- request )
+ "request" get request-with-url ;
- : http-request ( host resource method -- )
- write bl write " HTTP/1.0" write crlf
- "Host: " write write crlf ;
+ : relative-redirect ( path -- request )
+ "request" get swap store-path ;
- : get-request ( host resource -- )
- "GET" http-request crlf ;
+ : do-redirect ( response -- response stream )
+ dup response-code 300 399 between? [
+ header>> "location" swap at
+ dup "http://" head? [
+ absolute-redirect
+ ] [
+ relative-redirect
+ ] if "GET" >>method (http-request)
+ ] [
+ stdio get
+ ] if ;
- DEFER: http-get-stream
+ : (http-request) ( request -- response stream )
+ dup host>> over port>> <inet> <client> stdio set
+ dup "r" set-global write-request flush read-response
+ do-redirect ;
- : do-redirect ( code headers stream -- code headers stream )
- #! Should this support Location: headers that are
- #! relative URLs?
- pick 100 /i 3 = [
- dispose "location" swap peek-at nip http-get-stream
- ] when ;
+ PRIVATE>
- : default-timeout 1 minutes over set-timeout ;
+ : http-request ( url request -- response stream )
+ [
+ request-with-url
+ [
+ (http-request)
+ 1 minutes over set-timeout
+ ] [ ] [ stdio get dispose ] cleanup
+ ] with-scope ;
- : http-get-stream ( url -- code headers stream )
- #! Opens a stream for reading from an HTTP URL.
- parse-url over parse-host <inet> <client> [
- [ [ get-request read-response ] with-stream* ] keep
- default-timeout
- ] [ ] [ dispose ] cleanup do-redirect ;
+ : <get-request> ( -- request )
+ <request> "GET" >>method ;
+
+ : http-get-stream ( url -- response stream )
+ <get-request> http-request ;
: success? ( code -- ? ) 200 = ;
: download-to ( url file -- )
#! Downloads the contents of a URL to a file.
- >r http-get-stream check-response
- r> binary <file-writer> stream-copy ;
+ swap http-get-stream check-response
- [ swap <file-writer> stream-copy ] with-disposal ;
++ [ swap binary <file-writer> stream-copy ] with-disposal ;
: download ( url -- )
dup download-name download-to ;
! 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 http http.server.responders sequences prettyprint
- io.server logging calendar io.encodings.latin1 ;
-
+ threads http sequences prettyprint io.server logging calendar
+ new-slots html.elements accessors math.parser combinators.lib
-vocabs.loader debugger html continuations random combinators ;
++vocabs.loader debugger html continuations random combinators
++io.encodings.latin1 ;
IN: http.server
- : (url>path) ( uri -- path )
- url-decode "http://" ?head [
- "/" split1 dup "" ? nip
- ] when ;
+ GENERIC: call-responder ( request path responder -- response )
- : url>path ( uri -- path )
- "?" split1 dup [
- >r (url>path) "?" r> 3append
- ] [
- drop (url>path)
- ] if ;
+ TUPLE: trivial-responder response ;
+
+ C: <trivial-responder> trivial-responder
+
+ M: trivial-responder call-responder nip response>> call ;
+
+ : trivial-response-body ( code message -- )
+ <html>
+ <body>
+ <h1> swap number>string write bl write </h1>
+ </body>
+ </html> ;
+
+ : <trivial-response> ( code message -- response )
+ <response>
+ 2over [ trivial-response-body ] 2curry >>body
+ "text/html" set-content-type
+ swap >>message
+ swap >>code ;
+
+ : <400> ( -- response )
+ 400 "Bad request" <trivial-response> ;
+
+ : <404> ( -- response )
+ 404 "Not Found" <trivial-response> ;
+
+ SYMBOL: 404-responder
+
+ [ drop <404> ] <trivial-responder> 404-responder set-global
+
+ : modify-for-redirect ( request to -- url )
+ {
+ { [ dup "http://" head? ] [ nip ] }
+ { [ dup "/" head? ] [ >>path request-url ] }
+ { [ t ] [ >r dup path>> "/" last-split1 drop "/" r> 3append >>path request-url ] }
+ } cond ;
+
+ : <redirect> ( request to code message -- response )
+ <trivial-response>
+ -rot modify-for-redirect
+ "location" set-header ;
+
+ \ <redirect> DEBUG add-input-logging
+
+ : <permanent-redirect> ( request to -- response )
+ 301 "Moved Permanently" <redirect> ;
+
+ : <temporary-redirect> ( request to -- response )
+ 307 "Temporary Redirect" <redirect> ;
- : secure-path ( path -- path )
- ".." over subseq? [ drop f ] when ;
+ : <content> ( content-type -- response )
+ <response>
+ 200 >>code
+ swap set-content-type ;
- : request-method ( cmd -- method )
- H{
- { "GET" "get" }
- { "POST" "post" }
- { "HEAD" "head" }
- } at "bad" or ;
+ TUPLE: dispatcher default responders ;
- : (handle-request) ( arg cmd -- method path host )
- request-method dup "method" set swap
- prepare-url prepare-header host ;
+ : <dispatcher> ( -- dispatcher )
+ 404-responder H{ } clone dispatcher construct-boa ;
- : handle-request ( arg cmd -- )
- [ (handle-request) serve-responder ] with-scope ;
+ : set-main ( dispatcher name -- dispatcher )
+ [ <permanent-redirect> ] curry
+ <trivial-responder> >>default ;
- : parse-request ( request -- )
- " " split1 dup [
- " HTTP" split1 drop url>path secure-path dup [
- swap handle-request
+ : split-path ( path -- rest first )
+ [ CHAR: / = ] left-trim "/" split1 swap ;
+
+ : find-responder ( path dispatcher -- path responder )
+ over split-path pick responders>> at*
+ [ >r >r 2drop r> r> ] [ 2drop default>> ] if ;
+
+ : redirect-with-/ ( request -- response )
+ dup path>> "/" append <permanent-redirect> ;
+
+ M: dispatcher call-responder
+ over [
+ 3dup find-responder call-responder [
+ >r 3drop r>
] [
- 2drop bad-request
- ] if
+ default>> [
+ call-responder
+ ] [
+ 3drop f
+ ] if*
+ ] if*
] [
- 2drop bad-request
+ 2drop redirect-with-/
] if ;
- \ parse-request NOTICE add-input-logging
+ : add-responder ( dispatcher responder path -- dispatcher )
+ pick responders>> set-at ;
+
+ : add-main-responder ( dispatcher responder path -- dispatcher )
+ [ add-responder ] keep set-main ;
+
+ : <webapp> ( class -- dispatcher )
+ <dispatcher> swap construct-delegate ; inline
+
+ SYMBOL: virtual-hosts
+ SYMBOL: default-host
+
+ virtual-hosts global [ drop H{ } clone ] cache drop
+ default-host global [ drop 404-responder get-global ] cache drop
+
+ : find-virtual-host ( host -- responder )
+ virtual-hosts get at [ default-host get ] unless* ;
+
+ SYMBOL: development-mode
+
+ : <500> ( error -- response )
+ 500 "Internal server error" <trivial-response>
+ swap [
+ "Internal server error" [
+ development-mode get [
+ [ print-error nl :c ] with-html-stream
+ ] [
+ 500 "Internal server error"
+ trivial-response-body
+ ] if
+ ] simple-page
+ ] curry >>body ;
+
+ : do-response ( request response -- )
+ dup write-response
+ swap method>> "HEAD" =
+ [ drop ] [ write-response-body ] if ;
+
+ : do-request ( request -- request )
+ [
+ dup dup path>> over host>>
+ find-virtual-host call-responder
+ [ <404> ] unless*
+ ] [ dup \ do-request log-error <500> ] recover ;
+
+ : default-timeout 1 minutes stdio get set-timeout ;
+
+ LOG: httpd-hit NOTICE
+
+ : log-request ( request -- )
+ { method>> host>> path>> } map-exec-with httpd-hit ;
+
+ : handle-client ( -- )
+ default-timeout
+ development-mode get-global
+ [ global [ refresh-all ] bind ] when
+ read-request
+ dup log-request
+ do-request do-response ;
: httpd ( port -- )
- internet-server "http.server" latin1 [
- 1 minutes stdio get set-timeout
- readln [ parse-request ] when*
- ] with-server ;
+ internet-server "http.server"
- [ handle-client ] with-server ;
++ latin1 [ handle-client ] with-server ;
: httpd-main ( -- ) 8888 httpd ;
projects / factor.git / commitdiff