module Ella.Request (
Request
, RequestOptions(..)
, requestMethod
, pathInfo
, requestUriRaw
, environment
, allPOST
, allGET
, getPOST
, getPOSTlist
, hasPOST
, getGET
, getGETlist
, hasGET
, getCookieVal
, allCookies
, files
, mkRequest
, buildCGIRequest
, changeEncoding
, escapePath
, escapePathWithEnc
, Encoding(..)
, utf8Encoding
, FileInput(..)
, ContentType(..)
)
where
import Data.ByteString.Lazy (ByteString)
import Data.ByteString.Lazy.Char8 (pack, unpack)
import qualified Data.ByteString.Lazy as BS
import qualified Data.ByteString.Lazy.UTF8 as UTF8
import Data.List (partition)
import qualified Data.Map as Map
import Data.Maybe
import Network.CGI.Cookie (readCookies)
import Network.CGI.Protocol (takeInput, formDecode)
import Ella.CGI.Multipart
import Network.URI (escapeURIString, isUnescapedInURI)
import System.Environment (getEnvironment)
import System.IO (stdin)
data Encoding = Encoding {
name :: String
, decoder :: ByteString -> String
, encoder :: String -> ByteString
}
instance Eq Encoding where
x == y = name x == name y
instance Show Encoding where
show x = "Encoding " ++ name x
utf8Encoding :: Encoding
utf8Encoding = Encoding {
name = "UTF8"
, decoder = UTF8.toString
, encoder = UTF8.fromString
}
data RequestOptions = RequestOptions {
encoding :: Encoding
} deriving (Eq, Show)
data Request = Request {
environment :: Map.Map String String
, requestBody :: ByteString
, requestEncoding :: Encoding
, _env :: [(String, String)]
, allPOST :: [(String, String)]
, _postInputMap :: Map.Map String String
, allGET :: [(String, String)]
, _getInputMap :: Map.Map String String
, files :: Map.Map String FileInput
, allCookies :: [(String, String)]
} deriving (Show, Eq)
mkRequest :: [(String, String)]
-> ByteString
-> Encoding
-> Request
mkRequest env body enc
= let envMap = Map.fromList env
in Request {
environment = envMap
, requestBody = body
, requestEncoding = enc
, _env = env
, allPOST = pvs
, _postInputMap = Map.fromList pvs
, allGET = gvs
, _getInputMap = Map.fromList gvs
, files = Map.fromList fvs
, allCookies = readCookies $ lookupOrNil "HTTP_COOKIE" env
}
where
(pvs, fvs) = bodyInput env body enc
gvs = queryInput env enc
changeEncoding :: Encoding -> Request -> Request
changeEncoding enc req = mkRequest (_env req) (requestBody req) enc
requestMethod :: Request -> String
requestMethod request = fromJust $ Map.lookup "REQUEST_METHOD" $ environment request
pathInfo :: Request -> String
pathInfo request = let pi = Map.lookup "PATH_INFO" $ environment request
adjusted = case pi of
Nothing -> ""
Just ('/':rest) -> rest
Just path -> path
in repack adjusted (requestEncoding request)
repack :: String -> Encoding -> String
repack str encoding = let bytes = pack str
in (decoder encoding) bytes
requestUriRaw :: Request -> Maybe String
requestUriRaw request = Map.lookup "REQUEST_URI" $ environment request
buildCGIRequest :: RequestOptions
-> IO Request
buildCGIRequest opts = do
env <- getEnvironment
body <- BS.hGetContents stdin
return $ mkRequest env body (encoding opts)
escapePath :: ByteString -> String
escapePath bs = escapeURIString isUnescapedInURIPath $ unpack bs
where isUnescapedInURIPath c = isUnescapedInURI c && c `notElem` "?#"
escapePathWithEnc :: String -> Encoding -> String
escapePathWithEnc s enc = escapePath (encoder enc $ s)
getPOST :: Request -> String -> Maybe String
getPOST req name = Map.lookup name $ _postInputMap req
getPOSTlist :: Request -> String -> [String]
getPOSTlist req name = getMatching name (allPOST req)
hasPOST :: Request -> String -> Bool
hasPOST req name = Map.member name $ _postInputMap req
getGET :: Request -> String -> Maybe String
getGET req name = Map.lookup name $ _getInputMap req
getGETlist :: Request -> String -> [String]
getGETlist req name = getMatching name (allGET req)
hasGET :: Request -> String -> Bool
hasGET req name = Map.member name $ _getInputMap req
getCookieVal req name = lookup name $ allCookies req
queryInput :: [(String,String)]
-> Encoding
-> [(String,String)]
queryInput env enc = formInputEnc (lookupOrNil "QUERY_STRING" env) enc
formInputEnc :: String
-> Encoding
-> [(String,String)]
formInputEnc qs encoding = [(repack n encoding, repack v encoding) | (n,v) <- formDecode qs]
data FileInput = FileInput { fileFilename :: String
, fileContents :: ByteString
, fileContentType :: ContentType
} deriving (Read, Show, Eq)
defaultInputType :: ContentType
defaultInputType = ContentType "text" "plain" []
bodyInput :: [(String,String)]
-> ByteString
-> Encoding
-> ([(String,String)], [(String,FileInput)])
bodyInput env inp enc =
case lookup "REQUEST_METHOD" env of
Just "POST" ->
let ctype = lookup "CONTENT_TYPE" env >>= parseContentType
in decodeBody ctype (takeInput env inp) enc
_ -> ([], [])
decodeBody :: Maybe ContentType
-> ByteString
-> Encoding
-> ([(String,String)], [(String,FileInput)])
decodeBody ctype inp enc =
case ctype of
Just (ContentType "application" "x-www-form-urlencoded" _)
-> (formInputEnc (unpack inp) enc, [])
Just (ContentType "multipart" "form-data" ps)
-> multipartDecode ps inp enc
Just _ -> ([], [])
Nothing -> (formInputEnc (unpack inp) enc, [])
multipartDecode :: [(String,String)]
-> ByteString
-> Encoding
-> ([(String,String)]
,[(String,FileInput)])
multipartDecode ps inp enc =
case lookup "boundary" ps of
Just b -> let MultiPart bs = parseMultipartBody b inp
in splitLeftRight $ map (bodyPartToInput enc) bs
Nothing -> ([],[])
bodyPartToInput :: Encoding -> BodyPart -> Either (String,String) (String,FileInput)
bodyPartToInput enc (BodyPart hs b) =
case getContentDisposition hs of
Just (ContentDisposition "form-data" ps) ->
let name = repack (lookupOrNil "name" ps) enc
filename = lookup "filename" ps
in case filename of
Just f -> Right (name, FileInput { fileFilename = repack f enc
, fileContentType = ctype
, fileContents = b
})
Nothing -> Left (name, (decoder enc) b)
_ -> error "No Content-Disposition in input"
where ctype = fromMaybe defaultInputType (getContentType hs)
lookupOrNil :: String -> [(String,String)] -> String
lookupOrNil n = fromMaybe "" . lookup n
splitLeftRight xs = let (ls, rs) = partition isLeft xs
in (map (either id undefined) ls,
map (either undefined id) rs)
isLeft (Left x) = True
isLeft _ = False
getMatching name assoclist = map snd $ filter ((==name) . fst) assoclist