extra/fastcgi/fastcgi.factor

   1 ! Copyright (C) 2010 Brennan Cheung.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3
   4 ! This version of the FastCGI library only supports single connections.
   5 ! As opposed to multiplexing multiple requests across a single
   6 ! connection.
   7 !
   8 ! It also expects the following FastCGI parameters to be present:
   9 !     * REQUEST_METHOD
  10 !     * REQUEST_URI
  11 !
  12 ! The following are recommended:
  13 !     * HTTP_USER_AGENT
  14 !     * REMOTE_ADDR
  15
  16 USING: accessors alien.enums alien.syntax assocs combinators
  17 combinators.smart formatting http http.server
  18 http.server.responses io io.binary io.directories
  19 io.encodings.binary io.files io.servers io.sockets
  20 io.streams.byte-array kernel locals math namespaces pack
  21 prettyprint sequences sequences.deep strings threads
  22 urls.encoding ;
  23
  24 IN: fastcgi
  25
  26 SYMBOL: fcgi-server
  27 SYMBOL: fcgi-role
  28 SYMBOL: fcgi-flags
  29 SYMBOL: fcgi-params
  30 SYMBOL: fcgi-request
  31 SYMBOL: stdin-data
  32
  33 CONSTANT: fcgi-version 1
  34 CONSTANT: socket-path "/chroot/web/var/run/factor.sock"
  35
  36 TUPLE: fcgi-header version type request-id content-length
  37     padding-length reserved ;
  38
  39
  40 ENUM: fcgi-header-types
  41     { FCGI_BEGIN_REQUEST 1 }
  42     FCGI_ABORT_REQUEST
  43     FCGI_END_REQUEST
  44     FCGI_PARAMS
  45     FCGI_STDIN
  46     FCGI_STDOUT
  47     FCGI_STDERR
  48     FCGI_DATA
  49     FCGI_GET_VALUES
  50     FCGI_GET_VALUES_RESULT
  51     FCGI_UNKNOWN_TYPE
  52     { FCGI_MAXTYPE 11 } ;
  53
  54 ENUM: fcgi-roles
  55     { FCGI_RESPONDER 1 }
  56     FCGI_AUTHORIZER
  57     FCGI_FILTER ;
  58
  59 ENUM: fcgi-protocol-status
  60     { FCGI_REQUEST_COMPLETE 0 }
  61     FCGI_CANT_MAX_CONN
  62     FCGI_OVERLOADED
  63     FCGI_UNKNOWN_ROLE ;
  64
  65 :: debug-print ( print-quot -- )
  66     [ print-quot call flush ] with-global ; inline
  67
  68 ! read either a 1 byte or 4 byte big endian integer
  69 : read-var-int ( -- n/f )
  70     read1 [
  71         dup 7 bit?
  72         [ 127 bitand 3 read swap suffix be> ] when
  73     ] [ f ] if* ;
  74
  75 :: store-key-value-param ( key value -- )
  76     request tget value key set-header drop ;
  77
  78 : read-params ( -- )
  79     [
  80         read-var-int read-var-int 2dup and
  81         [
  82             [ read >string ] bi@
  83             store-key-value-param
  84             t
  85         ] [ 2drop f ] if
  86     ] loop ;
  87
  88 : delete-if-exists ( file -- )
  89     dup file-exists? [ delete-file ] [ drop ] if ;
  90
  91 : make-local-socket ( socket-path -- socket )
  92     [ delete-if-exists ] keep
  93     <local> ;
  94
  95 : get-header ( -- header )
  96     "CCSSCC" read-packed-be
  97     [ fcgi-header boa ] input<sequence
  98     dup type>> fcgi-header-types number>enum >>type ;
  99
 100 : get-content-data ( header -- content )
 101     dup
 102     [ content-length>> ]
 103     [ padding-length>> ] bi or 0 > ! because 0 read blocks
 104     [
 105         [ content-length>> read ]
 106         [ padding-length>> read drop ] bi
 107     ] [ drop f ] if ;
 108
 109 : begin-request-body ( seq -- )
 110     binary [ "SCCCCCC" read-packed-be ] with-byte-reader
 111     first2 fcgi-flags tset fcgi-roles
 112     number>enum fcgi-role tset ;
 113
 114 : process-begin-request ( header -- )
 115     get-content-data begin-request-body ;
 116
 117 : process-params ( header -- )
 118     get-content-data binary [ read-params ] with-byte-reader ;
 119
 120 :: make-response-packet ( content -- seq )
 121     [
 122         fcgi-version             ! version
 123         FCGI_STDOUT enum>number  ! type
 124         1                        ! request id
 125         content length           ! content length
 126         0                        ! padding length
 127         0                        ! reserved
 128     ] output>array
 129     "CCSSCC" pack-be content append ;
 130
 131 :: make-end-request-body ( app-status protocol-status -- seq )
 132     [ app-status protocol-status 0 0 0 ] output>array
 133     "ICCCC" pack-be ;
 134
 135 : make-end-request ( -- seq )
 136     [
 137         fcgi-version                   ! version
 138         FCGI_END_REQUEST enum>number   ! type
 139         1                              ! request id
 140         8                              ! content length (always 8 for end-request-body)
 141         0                              ! padding length
 142         0                              ! reserved
 143         0 0 make-end-request-body
 144     ] output>array flatten ;
 145
 146 : write-response ( content -- )
 147     make-response-packet write make-end-request write ;
 148
 149 :: append-stdin-data ( str -- )
 150     stdin-data [ str append ] tchange ;
 151
 152 ! process a header and determine whether we are
 153 ! expecting more input
 154 : dispatch-by-header ( header -- ? )
 155     dup type>>
 156     {
 157         { FCGI_BEGIN_REQUEST [ process-begin-request t ] }
 158         { FCGI_PARAMS [ process-params t ] }
 159         { FCGI_STDIN [ get-content-data dup append-stdin-data length 0 > ] }  ! keep going until STDIN empty
 160         { FCGI_DATA [ [ "FCGI_DATA ------------------\n" print ] debug-print get-content-data [ >string . ] debug-print f ] }
 161         [ [ "unkown packet type" print ] debug-print drop [ . ] debug-print f ]
 162     } case ;
 163
 164 : make-new-request ( -- )
 165     <request> request tset ;
 166
 167 : parse-packets ( -- )
 168     [ get-header dispatch-by-header ] loop ;
 169
 170 : post? ( -- ? ) request tget method>> "POST" = ;
 171
 172 :: handle-post-data* ( post-data data params -- )
 173     post-data data >>data params >>params
 174     request tget swap >>post-data drop ;
 175
 176 : handle-post-data ( -- )
 177     post? [
 178         request tget dup "CONTENT_TYPE" header
 179         <post-data> [ >>post-data ] keep nip
 180         stdin-data tget >string dup query>assoc
 181         handle-post-data*
 182     ] when ;
 183
 184 : prepare-request ( -- )
 185     request tget
 186     dup "REQUEST_METHOD" header >>method
 187     dup "REQUEST_URI" header >>url
 188     handle-post-data
 189     [ . ] debug-print ;
 190
 191 : fcgi-handler ( -- )
 192     make-new-request parse-packets
 193     prepare-request
 194     "/path" main-responder get call-responder*
 195     [ content-type>> "\n\n" append ] [ body>> ] bi append write-response ;
 196
 197 : <fastcgi-server> ( addr -- server )
 198     binary
 199     <threaded-server>
 200       swap >>insecure
 201       "fastcgi-server" >>name
 202       [ fcgi-handler ] >>handler ;
 203
 204 : test-output ( -- str )
 205     "<pre>"
 206     request tget header>> [ "%s => %s\n" sprintf ] { }
 207     assoc>map concat append
 208     "</pre>" append ;
 209
 210 TUPLE: test-responder ;
 211 C: <test-responder> test-responder
 212 M: test-responder call-responder* 2drop test-output <html-content> ;
 213
 214 : do-it ( -- )
 215     <test-responder> main-responder set
 216     socket-path [ delete-if-exists ] keep
 217     make-local-socket <fastcgi-server> dup fcgi-server set
 218     start-server drop ;