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