RunHTTP.hs

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" []