module Network.CGI.Protocol (
CGIRequest(..), Input(..),
CGIResult(..),
Headers, HeaderName(..),
hRunCGI, runCGIEnvFPS,
decodeInput, takeInput,
getCGIVars,
logCGI,
formEncode, urlEncode, formDecode, urlDecode,
maybeRead, replace
) where
import Control.Monad.Trans (MonadIO(..))
import Data.Char (toLower)
import Data.List (intersperse)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromMaybe, listToMaybe, isJust)
import Network.URI (unEscapeString,escapeURIString,isUnescapedInURI)
import System.Environment (getEnvironment)
import System.IO (Handle, hPutStrLn, stderr, hFlush)
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString)
import Data.Typeable (Typeable(..), mkTyConApp, mkTyCon)
import Network.CGI.Multipart
data CGIRequest =
CGIRequest {
cgiVars :: Map String String,
cgiInputs :: [(String, Input)],
cgiRequestBody :: ByteString
}
deriving (Show)
instance Typeable CGIResult where
typeOf _ = mkTyConApp (mkTyCon "Network.CGI.Protocol.CGIResult") []
data Input = Input {
inputValue :: ByteString,
inputFilename :: Maybe String,
inputContentType :: ContentType
}
deriving Show
data CGIResult = CGIOutput ByteString
| CGINothing
deriving (Show, Read, Eq, Ord)
type Headers = [(HeaderName, String)]
newtype HeaderName = HeaderName String deriving (Show)
instance Eq HeaderName where
HeaderName x == HeaderName y = map toLower x == map toLower y
instance Ord HeaderName where
HeaderName x `compare` HeaderName y = map toLower x `compare` map toLower y
hRunCGI :: MonadIO m =>
[(String,String)]
-> Handle
-> Handle
-> (CGIRequest -> m (Headers, CGIResult))
-> m ()
hRunCGI env hin hout f =
do inp <- liftIO $ BS.hGetContents hin
outp <- runCGIEnvFPS env inp f
liftIO $ BS.hPut hout outp
liftIO $ hFlush hout
runCGIEnvFPS :: Monad m =>
[(String,String)]
-> ByteString
-> (CGIRequest -> m (Headers, CGIResult))
-> m ByteString
runCGIEnvFPS vars inp f
= do let (inputs,body) = decodeInput vars inp
(hs,outp) <- f $ CGIRequest {
cgiVars = Map.fromList vars,
cgiInputs = inputs,
cgiRequestBody = body
}
return $ case outp of
CGIOutput c -> formatResponse c hs'
where hs' = if isJust (lookup ct hs)
then hs else hs ++ [(ct,defaultContentType)]
ct = HeaderName "Content-type"
CGINothing -> formatResponse BS.empty hs
formatResponse :: ByteString -> Headers -> ByteString
formatResponse c hs =
unlinesCrLf ([BS.pack (n++": "++v) | (HeaderName n,v) <- hs]
++ [BS.empty,c])
where unlinesCrLf = BS.concat . intersperse (BS.pack "\r\n")
defaultContentType :: String
defaultContentType = "text/html; charset=ISO-8859-1"
decodeInput :: [(String,String)]
-> ByteString
-> ([(String,Input)],ByteString)
decodeInput env inp =
let (inputs, body) = bodyInput env inp in (queryInput env ++ inputs, body)
simpleInput :: String -> Input
simpleInput v = Input { inputValue = BS.pack v,
inputFilename = Nothing,
inputContentType = defaultInputType }
defaultInputType :: ContentType
defaultInputType = ContentType "text" "plain" []
getCGIVars :: MonadIO m => m [(String,String)]
getCGIVars = liftIO getEnvironment
logCGI :: MonadIO m => String -> m ()
logCGI s = liftIO (hPutStrLn stderr s)
queryInput :: [(String,String)]
-> [(String,Input)]
queryInput env = formInput $ lookupOrNil "QUERY_STRING" env
formInput :: String
-> [(String,Input)]
formInput qs = [(n, simpleInput v) | (n,v) <- formDecode qs]
formEncode :: [(String,String)] -> String
formEncode xs =
concat $ intersperse "&" [urlEncode n ++ "=" ++ urlEncode v | (n,v) <- xs]
urlEncode :: String -> String
urlEncode = replace ' ' '+' . escapeURIString okChar
where okChar c = c == ' ' ||
(isUnescapedInURI c && c `notElem` "&=+")
formDecode :: String -> [(String,String)]
formDecode "" = []
formDecode s = (urlDecode n, urlDecode (drop 1 v)) : formDecode (drop 1 rs)
where (nv,rs) = break (=='&') s
(n,v) = break (=='=') nv
urlDecode :: String -> String
urlDecode = unEscapeString . replace '+' ' '
bodyInput :: [(String,String)]
-> ByteString
-> ([(String,Input)], ByteString)
bodyInput env inp =
case lookup "REQUEST_METHOD" env of
Just "POST" ->
let ctype = lookup "CONTENT_TYPE" env >>= parseContentType
in decodeBody ctype $ takeInput env inp
_ -> ([], inp)
decodeBody :: Maybe ContentType
-> ByteString
-> ([(String,Input)], ByteString)
decodeBody ctype inp =
case ctype of
Just (ContentType "application" "x-www-form-urlencoded" _)
-> (formInput (BS.unpack inp), BS.empty)
Just (ContentType "multipart" "form-data" ps)
-> (multipartDecode ps inp, BS.empty)
Just _ -> ([], inp)
Nothing -> (formInput (BS.unpack inp), BS.empty)
takeInput :: [(String,String)]
-> ByteString
-> ByteString
takeInput env req =
case len of
Just l -> BS.take l req
Nothing -> BS.empty
where len = lookup "CONTENT_LENGTH" env >>= maybeRead
multipartDecode :: [(String,String)]
-> ByteString
-> [(String,Input)]
multipartDecode ps inp =
case lookup "boundary" ps of
Just b -> let MultiPart bs = parseMultipartBody b inp
in map bodyPartToInput bs
Nothing -> []
bodyPartToInput :: BodyPart -> (String,Input)
bodyPartToInput (BodyPart hs b) =
case getContentDisposition hs of
Just (ContentDisposition "form-data" ps) ->
(lookupOrNil "name" ps,
Input { inputValue = b,
inputFilename = lookup "filename" ps,
inputContentType = ctype })
_ -> ("ERROR",simpleInput "ERROR")
where ctype = fromMaybe defaultInputType (getContentType hs)
replace :: Eq a =>
a
-> a
-> [a]
-> [a]
replace x y = map (\z -> if z == x then y else z)
maybeRead :: Read a => String -> Maybe a
maybeRead = fmap fst . listToMaybe . reads
lookupOrNil :: String -> [(String,String)] -> String
lookupOrNil n = fromMaybe "" . lookup n