module Happstack.Server.MessageWrap where
import Control.Monad.Identity
import qualified Data.ByteString.Char8 as P
import qualified Data.ByteString.Lazy.Char8 as L
import qualified Data.List as List
import Data.Maybe
import Happstack.Server.HTTP.Types as H
import Happstack.Server.HTTP.Multipart
import Happstack.Server.SURI as SURI
import Happstack.Util.Common
queryInput :: SURI -> [(String, Input)]
queryInput uri = formDecode (case SURI.query uri of
'?':r -> r
xs -> xs)
bodyInput :: Request -> [(String, Input)]
bodyInput req | rqMethod req /= POST = []
bodyInput req =
let ctype = getHeader "content-type" req >>= parseContentType . P.unpack
getBS (Body bs) = bs
in decodeBody ctype (getBS $ rqBody req)
formDecode :: String -> [(String, Input)]
formDecode [] = []
formDecode qString =
if null pairString then rest else
(SURI.unEscape name,simpleInput $ SURI.unEscape val):rest
where (pairString,qString')= split (=='&') qString
(name,val)=split (=='=') pairString
rest=if null qString' then [] else formDecode qString'
decodeBody :: Maybe ContentType
-> L.ByteString
-> [(String,Input)]
decodeBody ctype inp
= case ctype of
Just (ContentType "application" "x-www-form-urlencoded" _)
-> formDecode (L.unpack inp)
Just (ContentType "multipart" "form-data" ps)
-> multipartDecode ps inp
Just _ -> []
Nothing -> formDecode (L.unpack inp)
multipartDecode :: [(String,String)]
-> L.ByteString
-> [(String,Input)]
multipartDecode ps inp =
case lookup "boundary" ps of
Just b -> case parseMultipartBody b inp of
Just (MultiPart bs) -> map bodyPartToInput bs
Nothing -> []
Nothing -> []
bodyPartToInput :: BodyPart -> (String,Input)
bodyPartToInput (BodyPart hs b) =
case getContentDisposition hs of
Just (ContentDisposition "form-data" ps) ->
(fromMaybe "" $ lookup "name" ps,
Input { inputValue = b,
inputFilename = lookup "filename" ps,
inputContentType = ctype })
_ -> ("ERROR",simpleInput "ERROR")
where ctype = fromMaybe defaultInputType (getContentType hs)
simpleInput :: String -> Input
simpleInput v
= Input { inputValue = L.pack v
, inputFilename = Nothing
, inputContentType = defaultInputType
}
defaultInputType :: ContentType
defaultInputType = ContentType "text" "plain" []
pathEls :: String -> [String]
pathEls = (drop 1) . map SURI.unEscape . splitList '/'
class (Read a)=>ReadString a where readString::String->a; readString =read
instance ReadString Int
instance ReadString Double
instance ReadString Float
instance ReadString SURI.SURI where readString = read . show
instance ReadString [Char] where readString=id
instance ReadString Char where
readString s= if length t==1 then head t else read t where t=trim s