module Hack.Handler.CGI
( run
, helper
) where
import Hack
import Data.Default
import System.Environment (getEnvironment)
import Data.Maybe (fromMaybe)
import qualified Data.ByteString.Lazy as BS
import Data.Word (Word8)
import Control.Arrow (first)
import Data.Char (toLower)
safeRead :: Read a => a -> String -> a
safeRead d s =
case reads s of
((x, _):_) -> x
[] -> d
lookup' :: String -> [(String, String)] -> String
lookup' key pairs = fromMaybe "" $ lookup key pairs
run :: Application -> IO ()
run app = do
vars <- getEnvironment
body' <- BS.getContents
helper vars body' app >>= BS.putStr
helper :: [(String, String)]
-> BS.ByteString
-> Application
-> IO BS.ByteString
helper vars body' app = do
let rmethod = safeRead GET $ lookup' "REQUEST_METHOD" vars
sname = lookup' "SCRIPT_NAME" vars
pinfo = lookup' "PATH_INFO" vars
qstring = lookup' "QUERY_STRING" vars
servername = lookup' "SERVER_NAME" vars
serverport = safeRead 80 $ lookup' "SERVER_PORT" vars
contentLength = safeRead 0 $ lookup' "CONTENT_LENGTH" vars
let env = def
{ requestMethod = rmethod
, scriptName = sname
, pathInfo = pinfo
, queryString = qstring
, serverName = servername
, serverPort = serverport
, http = map (first cleanupVarName) vars
, hackInput = BS.take contentLength body'
}
res <- app env
let h = headers res
let h' = case lookup "Content-type" h of
Nothing -> ("Content-type", "text/html; charset=utf-8") : h
Just _ -> h
let s = case status res of
0 -> 200
x -> x
return $ BS.concat
[ pack "Status: "
, pack $ show s
, pack "\n"
, BS.concat $ map showHeader h'
, pack "\n"
, body res
]
showHeader :: (String, String) -> BS.ByteString
showHeader (x, y) = pack $ x ++ ": " ++ y ++ "\n"
pack :: String -> BS.ByteString
pack = BS.pack . map safeCharToWord8
safeCharToWord8 :: Char -> Word8
safeCharToWord8 c
| fromEnum c < 256 = toEnum $ fromEnum c
| otherwise = error $ "Out of bound character, value: " ++
show (fromEnum c)
cleanupVarName :: String -> String
cleanupVarName ('H':'T':'T':'P':'_':a:as) = a : helper' as where
helper' ('_':x:rest) = '-' : x : helper' rest
helper' (x:rest) = toLower x : helper' rest
helper' [] = []
cleanupVarName x = x