1 ! Copyright (C) 2008 Slava Pestov.
2 ! See http://factorcode.org/license.txt for BSD license.
3 USING: kernel namespaces sequences assocs accessors splitting
4 unicode.case urls http http.server http.server.responses ;
5 IN: http.server.dispatchers
7 TUPLE: dispatcher default responders ;
9 : new-dispatcher ( class -- dispatcher )
11 <404> <trivial-responder> >>default
12 H{ } clone >>responders ; inline
14 : <dispatcher> ( -- dispatcher )
15 dispatcher new-dispatcher ;
17 : find-responder ( path dispatcher -- path responder )
19 "" over responders>> at*
20 [ nip ] [ drop default>> ] if
22 over first over responders>> at*
23 [ [ drop rest-slice ] dip ] [ drop default>> ] if
26 M: dispatcher call-responder* ( path dispatcher -- response )
27 find-responder call-responder ;
29 TUPLE: vhost-dispatcher default responders ;
31 : <vhost-dispatcher> ( -- dispatcher )
32 vhost-dispatcher new-dispatcher ;
34 : canonical-host ( host -- host' )
35 >lower "www." ?head drop "." ?tail drop ;
37 : find-vhost ( dispatcher -- responder )
38 url get host>> canonical-host over responders>> at*
39 [ nip ] [ drop default>> ] if ;
41 M: vhost-dispatcher call-responder* ( path dispatcher -- response )
42 find-vhost call-responder ;
44 : add-responder ( dispatcher responder path -- dispatcher )
45 pick responders>> set-at ;
47 : add-main-responder ( dispatcher responder path -- dispatcher )
48 [ add-responder drop ]
49 [ drop "" add-responder drop ]