library/httpd/responder.factor

   1 !:folding=indent:collapseFolds=0:
   2
   3 ! $Id$
   4 !
   5 ! Copyright (C) 2004 Slava Pestov.
   6 !
   7 ! Redistribution and use in source and binary forms, with or without
   8 ! modification, are permitted provided that the following conditions are met:
   9 !
  10 ! 1. Redistributions of source code must retain the above copyright notice,
  11 !    this list of conditions and the following disclaimer.
  12 !
  13 ! 2. Redistributions in binary form must reproduce the above copyright notice,
  14 !    this list of conditions and the following disclaimer in the documentation
  15 !    and/or other materials provided with the distribution.
  16 !
  17 ! THIS SOFTWARE IS PROVIDED ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES,
  18 ! INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND
  19 ! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE
  20 ! DEVELOPERS AND CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,
  21 ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
  22 ! PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS;
  23 ! OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY,
  24 ! WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR
  25 ! OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF
  26 ! ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
  27
  28 IN: httpd-responder
  29
  30 USE: combinators
  31 USE: lists
  32 USE: logging
  33 USE: namespaces
  34 USE: stdio
  35 USE: stack
  36 USE: streams
  37 USE: strings
  38
  39 USE: httpd
  40
  41 : <responder> ( -- responder )
  42     <namespace> [
  43         [
  44             drop "GET method not implemented" httpd-error
  45         ] "get" set
  46
  47         [
  48             drop "POST method not implemented" httpd-error
  49         ] "post" set
  50     ] extend ;
  51
  52 : serving-html ( -- )
  53     "200 Document follows" "text/html" response print ;
  54
  55 : serving-text ( -- )
  56     "200 Document follows" "text/plain" response print ;
  57
  58 : get-responder ( name -- responder )
  59     "httpd-responders" get [ get ] bind ;
  60
  61 : responder-argument ( argument -- argument )
  62     dup f-or-"" [ drop "default-argument" get ] when ;
  63
  64 : call-responder ( method argument responder -- )
  65     [ responder-argument swap get call ] bind ;
  66
  67 : no-such-responder ( name -- )
  68     "404 no such responder: " swap cat2 httpd-error ;
  69
  70 : bad-responder-query ( argument -- )
  71     "404 missing parameter" httpd-error ;
  72
  73 : trim-/ ( url -- url )
  74     #! Trim a leading /, if there is one.
  75     dup "/" str-head? dup [ nip ] [ drop ] ifte ;
  76
  77 : log-responder ( argument -- )
  78     "Calling responder " swap cat2 log ;
  79
  80 : serve-responder ( argument method -- )
  81     swap
  82     trim-/
  83     dup "/" split1 dup [
  84         nip unswons dup get-responder dup [
  85             swap log-responder call-responder
  86         ] [
  87             drop nip nip no-such-responder
  88         ] ifte
  89     ] [
  90         3drop bad-responder-query
  91     ] ifte ;