basis/http/server/cgi/cgi.factor

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