mirror of
https://github.com/GrammaticalFramework/gf-core.git
synced 2026-04-09 13:09:33 -06:00
45 lines
1.7 KiB
Haskell
45 lines
1.7 KiB
Haskell
module RunHTTP(runHTTP,Options(..),cgiHandler) where
|
|
import Network.URI(uriPath,uriQuery)
|
|
import CGI(ContentType(..))
|
|
import CGI(CGIResult(..),CGIRequest(..),Input(..),
|
|
Headers,HeaderName(..))
|
|
import CGI(runCGIT)
|
|
import Network.Shed.Httpd(initServer,Request(..),Response(..))
|
|
import qualified Data.ByteString.Lazy.Char8 as BS(pack,unpack,empty)
|
|
import qualified Data.Map as M(fromList)
|
|
import URLEncoding(decodeQuery)
|
|
|
|
data Options = Options { documentRoot :: String, port :: Int } deriving Show
|
|
|
|
runHTTP (Options root port) = initServer port . cgiHandler root
|
|
|
|
cgiHandler root h = fmap httpResp . runCGIT h . cgiReq root
|
|
|
|
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 :: String -> Request -> CGIRequest
|
|
cgiReq root (Request method uri hdrs body)
|
|
| method == "POST" = CGIRequest vars (map input (decodeQuery body)) BS.empty
|
|
| otherwise = CGIRequest vars (map input (decodeQuery qs )) BS.empty -- assumes method=="GET"
|
|
where
|
|
vars = M.fromList [("REQUEST_METHOD",method),
|
|
("REQUEST_URI",show uri),
|
|
("SCRIPT_FILENAME",root++uriPath uri),
|
|
("QUERY_STRING",qs),
|
|
("HTTP_ACCEPT_LANGUAGE",al)]
|
|
qs = case uriQuery uri of
|
|
'?':'&':s -> s -- httpd-shed bug workaround
|
|
'?':s -> s
|
|
s -> s
|
|
al = maybe "" id $ lookup "Accept-Language" hdrs
|
|
|
|
input (name,val) = (name,Input (BS.pack val) Nothing plaintext)
|
|
plaintext = ContentType "text" "plain" []
|