libs/httpd/httpd.factor

   1 ! Copyright (C) 2003, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 IN: httpd
   4 USING: errors hashtables kernel namespaces io strings
   5 threads http sequences prettyprint ;
   6
   7 : (url>path) ( uri -- path )
   8     url-decode "http://" ?head [
   9         "/" split1 dup "" ? nip
  10     ] when ;
  11
  12 : url>path ( uri -- path )
  13     "?" split1 dup [
  14       >r (url>path) "?" r> 3append
  15     ] [
  16       drop (url>path)
  17     ] if ;
  18
  19 : secure-path ( path -- path )
  20     ".." over subseq? [ drop f ] when ;
  21
  22 : request-method ( cmd -- method )
  23     H{
  24         { "GET" "get" }
  25         { "POST" "post" }
  26         { "HEAD" "head" }
  27     } hash [ "bad" ] unless* ;
  28
  29 : host ( -- string )
  30     #! The host the current responder was called from.
  31     "Host" "header" get hash ":" split1 drop ;
  32
  33 : (handle-request) ( arg cmd -- method path host )
  34     request-method dup "method" set swap
  35     prepare-url prepare-header host ;
  36
  37 : handle-request ( arg cmd -- )
  38     [ (handle-request) serve-responder ] with-scope ;
  39
  40 : parse-request ( request -- )
  41     dup log-message
  42     " " split1 dup [
  43         " HTTP" split1 drop url>path secure-path dup [
  44             swap handle-request
  45         ] [
  46             2drop bad-request
  47         ] if
  48     ] [
  49         2drop bad-request
  50     ] if ;
  51
  52 : httpd ( port -- )
  53     "Starting HTTP server on port " write dup . flush
  54     \ httpd [
  55         60000 stdio get set-timeout
  56         readln [ parse-request ] when*
  57     ] with-server ;
  58
  59 : stop-httpd ( -- )
  60     #! Stop the server.
  61     \ httpd get stream-close ;