Verified Commit 6b234bdc authored by Camil Staps's avatar Camil Staps 🚀

Fix Internet.HTTP.CGI (fixes #3)

parent dba91cb7
......@@ -98,5 +98,4 @@ badRequestResponse :: !String -> HTTPResponse
staticResponse :: !HTTPRequest !*World -> (!HTTPResponse, !*World)
customResponse :: ![((String -> Bool),(HTTPRequest *World -> (HTTPResponse, *World)))] !Bool !HTTPRequest !*World -> (!HTTPResponse, !*World)
encodeResponse :: !Bool !HTTPResponse !*World -> (!String,!*World)
......@@ -283,3 +283,21 @@ customResponse [(pred,handler):rest] fallback request world
= handler request world //Apply handler function
= customResponse rest fallback request world //Search the rest of the list
//Response utilities
encodeResponse :: !Bool !HTTPResponse !*World -> (!String,!*World)
encodeResponse withreply {rsp_headers = headers, rsp_data = data} world
# reply = if withreply
("HTTP/1.0 " +++ (default "200 OK" (lookup "Status" headers)) +++ "\r\n")
("Status: " +++ (default "200 OK" (lookup "Status" headers)) +++ "\r\n")
# reply = reply +++ ("Server: " +++ (default "Clean HTTP tools" (lookup "Server" headers)) +++ "\r\n") //Server identifier
# reply = reply +++ ("Content-Type: " +++ (default "text/html" (lookup "Content-Type" headers)) +++ "\r\n") //Content type header
# reply = reply +++ ("Content-Length: " +++ (toString (size data)) +++ "\r\n") //Content length header
# reply = reply +++ (foldr (+++) "" [(n +++ ": " +++ v +++ "\r\n") \\ (n,v) <- headers | not (skipHeader n)]) //Additional headers
# reply = reply +++ ("\r\n" +++ data) //Separator + data
= (reply, world)
where
//Do not add these headers two times
default def mbval = case mbval of
Nothing = def
(Just val) = val
skipHeader s = isMember s ["Status","Date","Server","Content-Type","Content-Length","Last-Modified"]
implementation module Internet.HTTP.CGI
import StdFile, StdInt, StdBool, StdArray
import Data.Maybe, Internet.HTTP, Text, System.Environment, Data.Map
import Data.Maybe, Data.Tuple, Internet.HTTP, Text, System.Environment, Data.Map
//Http headers which should be polled in the environment
CGI_HEADERS :== [ ("Content-Type","CONTENT_TYPE")
......@@ -22,7 +22,7 @@ startCGI options handlers world
# (ok,console) = freopen console FReadData
# (datalength, world) = getDataLength world
# (data, console) = getData datalength console //Read post data
# (req_method, world) = getFromEnv "REQUEST_METHOD" world //Read environment data
# (req_method, world) = appFst fromString (getFromEnv "REQUEST_METHOD" world) //Read environment data
# (req_path, world) = getFromEnv "SCRIPT_NAME" world
# (req_query, world) = getFromEnv "QUERY_STRING" world
# (req_version, world) = getFromEnv "SERVER_PROTOCOL" world
......
......@@ -92,6 +92,7 @@ import qualified Graphics.Layout
import qualified Graphics.Scalable
import qualified Graphics.Scalable.Internal
import qualified Internet.HTTP
import qualified Internet.HTTP.CGI
import qualified Math.Geometry
import qualified Math.Random
import qualified Network.IP
......@@ -138,7 +139,6 @@ import qualified Text.Unicode.UChar
//Errors that need to be fixed
import qualified Text.XML
import qualified Internet.HTTP.CGI
import qualified Database.SQL.RelationalMapping
Start = "Hello World!"
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment