2008-02-07 02:05:10 -05:00
|
|
|
! Copyright (C) 2003, 2008 Slava Pestov.
|
2007-09-20 18:09:08 -04:00
|
|
|
! See http://factorcode.org/license.txt for BSD license.
|
2008-02-09 22:34:42 -05:00
|
|
|
USING: assocs kernel namespaces io io.timeouts strings splitting
|
2008-02-25 15:53:18 -05:00
|
|
|
threads http sequences prettyprint io.server logging calendar
|
2008-02-29 01:57:38 -05:00
|
|
|
new-slots html.elements accessors math.parser combinators.lib
|
2008-03-05 22:38:15 -05:00
|
|
|
vocabs.loader debugger html continuations random combinators
|
2008-03-11 04:39:09 -04:00
|
|
|
destructors io.encodings.latin1 fry combinators.cleave ;
|
2007-09-20 18:09:08 -04:00
|
|
|
IN: http.server
|
|
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
GENERIC: call-responder ( path responder -- response )
|
|
|
|
|
|
|
|
|
|
: <content> ( content-type -- response )
|
|
|
|
|
<response>
|
|
|
|
|
200 >>code
|
|
|
|
|
swap set-content-type ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-02-29 01:57:38 -05:00
|
|
|
TUPLE: trivial-responder response ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-02-29 01:57:38 -05:00
|
|
|
C: <trivial-responder> trivial-responder
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-03-03 03:19:36 -05:00
|
|
|
M: trivial-responder call-responder nip response>> call ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
|
|
|
|
: trivial-response-body ( code message -- )
|
|
|
|
|
<html>
|
|
|
|
|
<body>
|
2008-03-11 04:39:09 -04:00
|
|
|
<h1> [ number>string write bl ] [ write ] bi* </h1>
|
2008-02-25 15:53:18 -05:00
|
|
|
</body>
|
|
|
|
|
</html> ;
|
|
|
|
|
|
2008-02-29 01:57:38 -05:00
|
|
|
: <trivial-response> ( code message -- response )
|
2008-03-11 04:39:09 -04:00
|
|
|
2dup '[ , , trivial-response-body ]
|
|
|
|
|
"text/html" <content>
|
|
|
|
|
swap >>body
|
|
|
|
|
swap >>message
|
|
|
|
|
swap >>code ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-03-03 05:40:29 -05:00
|
|
|
: <400> ( -- response )
|
|
|
|
|
400 "Bad request" <trivial-response> ;
|
|
|
|
|
|
2008-02-29 01:57:38 -05:00
|
|
|
: <404> ( -- response )
|
2008-02-25 15:53:18 -05:00
|
|
|
404 "Not Found" <trivial-response> ;
|
|
|
|
|
|
2008-02-29 01:57:38 -05:00
|
|
|
SYMBOL: 404-responder
|
|
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
[ <404> ] <trivial-responder> 404-responder set-global
|
|
|
|
|
|
|
|
|
|
: url-redirect ( to query -- url )
|
|
|
|
|
#! Different host.
|
|
|
|
|
dup assoc-empty? [
|
|
|
|
|
drop
|
|
|
|
|
] [
|
|
|
|
|
assoc>query "?" swap 3append
|
|
|
|
|
] if ;
|
|
|
|
|
|
|
|
|
|
: absolute-redirect ( to query -- url )
|
|
|
|
|
#! Same host.
|
|
|
|
|
request get clone
|
|
|
|
|
swap [ >>query ] when*
|
|
|
|
|
swap >>path
|
|
|
|
|
request-url ;
|
|
|
|
|
|
|
|
|
|
: replace-last-component ( path with -- path' )
|
|
|
|
|
>r "/" last-split1 drop "/" r> 3append ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
: relative-redirect ( to query -- url )
|
|
|
|
|
request get clone
|
|
|
|
|
swap [ >>query ] when*
|
|
|
|
|
swap [ '[ , replace-last-component ] change-path ] when*
|
|
|
|
|
request-url ;
|
|
|
|
|
|
|
|
|
|
: derive-url ( to query -- url )
|
2008-03-03 03:19:36 -05:00
|
|
|
{
|
2008-03-11 04:39:09 -04:00
|
|
|
{ [ over "http://" head? ] [ url-redirect ] }
|
|
|
|
|
{ [ over "/" head? ] [ absolute-redirect ] }
|
|
|
|
|
{ [ t ] [ relative-redirect ] }
|
2008-03-03 03:19:36 -05:00
|
|
|
} cond ;
|
|
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
: <redirect> ( to query code message -- response )
|
|
|
|
|
<trivial-response> -rot derive-url "location" set-header ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-02-29 01:57:38 -05:00
|
|
|
\ <redirect> DEBUG add-input-logging
|
|
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
: <permanent-redirect> ( to query -- response )
|
2008-02-25 15:53:18 -05:00
|
|
|
301 "Moved Permanently" <redirect> ;
|
|
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
: <temporary-redirect> ( to query -- response )
|
2008-02-25 15:53:18 -05:00
|
|
|
307 "Temporary Redirect" <redirect> ;
|
|
|
|
|
|
2008-02-29 01:57:38 -05:00
|
|
|
TUPLE: dispatcher default responders ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-03-03 03:19:36 -05:00
|
|
|
: <dispatcher> ( -- dispatcher )
|
2008-03-11 04:39:09 -04:00
|
|
|
404-responder get H{ } clone dispatcher construct-boa ;
|
2008-03-03 03:19:36 -05:00
|
|
|
|
|
|
|
|
: set-main ( dispatcher name -- dispatcher )
|
2008-03-11 04:39:09 -04:00
|
|
|
'[ , f <permanent-redirect> ] <trivial-responder>
|
|
|
|
|
>>default ;
|
2008-03-03 03:19:36 -05:00
|
|
|
|
|
|
|
|
: split-path ( path -- rest first )
|
|
|
|
|
[ CHAR: / = ] left-trim "/" split1 swap ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-02-29 01:57:38 -05:00
|
|
|
: find-responder ( path dispatcher -- path responder )
|
2008-03-03 03:19:36 -05:00
|
|
|
over split-path pick responders>> at*
|
|
|
|
|
[ >r >r 2drop r> r> ] [ 2drop default>> ] if ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
: redirect-with-/ ( -- response )
|
|
|
|
|
request get path>> "/" append f <permanent-redirect> ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
M: dispatcher call-responder ( path dispatcher -- response )
|
2008-02-29 01:57:38 -05:00
|
|
|
over [
|
2008-03-11 04:39:09 -04:00
|
|
|
2dup find-responder call-responder [
|
|
|
|
|
2nip
|
2008-03-03 03:19:36 -05:00
|
|
|
] [
|
|
|
|
|
default>> [
|
|
|
|
|
call-responder
|
|
|
|
|
] [
|
2008-03-11 04:39:09 -04:00
|
|
|
drop f
|
2008-03-03 03:19:36 -05:00
|
|
|
] if*
|
|
|
|
|
] if*
|
2008-02-29 01:57:38 -05:00
|
|
|
] [
|
|
|
|
|
2drop redirect-with-/
|
|
|
|
|
] if ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-02-29 01:57:38 -05:00
|
|
|
: add-responder ( dispatcher responder path -- dispatcher )
|
|
|
|
|
pick responders>> set-at ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-03-03 03:19:36 -05:00
|
|
|
: add-main-responder ( dispatcher responder path -- dispatcher )
|
|
|
|
|
[ add-responder ] keep set-main ;
|
|
|
|
|
|
|
|
|
|
: <webapp> ( class -- dispatcher )
|
|
|
|
|
<dispatcher> swap construct-delegate ; inline
|
2008-03-03 05:40:29 -05:00
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
SYMBOL: main-responder
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
main-responder global
|
|
|
|
|
[ drop 404-responder get-global ] cache
|
|
|
|
|
drop
|
2008-02-25 15:53:18 -05:00
|
|
|
|
2008-03-03 03:19:36 -05:00
|
|
|
SYMBOL: development-mode
|
|
|
|
|
|
2008-02-29 01:57:38 -05:00
|
|
|
: <500> ( error -- response )
|
|
|
|
|
500 "Internal server error" <trivial-response>
|
2008-03-11 04:39:09 -04:00
|
|
|
swap '[
|
|
|
|
|
, "Internal server error" [
|
2008-03-03 03:19:36 -05:00
|
|
|
development-mode get [
|
|
|
|
|
[ print-error nl :c ] with-html-stream
|
|
|
|
|
] [
|
|
|
|
|
500 "Internal server error"
|
|
|
|
|
trivial-response-body
|
|
|
|
|
] if
|
2008-02-29 01:57:38 -05:00
|
|
|
] simple-page
|
2008-03-11 04:39:09 -04:00
|
|
|
] >>body ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
: do-response ( response -- )
|
2008-02-29 01:57:38 -05:00
|
|
|
dup write-response
|
2008-03-11 04:39:09 -04:00
|
|
|
request get method>> "HEAD" =
|
2008-02-29 01:57:38 -05:00
|
|
|
[ drop ] [ write-response-body ] if ;
|
2008-02-25 15:53:18 -05:00
|
|
|
|
|
|
|
|
LOG: httpd-hit NOTICE
|
|
|
|
|
|
|
|
|
|
: log-request ( request -- )
|
|
|
|
|
{ method>> host>> path>> } map-exec-with httpd-hit ;
|
2008-02-07 18:07:43 -05:00
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
SYMBOL: exit-continuation
|
|
|
|
|
|
|
|
|
|
: exit-with exit-continuation get continue-with ;
|
|
|
|
|
|
|
|
|
|
: do-request ( request -- response )
|
|
|
|
|
'[
|
|
|
|
|
exit-continuation set ,
|
|
|
|
|
[
|
|
|
|
|
[ log-request ]
|
|
|
|
|
[ request set ]
|
|
|
|
|
[ path>> main-responder get call-responder ] tri
|
|
|
|
|
[ <404> ] unless*
|
|
|
|
|
] [
|
|
|
|
|
[ \ do-request log-error ]
|
|
|
|
|
[ <500> ]
|
|
|
|
|
bi
|
|
|
|
|
] recover
|
|
|
|
|
] callcc1
|
|
|
|
|
exit-continuation off ;
|
|
|
|
|
|
|
|
|
|
: default-timeout 1 minutes stdio get set-timeout ;
|
|
|
|
|
|
2008-03-05 22:38:15 -05:00
|
|
|
: ?refresh-all ( -- )
|
2008-02-29 01:57:38 -05:00
|
|
|
development-mode get-global
|
2008-03-05 22:38:15 -05:00
|
|
|
[ global [ refresh-all ] bind ] when ;
|
|
|
|
|
|
|
|
|
|
: handle-client ( -- )
|
|
|
|
|
[
|
|
|
|
|
default-timeout
|
|
|
|
|
?refresh-all
|
|
|
|
|
read-request
|
2008-03-11 04:39:09 -04:00
|
|
|
do-request
|
|
|
|
|
do-response
|
2008-03-05 22:38:15 -05:00
|
|
|
] with-destructors ;
|
2008-02-29 01:57:38 -05:00
|
|
|
|
2007-09-20 18:09:08 -04:00
|
|
|
: httpd ( port -- )
|
2008-03-03 03:19:36 -05:00
|
|
|
internet-server "http.server"
|
2008-03-06 16:58:05 -05:00
|
|
|
latin1 [ handle-client ] with-server ;
|
2007-09-20 18:09:08 -04:00
|
|
|
|
|
|
|
|
: httpd-main ( -- ) 8888 httpd ;
|
|
|
|
|
|
|
|
|
|
MAIN: httpd-main
|
2008-02-29 01:57:38 -05:00
|
|
|
|
2008-03-11 04:39:09 -04:00
|
|
|
! Utility
|
2008-02-29 01:57:38 -05:00
|
|
|
: generate-key ( assoc -- str )
|
2008-03-11 04:39:09 -04:00
|
|
|
>r random-256 >hex r>
|
|
|
|
|
2dup key? [ nip generate-key ] [ drop ] if ;
|
|
|
|
|
|
|
|
|
|
: set-at-unique ( value assoc -- key )
|
|
|
|
|
dup generate-key [ swap set-at ] keep ;
|
