module Util.Post where
import Codec.MIME.Type as MIME
import Codec.MIME.Parse as MIME
import Util.MIME
import Codec.URLEncoder
import Data.List
import System.Random
import Numeric
data PostReq
= PostReq
{ prName :: String
, prVals :: [PostParam]
}
data PostKind
= PostQuery
| PostWWWForm
| PostFormData
newPostRequest :: String -> PostReq
newPostRequest s = PostReq{prName=s,prVals=[]}
testRequest :: PostReq
-> Maybe PostKind
-> IO ()
testRequest a b = do
(as,bs,cs) <- toRequest a b
putStrLn ("URL query portion: " ++ as)
putStrLn (unlines $ map (\ (k,v) -> k ++ ':':' ':v) bs)
putStrLn ""
putStrLn cs
toRequest :: PostReq
-> Maybe PostKind
-> IO (String, [(String,String)], String)
toRequest pr mbKind =
case mbKind of
Nothing ->
case filter isPostFile (prVals pr) of
(_:_) -> toRequest pr (Just PostFormData)
_ -> toRequest pr (Just PostWWWForm)
Just PostQuery ->
case partition isPostFile (prVals pr) of
(ls@(_:_),bs) -> do
putStrLn ("toRequest: POST request contains " ++
shows (length ls) (" files; unable to represent as query string"))
putStrLn ("Defaulting to multiform/form-data instead")
toRequest pr{prVals=bs++ls} (Just PostFormData)
_ -> return (intercalate "&" $
map (\ (PostNameValue n v) -> encodeString n ++ '=':encodeString v) (prVals pr), [],"")
Just PostWWWForm ->
case partition isPostFile (prVals pr) of
(ls@(_:_),bs) -> do
putStrLn ("toRequest: POST request contains " ++
shows (length ls) (" files; unable to represent as application/x-www-form-urlencoded"))
putStrLn ("Defaulting to multiform/form-data instead")
toRequest pr{prVals=bs++ls} (Just PostFormData)
_ -> return ( ""
, [("Content-Type", "application/x-www-form-urlencoded")]
, crnl ++ (intercalate "&" $
map (\ (PostNameValue n v) -> encodeString n ++ '=':encodeString v) (prVals pr))
)
Just PostFormData -> do
mv <- toMIMEValue (prVals pr)
let (hs,bod) = showMIMEValue "" mv
return ( "", hs, bod)
addNameValue :: String -> String -> PostReq -> PostReq
addNameValue n v pr = pr{prVals=(PostNameValue n v):prVals pr}
addNameFile :: String -> FilePath -> Maybe String -> PostReq -> PostReq
addNameFile nm fp mbTy pr = pr{prVals=(PostFile nm fp mbTy):prVals pr}
data PostParam
= PostNameValue String
String
| PostFile String
FilePath
(Maybe String)
isPostFile :: PostParam -> Bool
isPostFile PostFile{} = True
isPostFile _ = False
toMIMEValue :: [PostParam] -> IO MIMEValue
toMIMEValue ps = do
let low = (2^(32::Integer)1) :: Integer
x <- randomRIO (low,low*low)
let boundary = replicate 30 '-' ++ showHex x ""
let (fs,ns) =
case partition isPostFile ps of
([_],_) -> ([],ps)
xs -> xs
fns <- mapM (fromPostParam boundary) ns
(mi,b) <- mixedType
ffs <- mapM (fromPostParam b) fs
let addM [] = []
addM xs = [mi{mime_val_content=Multi xs}]
return MIMEValue
{ mime_val_type = MIME.Type{ mimeType = Multipart FormData
, mimeParams = [("boundary", boundary)]
}
, mime_val_disp = Nothing
, mime_val_content = Multi (fns ++ addM ffs)
, mime_val_inc_type = True
, mime_val_headers = []
}
fromPostParam :: String -> PostParam -> IO MIMEValue
fromPostParam _boundary (PostNameValue n v) =
return MIMEValue
{ mime_val_type = MIME.Type
{ mimeType = Application "x-www-form-urlencoded"
, mimeParams=[]
}
, mime_val_disp = Just $
Disposition { dispType = DispFormData
, dispParams = [Name n]
}
, mime_val_content = Single (encodeString v)
, mime_val_headers = []
, mime_val_inc_type = False
}
fromPostParam _boundary (PostFile nm fp mbTy) = do
ty <-
case mbTy of
Nothing -> getMIMEType fp
Just ty -> toMIMEType ty
mv <- uploadFile nm fp
return mv{mime_val_type=ty}
toMIMEType :: String -> IO Type
toMIMEType tyStr =
case parseMIMEType tyStr of
Just t -> return t
_ -> return MIME.Type{mimeType=Text "plain",mimeParams=[]}
getMIMEType :: String -> IO Type
getMIMEType x =
case parseMIMEType x of
Just t -> return t
_ -> return MIME.Type{mimeType=Application "octet-stream",mimeParams=[]}