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