diff options
Diffstat (limited to 'MIME/Parse.hs')
-rw-r--r-- | MIME/Parse.hs | 241 |
1 files changed, 0 insertions, 241 deletions
diff --git a/MIME/Parse.hs b/MIME/Parse.hs deleted file mode 100644 index 06fffc6..0000000 --- a/MIME/Parse.hs +++ /dev/null @@ -1,241 +0,0 @@ -{- | - Module : MIME.Parse - Copyright : (c) 2006 - - Maintainer : tse-dev-team@galois.com - Stability : unstable - Portability : GHC - - Parsing MIME content. --} -module MIME.Parse - ( parseMIMEBody - , parseMIMEType - ) where - -import MIME.Type -import MIME.Decode - -import Data.Char -import Data.Maybe -import Data.List -import Debug.Trace ( trace ) - -parseMIMEBody :: [(String,String)] -> String -> MIMEValue -parseMIMEBody headers_in body = - case mimeType mty of - Multipart{} -> fst (parseMultipart mty body) - Message{} -> fst (parseMultipart mty body) - _ -> MIMEValue mty (parseContentDisp headers) - (Single (processBody headers body)) - - where headers = [ (map toLower k,v) | (k,v) <- headers_in ] - mty = fromMaybe defaultType - (parseContentType =<< lookup "content-type" headers) -defaultType :: Type -defaultType = Type { mimeType = Text "plain" - , mimeParams = [("charset", "us-ascii")] - } - -parseContentDisp :: [(String,String)] -> Maybe Disposition -parseContentDisp headers = - (processDisp . dropFoldingWSP) =<< lookup "content-disposition" headers - where - processDisp "" = Nothing - processDisp xs = Just $ - case break (\ch -> isSpace ch || ch == ';') xs of - (as,"") -> Disposition { dispType = toDispType (map toLower as) - , dispParams = [] - } - (as,bs) -> Disposition { dispType = toDispType (map toLower as) - , dispParams = processParams (parseParams bs) - } - - processParams = map procP - where - procP (as,val) - | "name" == asl = Name val - | "filename" == asl = Filename val - | "creation-date" == asl = CreationDate val - | "modification-date" == asl = ModDate val - | "read-date" == asl = ReadDate val - | "size" == asl = Size val - | otherwise = OtherParam (map toLower as) val - where asl = map toLower as - - toDispType t = case t of - "inline" -> DispInline - "attachment" -> DispAttachment - "form-data" -> DispFormData - _ -> DispOther t - - -processBody :: [(String,String)] -> String -> String -processBody headers body = - case lookup "content-transfer-encoding" headers of - Nothing -> body - Just v -> decodeBody v body - -parseMIMEMessage :: String -> MIMEValue -parseMIMEMessage entity = - case parseHeaders entity of - (as,bs) -> parseMIMEBody as bs - -parseHeaders :: String -> ([(String,String)], String) -parseHeaders str = - case findFieldName "" str of - Left (nm, rs) -> parseFieldValue nm (dropFoldingWSP rs) - Right body -> ([],body) - where - findFieldName _acc "" = Right "" - findFieldName _acc ('\r':'\n':xs) = Right xs - findFieldName acc (':':xs) = Left (reverse (dropWhile isHSpace acc), xs) - findFieldName acc (x:xs) = findFieldName (x:acc) xs - - parseFieldValue nm xs = - case takeUntilCRLF xs of - (as,"") -> ([(nm,as)],"") - (as,bs) -> let (zs,ys) = parseHeaders bs in ((nm,as):zs,ys) - -parseMultipart :: Type -> String -> (MIMEValue, String) -parseMultipart mty body = - case lookup "boundary" (mimeParams mty) of - Nothing -> trace ("Multipart mime type, " ++ showType mty ++ - ", has no required boundary parameter. Defaulting to text/plain") $ - (MIMEValue defaultType Nothing (Single body), "") - Just bnd -> (MIMEValue mty Nothing (Multi vals), rs) - where (vals,rs) = splitMulti bnd body - -splitMulti :: String -> String -> ([MIMEValue], String) -splitMulti bnd body_in = - -- Note: we insert a CRLF if it looks as if the boundary string starts - -- right off the bat. No harm done if this turns out to be incorrect. - let body = case body_in of - '-':'-':_ -> ('\r':'\n':body_in) - _ -> body_in - in case untilMatch dashBoundary body of - Nothing -> ([],"") - Just ('-':'-':xs) -> ([],xs) - Just xs -> splitMulti1 (dropTrailer xs) - - where - dashBoundary = ("\r\n--" ++ bnd) - - splitMulti1 xs = - case matchUntil dashBoundary xs of - ("","") -> ([],"") - (as,"") -> ([parseMIMEMessage as],"") - (as,'-':'-':bs) -> ([parseMIMEMessage as], dropTrailer bs) - (as,bs) -> let (zs,ys) = splitMulti1 (dropTrailer bs) - in ((parseMIMEMessage as) : zs,ys) - - dropTrailer xs = - case dropWhile isHSpace xs of - '\r':'\n':xs1 -> xs1 - xs1 -> xs1 -- hmm, flag an error? - -parseMIMEType :: String -> Maybe Type -parseMIMEType = parseContentType - -parseContentType :: String -> Maybe Type -parseContentType str = - case break (=='/') (dropFoldingWSP str) of - (maj,_:minor) -> - case break (\ ch -> isHSpace ch || isTSpecial ch) minor of - (as,bs) -> - Just Type { mimeType = toType maj as - , mimeParams = parseParams (dropWhile isHSpace bs) - } - _ -> trace ("unable to parse content-type: " ++ show str) $ Nothing - where - toType a b = case lookup (map toLower a) mediaTypes of - Just ctor -> ctor b - _ -> Other a b - - -parseParams :: String -> [(String,String)] -parseParams "" = [] -parseParams (';':xs) = - case break (=='=') (dropFoldingWSP xs) of - (nm,_:vs) -> - case vs of - '"':vs1 -> - case break (=='"') vs1 of - (val,"") -> [(nm,val)] - (val,_:zs) -> (nm,val):parseParams (dropWhile isHSpace zs) - _ -> case break (\ ch -> isHSpace ch || isTSpecial ch) vs of - (val,zs) -> (nm,val):parseParams (dropWhile isHSpace zs) - _ -> [] - -parseParams cs = trace ("curious: " ++ show cs) [] - -mediaTypes :: [(String, String -> MIMEType)] -mediaTypes = - [ ("multipart", (Multipart . toMultipart)) - , ("application", Application) - , ("audio", Audio) - , ("image", Image) - , ("message", Message) - , ("model", Model) - , ("text", Text) - , ("video", Video) - ] - where toMultipart b = fromMaybe other (lookup (map toLower b) multipartTypes) - where other = case b of - 'x':'-':_ -> Extension b - _ -> OtherMulti b - - -multipartTypes :: [(String, Multipart)] -multipartTypes = - [ ("alternative", Alternative) - , ("byteranges", Byteranges) - , ("digest", Digest) - , ("encrypted", Encrypted) - , ("form-data", FormData) - , ("mixed", Mixed) - , ("parallel", Parallel) - , ("related", Related) - , ("signed", Signed) - ] - - -untilMatch :: String -> String -> Maybe String -untilMatch str xs = go str xs - where go "" rs = Just rs - go _ "" = Nothing - go (a:as) (b:bs) = if a == b then go as bs else go str bs - -matchUntil :: String -> String -> (String, String) -matchUntil _ "" = ("", "") -matchUntil str xs - -- slow, but it'll do for now. - | str `isPrefixOf` xs = ("", drop (length str) xs) -matchUntil str (x:xs) = let (as,bs) = matchUntil str xs in (x:as,bs) - - - -isHSpace :: Char -> Bool -isHSpace c = c == ' ' || c == '\t' - -isTSpecial :: Char -> Bool -isTSpecial x = x `elem` "()<>@,;:\\\"/[]?=" - - -dropFoldingWSP :: String -> String -dropFoldingWSP "" = "" -dropFoldingWSP (x:xs) - | isHSpace x = dropFoldingWSP xs -dropFoldingWSP ('\r':'\n':x:xs) - | isHSpace x = dropFoldingWSP xs -dropFoldingWSP (x:xs) = x:xs - -takeUntilCRLF :: String -> (String, String) -takeUntilCRLF str = go "" str - where - go acc "" = (reverse (dropWhile isHSpace acc), "") - go acc ('\r':'\n':x:xs) - | isHSpace x = go (' ':acc) xs - | otherwise = (reverse (dropWhile isHSpace acc), x:xs) - go acc (x:xs) = go (x:acc) xs - |