module Hascat.Protocol (
Input(..),
ServletRequest(..),
decodeInput, takeInput,
formDecode, urlDecode,
maybeRead, replace
) where
import Data.List (intersperse)
import qualified Data.Map as Map
import Data.Map (Map)
import Data.Maybe (fromMaybe, listToMaybe, isJust)
import Network.URI
import qualified Network.HTTP as HTTP
import qualified Data.ByteString.Lazy.Char8 as BS
import Data.ByteString.Lazy.Char8 (ByteString)
import Hascat.Multipart
data ServletRequest = ServletRequest {
rqURI :: URI,
rqMethod :: HTTP.RequestMethod,
rqHeaders :: [HTTP.Header],
rqInputs :: [(String, Input)],
rqBody :: ByteString
}
deriving Show
data Input = Input {
inputValue :: ByteString,
inputFilename :: Maybe String,
inputContentType :: ContentType
}
deriving Show
decodeInput :: HTTP.Request ByteString
-> ServletRequest
decodeInput req@(HTTP.Request uri method headers inp) =
let inputs = bodyInput req
in ServletRequest uri method headers (queryInput uri ++ inputs) inp
simpleInput :: String -> Input
simpleInput v = Input { inputValue = BS.pack v,
inputFilename = Nothing,
inputContentType = defaultInputType }
defaultInputType :: ContentType
defaultInputType = ContentType "text" "plain" []
queryInput :: URI
-> [(String,Input)]
queryInput uri = formInput $
case uriQuery uri of
'?':str -> str
str -> str
formInput :: String
-> [(String,Input)]
formInput qs = [(n, simpleInput v) | (n,v) <- formDecode qs]
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 :: HTTP.Request ByteString
-> [(String,Input)]
bodyInput req@(HTTP.Request uri method headers inp) =
case method of
HTTP.POST ->
let ctype = HTTP.lookupHeader HTTP.HdrContentType headers >>= parseContentType
in decodeBody ctype $ takeInput headers inp
_ -> []
decodeBody :: Maybe ContentType
-> ByteString
-> [(String,Input)]
decodeBody ctype inp =
case ctype of
Just (ContentType "application" "x-www-form-urlencoded" _)
-> formInput (BS.unpack inp)
Just (ContentType "multipart" "form-data" ps)
-> multipartDecode ps inp
Just _ -> []
Nothing -> formInput (BS.unpack inp)
takeInput :: [HTTP.Header]
-> ByteString
-> ByteString
takeInput headers req =
case len of
Just l -> BS.take l req
Nothing -> BS.empty
where len = HTTP.lookupHeader HTTP.HdrContentLength headers >>= 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