basis/http/server/cgi/cgi.factor

   1 ! Copyright (C) 2007, 2009 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: namespaces kernel assocs io.files io.streams.duplex
   4 combinators arrays io.launcher io.encodings io.encodings.binary io
   5 http.server.static http.server http accessors sequences strings
   6 math.parser fry urls urls.encoding calendar make ;
   7 IN: http.server.cgi
   8
   9 : cgi-variables ( script-path -- assoc )
  10     ! This needs some work.
  11     [
  12         "CGI/1.0" "GATEWAY_INTERFACE" ,,
  13         "HTTP/" request get version>> append "SERVER_PROTOCOL" ,,
  14         "Factor" "SERVER_SOFTWARE" ,,
  15
  16         [ "PATH_TRANSLATED" ,, ] [ "SCRIPT_FILENAME" ,, ] bi
  17
  18         url get path>> "SCRIPT_NAME" ,,
  19
  20         url get host>> "SERVER_NAME" ,,
  21         url get port>> number>string "SERVER_PORT" ,,
  22         "" "PATH_INFO" ,,
  23         "" "REMOTE_HOST" ,,
  24         "" "REMOTE_ADDR" ,,
  25         "" "AUTH_TYPE" ,,
  26         "" "REMOTE_USER" ,,
  27         "" "REMOTE_IDENT" ,,
  28
  29         request get method>> "REQUEST_METHOD" ,,
  30         url get query>> assoc>query "QUERY_STRING" ,,
  31         request get "cookie" header "HTTP_COOKIE" ,,
  32
  33         request get "user-agent" header "HTTP_USER_AGENT" ,,
  34         request get "accept" header "HTTP_ACCEPT" ,,
  35
  36         post-request? [
  37             request get post-data>> data>>
  38             [ "CONTENT_TYPE" ,, ]
  39             [ length number>string "CONTENT_LENGTH" ,, ]
  40             bi
  41         ] when
  42     ] H{ } make ;
  43
  44 : <cgi-process> ( name -- desc )
  45     <process>
  46         over 1array >>command
  47         swap cgi-variables >>environment
  48         1 minutes >>timeout ;
  49
  50 : serve-cgi ( name -- response )
  51     <raw-response>
  52     200 >>code
  53     "CGI output follows" >>message
  54     swap '[
  55         binary encode-output
  56         output-stream get _ <cgi-process> binary <process-stream> [
  57             post-request? [ request get post-data>> data>> write flush ] when
  58             '[ _ stream-write ] each-block
  59         ] with-stream
  60     ] >>body ;
  61
  62 SLOT: special
  63
  64 : enable-cgi ( responder -- responder )
  65     [ serve-cgi ] "application/x-cgi-script"
  66     pick special>> set-at ;