module Util.MIME where
import System.IO
import System.Random
import Numeric ( showHex )
import Data.List ( intercalate )
import Codec.MIME.Type as MIME
uploadFileType :: String -> MIME.Type
uploadFileType bou = MIME.Type
{ mimeType = Multipart FormData
, mimeParams = [("boundary", bou)]
}
mixedType :: IO (MIMEValue, String)
mixedType = do
let low = (2^(32::Integer)1) :: Integer
x <- randomRIO (low,low*low)
let boundary = replicate 30 '-' ++ showHex x ""
return (nullMIMEValue
{ mime_val_type = MIME.Type { mimeType = Multipart Mixed
, mimeParams = [("boundary", boundary)]
}
}, boundary)
uploadFile :: String -> FilePath -> IO MIMEValue
uploadFile nm fp = do
let file_disp =
Disposition
{ dispType = DispFormData
, dispParams = [ Name nm, Filename fp ]
}
h <- openBinaryFile fp ReadMode
ls <- hGetContents h
let fileValue =
nullMIMEValue
{ mime_val_type = Type{mimeType=Text "plain", mimeParams=[]}
, mime_val_disp = Just file_disp
, mime_val_content = Single ls
, mime_val_headers = [ ("Content-Transfer-Encoding", "binary")
, ("Content-Length", show (length ls))
]
, mime_val_inc_type = True
}
return fileValue
showMIMEValue :: String -> MIMEValue -> ([(String,String)], String)
showMIMEValue m mv =
let marker =
case mimeType (mime_val_type mv) of
Multipart{} ->
case lookup "boundary" (mimeParams (mime_val_type mv)) of
Just x -> crnl ++ '-':'-':x
_ -> m
_ -> m
in
( withType $ withDisp (mime_val_headers mv)
, (if True || null m then (crnl++) else (\x -> m ++ crnl ++ x))
(showMIMEContent marker (mime_val_content mv))
)
where
withType
| mime_val_inc_type mv = (("Content-Type", showType (mime_val_type mv)):)
| otherwise = id
withDisp =
case mime_val_disp mv of
Nothing -> id
Just d -> (("Content-Disposition", showDisposition d):)
showMIMEContent :: String -> MIMEContent -> String
showMIMEContent _marker (Single s) = s
showMIMEContent marker (Multi ms) =
concat (map (s.(showMIMEValue marker)) ms) ++ marker ++ "--"
where
s (hs,v) = marker ++ crnl ++
intercalate crnl (map (\ (a,b) -> (a ++ ':':' ':b)) hs) ++ crnl ++ v
crnl :: String
crnl = "\r\n"
showDisposition :: Disposition -> String
showDisposition d =
showDispType (dispType d) ++
(concat $ map showDispParam (dispParams d))
showDispType :: DispType -> String
showDispType dt =
case dt of
DispInline -> "inline"
DispAttachment -> "attachment"
DispFormData -> "form-data"
DispOther x -> x
showDispParam :: DispParam -> String
showDispParam dp = ';':' ':
case dp of
Name x -> "name="++show x
Filename x -> "filename=" ++ show x
CreationDate s -> "creation-date=" ++ show s
ModDate s -> "modification-date=" ++ show s
ReadDate s -> "read-date=" ++ show s
MIME.Size x -> "size=" ++ show x
OtherParam a b -> a ++ '=':show b