1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
|
module RunHTTP(runHTTP) where
import Network.URI(uriPath,uriQuery)
import Network.CGI(ContentType(..))
import Network.CGI.Protocol(CGIResult(..),CGIRequest(..),Input(..),
Headers,HeaderName(..))
import Network.CGI.Monad(runCGIT)
import Network.Shed.Httpd(initServer,Request(..),Response(..),queryToArguments)
import qualified Data.ByteString.Lazy.Char8 as BS(pack,unpack)
import qualified Data.Map as M(fromList)
documentRoot = "www"
runHTTP port = initServer port . cgiHandler
cgiHandler h = fmap httpResp . runCGIT h . cgiReq
httpResp :: (Headers,CGIResult) -> Response
httpResp (hdrs,r) = Response code (map name hdrs) (body r)
where
code = maybe 200 (read.head.words) (lookup (HeaderName "Status") hdrs)
body CGINothing = ""
body (CGIOutput s) = BS.unpack s
name (HeaderName n,v) = (n,v)
cgiReq :: Request -> CGIRequest
cgiReq (Request method uri hdrs body) = CGIRequest vars inputs body'
where
vars = M.fromList [("REQUEST_METHOD",method),
("REQUEST_URI",show uri),
("SCRIPT_FILENAME",documentRoot++uriPath uri),
("QUERY_STRING",qs)]
qs = case uriQuery uri of
'?':s -> s
s -> s
inputs = map input $ queryToArguments qs -- assumes method=="GET"
body' = BS.pack body
input (name,val) = (name,Input (BS.pack val) Nothing plaintext)
plaintext = ContentType "plain" "text" []
|
