Paste: fcgi

! Copyright (C) 2010 Brennan Cheung.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.enums alien.syntax assocs combinators
combinators.smart io io.binary io.directories io.encodings.binary
io.files io.servers.connection io.sockets io.streams.byte-array kernel
locals math namespaces pack prettyprint sequences sequences.deep
strings unix.users ;
IN: fastcgi

SYMBOL: fcgi-server
SYMBOL: fcgi-role
SYMBOL: fcgi-flags
SYMBOL: fcgi-params
SYMBOL: fcgi-request

CONSTANT: fcgi-version 1
CONSTANT: socket-path "/chroot/web/var/run/factor.sock"

TUPLE: fcgi-header version type request-id content-length
    padding-length reserved ;

TUPLE: request params stdin data ;

: <request> ( params stdin data -- obj ) request boa ;

ENUM: fcgi-header-types
    { FCGI_BEGIN_REQUEST 1 }
    FCGI_ABORT_REQUEST
    FCGI_END_REQUEST
    FCGI_PARAMS
    FCGI_STDIN
    FCGI_STDOUT
    FCGI_STDERR
    FCGI_DATA
    FCGI_GET_VALUES
    FCGI_GET_VALUES_RESULT
    FCGI_UNKNOWN_TYPE
    { FCGI_MAXTYPE 11 } ;

ENUM: fcgi-roles
    { FCGI_RESPONDER 1 }
    FCGI_AUTHORIZER
    FCGI_FILTER ;

ENUM: fcgi-protocol-status
    { FCGI_REQUEST_COMPLETE 0 }
    FCGI_CANT_MAX_CONN
    FCGI_OVERLOADED
    FCGI_UNKNOWN_ROLE ;

:: debug-print ( print-quot -- )
    global [ print-quot call flush ] bind ; inline

! read either a 1 byte or 4 byte big endian integer
: read-var-int ( -- n/f )
    read1 [
        dup 7 bit?
        [ 127 bitand 3 read swap suffix be> ] when
    ] [ f ] if* ;

: store-key-value-param ( key value -- )
    swap fcgi-params get set-at ;
!    "%s => %s" sprintf [ print ] debug-print ;

: read-params ( -- )
    [
        read-var-int read-var-int 2dup and
        [
            [ read >string ] bi@
            store-key-value-param
            t
        ] [ 2drop f ] if
    ] loop
    fcgi-request get fcgi-params get >>params fcgi-request set ;
    
: delete-if-exists ( file -- )
    dup exists? [ delete-file ] [ drop ] if ;

: make-local-socket ( -- socket )
    socket-path [ delete-if-exists ] keep
    <local> ; 

: get-header ( -- header )
    "CCSSCC" read-packed-be
    [ fcgi-header boa ] input<sequence
    dup type>> fcgi-header-types number>enum >>type ;

: get-content-data ( header -- content )
    dup
    [ content-length>> ] [ padding-length>> ] bi or 0 > ! need to check because 0 read is blocking for some reason
    [
        [ content-length>> read ] [ padding-length>> read drop ] bi
    ] [ drop f ] if ;

: begin-request-body ( seq -- )
    binary [ "SCCCCCC" read-packed-be ] with-byte-reader
    first2 fcgi-flags set fcgi-roles number>enum fcgi-role set ;

: process-begin-request ( header -- )
    get-content-data begin-request-body
    H{ } clone dup fcgi-params set
    "" "" <request> fcgi-request set ;

: process-params ( header -- )
    get-content-data binary [ read-params ] with-byte-reader ;

:: make-response-packet ( content -- seq )
    [
        fcgi-version             ! version
        FCGI_STDOUT enum>number  ! type
        1                        ! request id
        content length           ! content length
        0                        ! padding length
        0                        ! reserved
    ] output>array
    "CCSSCC" pack-be content append ;

:: make-end-request-body ( app-status protocol-status -- seq )
    [ app-status protocol-status 0 0 0 ] output>array "ICCCC" pack-be ;

: make-end-request ( -- seq )
    [
        fcgi-version                   ! version
        FCGI_END_REQUEST enum>number   ! type
        1                              ! request id
        8                              ! content length (always 8 for end-request-body)
        0                              ! padding length
        0                              ! reserved
        0 0 make-end-request-body
    ] output>array flatten ;

: write-response ( content -- )
    make-response-packet write ;

! process a header and determine whether we are expecting more input
: dispatch-by-header ( header -- ? )
    dup type>>
    {
        { FCGI_BEGIN_REQUEST [ process-begin-request t ] }
        { FCGI_PARAMS [ process-params t ] }
        { FCGI_STDIN [ get-content-data drop f ] } ! server should be done sending request
        [ drop [ . ] debug-print f ]
    } case ;

: page-handler ( -- )
    "Content-type: text/html\n\nThis is a test" write-response ;

: fcgi-handler ( -- )
    [ get-header dispatch-by-header ] loop [ "stopped" print ] debug-print page-handler ;

: <fastcgi-server> ( addr -- server )
    binary
    <threaded-server>
      swap >>insecure
      "fastcgi-server" >>name
      [ fcgi-handler ] >>handler ;

: do-it ( -- )
    socket-path delete-if-exists
    "nginx" [ make-local-socket <fastcgi-server> dup fcgi-server set start-server ]  with-real-user ;