basis/http/server/dispatchers/dispatchers.factor

   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 urls http http.server http.server.responses ;
   5 IN: http.server.dispatchers
   6
   7 TUPLE: dispatcher default responders ;
   8
   9 : new-dispatcher ( class -- dispatcher )
  10     new
  11         <404> <trivial-responder> >>default
  12         H{ } clone >>responders ; inline
  13
  14 : <dispatcher> ( -- dispatcher )
  15     dispatcher new-dispatcher ;
  16
  17 : find-responder ( path dispatcher -- path responder )
  18     over empty? [
  19         "" over responders>> at*
  20         [ nip ] [ drop default>> ] if
  21     ] [
  22         over first over responders>> at*
  23         [ [ drop rest-slice ] dip ] [ drop default>> ] if
  24     ] if ;
  25
  26 M: dispatcher call-responder*
  27     find-responder call-responder ;
  28
  29 TUPLE: vhost-dispatcher default responders ;
  30
  31 : <vhost-dispatcher> ( -- dispatcher )
  32     vhost-dispatcher new-dispatcher ;
  33
  34 : canonical-host ( host -- host' )
  35     >lower "www." ?head drop "." ?tail drop ;
  36
  37 : find-vhost ( dispatcher -- responder )
  38     url get host>> canonical-host over responders>> at*
  39     [ nip ] [ drop default>> ] if ;
  40
  41 M: vhost-dispatcher call-responder*
  42     find-vhost call-responder ;
  43
  44 : add-responder ( dispatcher responder path -- dispatcher )
  45     pick responders>> set-at ;
  46
  47 : add-main-responder ( dispatcher responder path -- dispatcher )
  48     [ add-responder drop ]
  49     [ drop "" add-responder drop ]
  50     [ 2drop ] 3tri ;