basis/http/server/cgi/cgi.factor

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