mime 0.3.2 → 0.3.3
raw patch · 10 files changed
+836/−841 lines, 10 filesdep ~basesetup-changed
Dependency ranges changed: base
Files
- CHANGES +5/−5
- Codec/MIME/Base64.hs +147/−147
- Codec/MIME/Decode.hs +76/−76
- Codec/MIME/Parse.hs +268/−268
- Codec/MIME/QuotedPrintable.hs +66/−66
- Codec/MIME/Type.hs +187/−187
- Codec/MIME/Utils.hs +32/−32
- LICENSE +27/−27
- Setup.hs +4/−4
- mime.cabal +24/−29
CHANGES view
@@ -1,5 +1,5 @@-Version 0.3.2: released 2009-12-21 - -* sub-point release. -* extend exports of Codec.MIME.Parse to include misc - local utility functions: parseMIMEMessage, parseContentType +Version 0.3.2: released 2009-12-21++* sub-point release.+* extend exports of Codec.MIME.Parse to include misc+ local utility functions: parseMIMEMessage, parseContentType
Codec/MIME/Base64.hs view
@@ -1,147 +1,147 @@--------------------------------------------------------------------- --- | --- Module : Codec.MIME.Base64 --- Copyright : (c) 2006-2009, Galois, Inc. --- License : BSD3 --- --- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com> --- Stability : provisional --- Portability: portable --- --- --- Base64 decoding and encoding routines, multiple entry --- points for either depending on use and level of control --- wanted over the encoded output (and its input form on the --- decoding side.) --- --------------------------------------------------------------------- -module Codec.MIME.Base64 - ( encodeRaw -- :: Bool -> String -> [Word8] - , encodeRawString -- :: Bool -> String -> String - , encodeRawPrim -- :: Bool -> Char -> Char -> [Word8] -> String - - , formatOutput -- :: Int -> Maybe String -> String -> String - - , decode -- :: String -> [Word8] - , decodeToString -- :: String -> String - , decodePrim -- :: Char -> Char -> String -> [Word8] - ) where - -import Data.Bits -import Data.Char -import Data.Word -import Data.Maybe - -encodeRawString :: Bool -> String -> String -encodeRawString trail xs = encodeRaw trail (map (fromIntegral.ord) xs) - --- | @formatOutput n mbLT str@ formats @str@, splitting it --- into lines of length @n@. The optional value lets you control what --- line terminator sequence to use; the default is CRLF (as per MIME.) -formatOutput :: Int -> Maybe String -> String -> String -formatOutput n mbTerm str - | n <= 0 = error ("Codec.MIME.Base64.formatOutput: negative line length " ++ show n) - | otherwise = chop n str - where - crlf :: String - crlf = fromMaybe "\r\n" mbTerm - - chop _ "" = "" - chop i xs = - case splitAt i xs of - (as,"") -> as - (as,bs) -> as ++ crlf ++ chop i bs - -encodeRaw :: Bool -> [Word8] -> String -encodeRaw trail bs = encodeRawPrim trail '+' '/' bs - --- | @encodeRawPrim@ lets you control what non-alphanum characters to use --- (The base64url variation uses @*@ and @-@, for instance.) --- No support for mapping these to multiple characters in the output though. -encodeRawPrim :: Bool -> Char -> Char -> [Word8] -> String -encodeRawPrim trail ch62 ch63 ls = encoder ls - where - trailer xs ys - | not trail = xs - | otherwise = xs ++ ys - f = fromB64 ch62 ch63 - encoder [] = [] - encoder [x] = trailer (take 2 (encode3 f x 0 0 "")) "==" - encoder [x,y] = trailer (take 3 (encode3 f x y 0 "")) "=" - encoder (x:y:z:ws) = encode3 f x y z (encoder ws) - -encode3 :: (Word8 -> Char) -> Word8 -> Word8 -> Word8 -> String -> String -encode3 f a b c rs = - f (low6 (w24 `shiftR` 18)) : - f (low6 (w24 `shiftR` 12)) : - f (low6 (w24 `shiftR` 6)) : - f (low6 w24) : rs - where - w24 :: Word32 - w24 = (fromIntegral a `shiftL` 16) + - (fromIntegral b `shiftL` 8) + - fromIntegral c - -decodeToString :: String -> String -decodeToString str = map (chr.fromIntegral) $ decode str - -decode :: String -> [Word8] -decode str = decodePrim '+' '/' str - -decodePrim :: Char -> Char -> String -> [Word8] -decodePrim ch62 ch63 str = decoder $ takeUntilEnd str - where - takeUntilEnd "" = [] - takeUntilEnd ('=':_) = [] - takeUntilEnd (x:xs) = - case toB64 ch62 ch63 x of - Nothing -> takeUntilEnd xs - Just b -> b : takeUntilEnd xs - -decoder :: [Word8] -> [Word8] -decoder [] = [] -decoder [x] = take 1 (decode4 x 0 0 0 []) -decoder [x,y] = take 1 (decode4 x y 0 0 []) -- upper 4 bits of second val are known to be 0. -decoder [x,y,z] = take 2 (decode4 x y z 0 []) -decoder (x:y:z:w:xs) = decode4 x y z w (decoder xs) - -decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> [Word8] -> [Word8] -decode4 a b c d rs = - (lowByte (w24 `shiftR` 16)) : - (lowByte (w24 `shiftR` 8)) : - (lowByte w24) : rs - where - w24 :: Word32 - w24 = - (fromIntegral a) `shiftL` 18 .|. - (fromIntegral b) `shiftL` 12 .|. - (fromIntegral c) `shiftL` 6 .|. - (fromIntegral d) - -toB64 :: Char -> Char -> Char -> Maybe Word8 -toB64 a b ch - | ch >= 'A' && ch <= 'Z' = Just (fromIntegral (ord ch - ord 'A')) - | ch >= 'a' && ch <= 'z' = Just (26 + fromIntegral (ord ch - ord 'a')) - | ch >= '0' && ch <= '9' = Just (52 + fromIntegral (ord ch - ord '0')) - | ch == a = Just 62 - | ch == b = Just 63 - | otherwise = Nothing - -fromB64 :: Char -> Char -> Word8 -> Char -fromB64 ch62 ch63 x - | x < 26 = chr (ord 'A' + xi) - | x < 52 = chr (ord 'a' + (xi-26)) - | x < 62 = chr (ord '0' + (xi-52)) - | x == 62 = ch62 - | x == 63 = ch63 - | otherwise = error ("fromB64: index out of range " ++ show x) - where - xi :: Int - xi = fromIntegral x - -low6 :: Word32 -> Word8 -low6 x = fromIntegral (x .&. 0x3f) - -lowByte :: Word32 -> Word8 -lowByte x = (fromIntegral x) .&. 0xff - +--------------------------------------------------------------------+-- |+-- Module : Codec.MIME.Base64+-- Copyright : (c) 2006-2009, Galois, Inc. +-- License : BSD3+--+-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>+-- Stability : provisional+-- Portability: portable+--+-- +-- Base64 decoding and encoding routines, multiple entry+-- points for either depending on use and level of control+-- wanted over the encoded output (and its input form on the+-- decoding side.)+-- +--------------------------------------------------------------------+module Codec.MIME.Base64 + ( encodeRaw -- :: Bool -> String -> [Word8]+ , encodeRawString -- :: Bool -> String -> String+ , encodeRawPrim -- :: Bool -> Char -> Char -> [Word8] -> String++ , formatOutput -- :: Int -> Maybe String -> String -> String++ , decode -- :: String -> [Word8]+ , decodeToString -- :: String -> String+ , decodePrim -- :: Char -> Char -> String -> [Word8]+ ) where++import Data.Bits+import Data.Char+import Data.Word+import Data.Maybe++encodeRawString :: Bool -> String -> String+encodeRawString trail xs = encodeRaw trail (map (fromIntegral.ord) xs)++-- | @formatOutput n mbLT str@ formats @str@, splitting it+-- into lines of length @n@. The optional value lets you control what+-- line terminator sequence to use; the default is CRLF (as per MIME.)+formatOutput :: Int -> Maybe String -> String -> String+formatOutput n mbTerm str+ | n <= 0 = error ("Codec.MIME.Base64.formatOutput: negative line length " ++ show n)+ | otherwise = chop n str+ where+ crlf :: String+ crlf = fromMaybe "\r\n" mbTerm++ chop _ "" = ""+ chop i xs =+ case splitAt i xs of+ (as,"") -> as+ (as,bs) -> as ++ crlf ++ chop i bs++encodeRaw :: Bool -> [Word8] -> String+encodeRaw trail bs = encodeRawPrim trail '+' '/' bs++-- | @encodeRawPrim@ lets you control what non-alphanum characters to use+-- (The base64url variation uses @*@ and @-@, for instance.)+-- No support for mapping these to multiple characters in the output though.+encodeRawPrim :: Bool -> Char -> Char -> [Word8] -> String+encodeRawPrim trail ch62 ch63 ls = encoder ls+ where+ trailer xs ys+ | not trail = xs+ | otherwise = xs ++ ys+ f = fromB64 ch62 ch63 + encoder [] = []+ encoder [x] = trailer (take 2 (encode3 f x 0 0 "")) "=="+ encoder [x,y] = trailer (take 3 (encode3 f x y 0 "")) "="+ encoder (x:y:z:ws) = encode3 f x y z (encoder ws)++encode3 :: (Word8 -> Char) -> Word8 -> Word8 -> Word8 -> String -> String+encode3 f a b c rs = + f (low6 (w24 `shiftR` 18)) :+ f (low6 (w24 `shiftR` 12)) :+ f (low6 (w24 `shiftR` 6)) :+ f (low6 w24) : rs+ where+ w24 :: Word32+ w24 = (fromIntegral a `shiftL` 16) ++ (fromIntegral b `shiftL` 8) + + fromIntegral c++decodeToString :: String -> String+decodeToString str = map (chr.fromIntegral) $ decode str++decode :: String -> [Word8]+decode str = decodePrim '+' '/' str++decodePrim :: Char -> Char -> String -> [Word8]+decodePrim ch62 ch63 str = decoder $ takeUntilEnd str+ where+ takeUntilEnd "" = []+ takeUntilEnd ('=':_) = []+ takeUntilEnd (x:xs) = + case toB64 ch62 ch63 x of+ Nothing -> takeUntilEnd xs+ Just b -> b : takeUntilEnd xs++decoder :: [Word8] -> [Word8]+decoder [] = []+decoder [x] = take 1 (decode4 x 0 0 0 [])+decoder [x,y] = take 1 (decode4 x y 0 0 []) -- upper 4 bits of second val are known to be 0.+decoder [x,y,z] = take 2 (decode4 x y z 0 [])+decoder (x:y:z:w:xs) = decode4 x y z w (decoder xs)++decode4 :: Word8 -> Word8 -> Word8 -> Word8 -> [Word8] -> [Word8]+decode4 a b c d rs =+ (lowByte (w24 `shiftR` 16)) :+ (lowByte (w24 `shiftR` 8)) :+ (lowByte w24) : rs+ where+ w24 :: Word32+ w24 =+ (fromIntegral a) `shiftL` 18 .|.+ (fromIntegral b) `shiftL` 12 .|.+ (fromIntegral c) `shiftL` 6 .|.+ (fromIntegral d)++toB64 :: Char -> Char -> Char -> Maybe Word8+toB64 a b ch+ | ch >= 'A' && ch <= 'Z' = Just (fromIntegral (ord ch - ord 'A'))+ | ch >= 'a' && ch <= 'z' = Just (26 + fromIntegral (ord ch - ord 'a'))+ | ch >= '0' && ch <= '9' = Just (52 + fromIntegral (ord ch - ord '0'))+ | ch == a = Just 62+ | ch == b = Just 63+ | otherwise = Nothing++fromB64 :: Char -> Char -> Word8 -> Char+fromB64 ch62 ch63 x + | x < 26 = chr (ord 'A' + xi)+ | x < 52 = chr (ord 'a' + (xi-26))+ | x < 62 = chr (ord '0' + (xi-52))+ | x == 62 = ch62+ | x == 63 = ch63+ | otherwise = error ("fromB64: index out of range " ++ show x)+ where+ xi :: Int+ xi = fromIntegral x++low6 :: Word32 -> Word8+low6 x = fromIntegral (x .&. 0x3f)++lowByte :: Word32 -> Word8+lowByte x = (fromIntegral x) .&. 0xff+
Codec/MIME/Decode.hs view
@@ -1,76 +1,76 @@--------------------------------------------------------------------- --- | --- Module : Codec.MIME.Decode --- Copyright : (c) 2006-2009, Galois, Inc. --- License : BSD3 --- --- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com> --- Stability : provisional --- Portability: portable --- --- --- --------------------------------------------------------------------- - -module Codec.MIME.Decode where - -import Data.Char - -import Codec.MIME.QuotedPrintable as QP -import Codec.MIME.Base64 as Base64 - --- | @decodeBody enc str@ decodes @str@ according to the scheme --- specified by @enc@. Currently, @base64@ and @quoted-printable@ are --- the only two encodings supported. If you supply anything else --- for @enc@, @decodeBody@ returns @str@. --- -decodeBody :: String -> String -> String -decodeBody enc body = - case map toLower enc of - "base64" -> map (chr.fromIntegral) $ Base64.decode body - "quoted-printable" -> QP.decode body - _ -> body - --- Decoding of RFC 2047's "encoded-words" production --- (as used in email-headers and some HTTP header cases --- (AtomPub's Slug: header)) -decodeWord :: String -> Maybe (String, String) -decodeWord str = - case str of - '=':'?':xs -> - case dropLang $ break (\ch -> ch =='?' || ch == '*') xs of - (cs,_:x:'?':bs) - | isKnownCharset (map toLower cs) -> - case toLower x of - 'q' -> decodeQ cs (break (=='?') bs) - 'b' -> decodeB cs (break (=='?') bs) - _ -> Nothing - _ -> Nothing - _ -> Nothing - where - isKnownCharset cs = cs `elem` ["iso-8859-1", "us-ascii"] - - -- ignore RFC 2231 extension of permitting a language tag to be supplied - -- after the charset. - dropLang (as,'*':bs) = (as,dropWhile (/='?') bs) - dropLang (as,bs) = (as,bs) - - decodeQ cset (fs,'?':'=':rs) = Just (fromCharset cset (QP.decode fs),rs) - decodeQ _ _ = Nothing - - decodeB cset (fs,'?':'=':rs) = - Just (fromCharset cset (Base64.decodeToString fs),rs) - decodeB _ _ = Nothing - - fromCharset _cset cs = cs - -decodeWords :: String -> String -decodeWords "" = "" -decodeWords (x:xs) - | isSpace x = x : decodeWords xs - | otherwise = - case decodeWord (x:xs) of - Nothing -> x : decodeWords xs - Just (as,bs) -> as ++ decodeWords bs - - +--------------------------------------------------------------------+-- |+-- Module : Codec.MIME.Decode+-- Copyright : (c) 2006-2009, Galois, Inc. +-- License : BSD3+--+-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>+-- Stability : provisional+-- Portability: portable+--+-- +-- +--------------------------------------------------------------------++module Codec.MIME.Decode where++import Data.Char++import Codec.MIME.QuotedPrintable as QP+import Codec.MIME.Base64 as Base64++-- | @decodeBody enc str@ decodes @str@ according to the scheme+-- specified by @enc@. Currently, @base64@ and @quoted-printable@ are+-- the only two encodings supported. If you supply anything else+-- for @enc@, @decodeBody@ returns @str@.+-- +decodeBody :: String -> String -> String+decodeBody enc body =+ case map toLower enc of+ "base64" -> map (chr.fromIntegral) $ Base64.decode body+ "quoted-printable" -> QP.decode body+ _ -> body++-- Decoding of RFC 2047's "encoded-words" production+-- (as used in email-headers and some HTTP header cases+-- (AtomPub's Slug: header))+decodeWord :: String -> Maybe (String, String)+decodeWord str =+ case str of+ '=':'?':xs ->+ case dropLang $ break (\ch -> ch =='?' || ch == '*') xs of+ (cs,_:x:'?':bs)+ | isKnownCharset (map toLower cs) ->+ case toLower x of+ 'q' -> decodeQ cs (break (=='?') bs)+ 'b' -> decodeB cs (break (=='?') bs)+ _ -> Nothing+ _ -> Nothing+ _ -> Nothing+ where+ isKnownCharset cs = cs `elem` ["iso-8859-1", "us-ascii"]++ -- ignore RFC 2231 extension of permitting a language tag to be supplied+ -- after the charset.+ dropLang (as,'*':bs) = (as,dropWhile (/='?') bs)+ dropLang (as,bs) = (as,bs)++ decodeQ cset (fs,'?':'=':rs) = Just (fromCharset cset (QP.decode fs),rs)+ decodeQ _ _ = Nothing++ decodeB cset (fs,'?':'=':rs) =+ Just (fromCharset cset (Base64.decodeToString fs),rs)+ decodeB _ _ = Nothing++ fromCharset _cset cs = cs++decodeWords :: String -> String+decodeWords "" = ""+decodeWords (x:xs)+ | isSpace x = x : decodeWords xs+ | otherwise =+ case decodeWord (x:xs) of+ Nothing -> x : decodeWords xs+ Just (as,bs) -> as ++ decodeWords bs++
Codec/MIME/Parse.hs view
@@ -1,268 +1,268 @@--------------------------------------------------------------------- --- | --- Module : Codec.MIME.Pare --- Copyright : (c) 2006-2009, Galois, Inc. --- License : BSD3 --- --- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com> --- Stability : provisional --- Portability: portable --- --- Parsing MIME content. --- --------------------------------------------------------------------- -module Codec.MIME.Parse - ( parseMIMEBody -- :: [(String,String)] -> String -> MIMEValue - , parseMIMEType -- :: String -> Maybe Type - , parseMIMEMessage -- :: String -> MIMEValue - - , parseHeaders -- :: String -> ([(String,String)], String) - , parseMultipart -- :: Type -> String -> (MIMEValue, String) - , parseContentType -- :: String -> Maybe Type - , splitMulti -- :: String -> String -> ([MIMEValue], String) - ) where - -import Codec.MIME.Type -import Codec.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) - _ -> nullMIMEValue - { mime_val_type = mty - , mime_val_disp = parseContentDisp headers - , mime_val_content = Single (processBody headers body) - } - - where headers = [ (map toLower k,v) | (k,v) <- headers_in ] - mty = fromMaybe defaultType - (parseContentType =<< lookupField "content-type" headers) -defaultType :: Type -defaultType = Type { mimeType = Text "plain" - , mimeParams = [("charset", "us-ascii")] - } - -parseContentDisp :: [(String,String)] -> Maybe Disposition -parseContentDisp headers = - (processDisp . dropFoldingWSP) =<< lookupField "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 lookupField "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 lookupField "boundary" (mimeParams mty) of - Nothing -> trace ("Multipart mime type, " ++ showType mty ++ - ", has no required boundary parameter. Defaulting to text/plain") $ - (nullMIMEValue{ mime_val_type = defaultType - , mime_val_disp = Nothing - , mime_val_content = Single body - }, "") - Just bnd -> (nullMIMEValue { mime_val_type = mty - , mime_val_disp = Nothing - , mime_val_content = 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 lookupField (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_raw,_: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) - where - nm = map toLower nm_raw - -parseParams cs = trace ("Codec.MIME.Parse.parseParams: curious param value -- " ++ 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 (lookupField (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 - --- case in-sensitive lookup of field names or attributes\/parameters. -lookupField :: String -> [(String,a)] -> Maybe a -lookupField n ns = - -- assume that inputs have been mostly normalized already - -- (i.e., lower-cased), but should the lookup fail fall back - -- to a second try where we do normalize before giving up. - case lookup n ns of - x@Just{} -> x - Nothing -> - let nl = map toLower n in - case find (\ (y,_) -> nl == map toLower y) ns of - Nothing -> Nothing - Just (_,x) -> Just x - +--------------------------------------------------------------------+-- |+-- Module : Codec.MIME.Pare+-- Copyright : (c) 2006-2009, Galois, Inc. +-- License : BSD3+--+-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>+-- Stability : provisional+-- Portability: portable+--+-- Parsing MIME content.+-- +--------------------------------------------------------------------+module Codec.MIME.Parse+ ( parseMIMEBody -- :: [(String,String)] -> String -> MIMEValue+ , parseMIMEType -- :: String -> Maybe Type+ , parseMIMEMessage -- :: String -> MIMEValue++ , parseHeaders -- :: String -> ([(String,String)], String)+ , parseMultipart -- :: Type -> String -> (MIMEValue, String)+ , parseContentType -- :: String -> Maybe Type+ , splitMulti -- :: String -> String -> ([MIMEValue], String)+ ) where++import Codec.MIME.Type+import Codec.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)+ _ -> nullMIMEValue + { mime_val_type = mty+ , mime_val_disp = parseContentDisp headers+ , mime_val_content = Single (processBody headers body)+ }++ where headers = [ (map toLower k,v) | (k,v) <- headers_in ]+ mty = fromMaybe defaultType+ (parseContentType =<< lookupField "content-type" headers)+defaultType :: Type+defaultType = Type { mimeType = Text "plain"+ , mimeParams = [("charset", "us-ascii")]+ }++parseContentDisp :: [(String,String)] -> Maybe Disposition+parseContentDisp headers =+ (processDisp . dropFoldingWSP) =<< lookupField "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 lookupField "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 lookupField "boundary" (mimeParams mty) of+ Nothing -> trace ("Multipart mime type, " ++ showType mty +++ ", has no required boundary parameter. Defaulting to text/plain") $+ (nullMIMEValue{ mime_val_type = defaultType+ , mime_val_disp = Nothing+ , mime_val_content = Single body+ }, "")+ Just bnd -> (nullMIMEValue { mime_val_type = mty+ , mime_val_disp = Nothing+ , mime_val_content = 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 lookupField (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_raw,_: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)+ where+ nm = map toLower nm_raw++parseParams cs = trace ("Codec.MIME.Parse.parseParams: curious param value -- " ++ 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 (lookupField (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++-- case in-sensitive lookup of field names or attributes\/parameters.+lookupField :: String -> [(String,a)] -> Maybe a+lookupField n ns = + -- assume that inputs have been mostly normalized already + -- (i.e., lower-cased), but should the lookup fail fall back+ -- to a second try where we do normalize before giving up.+ case lookup n ns of+ x@Just{} -> x+ Nothing -> + let nl = map toLower n in+ case find (\ (y,_) -> nl == map toLower y) ns of+ Nothing -> Nothing+ Just (_,x) -> Just x+
Codec/MIME/QuotedPrintable.hs view
@@ -1,66 +1,66 @@--------------------------------------------------------------------- --- | --- Module : Codec.MIME.QuotedPrintable --- Copyright : (c) 2006-2009, Galois, Inc. --- License : BSD3 --- --- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com> --- Stability : provisional --- Portability: --- --- To and from QP content encoding. --- --------------------------------------------------------------------- -module Codec.MIME.QuotedPrintable - ( decode -- :: String -> String - , encode -- :: String -> String - ) where - -import Data.Char - --- | 'decode' incoming quoted-printable content, stripping --- out soft line breaks and translating @=XY@ sequences --- into their decoded byte\/octet. The output encoding\/representation --- is still a String, not a sequence of bytes. -decode :: String -> String -decode "" = "" -decode ('=':'\r':'\n':xs) = decode xs -- soft line break. -decode ('=':x1:x2:xs) - | isHexDigit x1 && isHexDigit x2 = - chr (digitToInt x1 * 16 + digitToInt x2) : decode xs -decode ('=':xs) = '=':decode xs - -- make it explicit that we propagate other '=' occurrences. -decode (x1:xs) = x1:decode xs - --- | 'encode' converts a sequence of characeter _octets_ into --- quoted-printable form; suitable for transmission in MIME --- payloads. Note the stress on _octets_; it is assumed that --- you have already converted Unicode into a <=8-bit encoding --- (UTF-8, most likely.) -encode :: String -> String -encode xs = encodeLength 0 xs - --- | @encodeLength llen str@ is the worker function during encoding. --- The extra argument @llen@ tracks the current column for the line --- being processed. Soft line breaks are inserted if a line exceeds --- a max length. -encodeLength :: Int -> String -> String -encodeLength _ "" = "" -encodeLength n (x:xs) - | n >= 72 = '=':'\r':'\n':encodeLength 0 (x:xs) -encodeLength _ ('=':xs) - = '=':'3':'D':encodeLength 0 xs -encodeLength n (x:xs) - | ox >= 0x100 = error ("QuotedPrintable.encode: encountered > 8 bit character: " ++ show (x,ox)) - | n >= 72 = '=':'\r':'\n':encodeLength 0 (x:xs) - | ox >= 0x21 && ox <= 0x7e = x : encodeLength (n+1) xs - | ox == 0x09 || ox == 0x20 = x : encodeLength (n+1) xs - | otherwise = '=':showH (ox `div` 0x10): showH (ox `mod` 0x10):encodeLength (n+3) xs - where - ox = ord x - showH v - | v < 10 = chr (ord_0 + v) - | otherwise = chr (ord_A + (v-10)) - - ord_0 = ord '0' - ord_A = ord 'A' +--------------------------------------------------------------------+-- |+-- Module : Codec.MIME.QuotedPrintable+-- Copyright : (c) 2006-2009, Galois, Inc. +-- License : BSD3+--+-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>+-- Stability : provisional+-- Portability:+--+-- To and from QP content encoding.+--+--------------------------------------------------------------------+module Codec.MIME.QuotedPrintable + ( decode -- :: String -> String+ , encode -- :: String -> String+ ) where++import Data.Char++-- | 'decode' incoming quoted-printable content, stripping+-- out soft line breaks and translating @=XY@ sequences+-- into their decoded byte\/octet. The output encoding\/representation +-- is still a String, not a sequence of bytes.+decode :: String -> String+decode "" = ""+decode ('=':'\r':'\n':xs) = decode xs -- soft line break.+decode ('=':x1:x2:xs)+ | isHexDigit x1 && isHexDigit x2 =+ chr (digitToInt x1 * 16 + digitToInt x2) : decode xs+decode ('=':xs) = '=':decode xs+ -- make it explicit that we propagate other '=' occurrences.+decode (x1:xs) = x1:decode xs++-- | 'encode' converts a sequence of characeter _octets_ into+-- quoted-printable form; suitable for transmission in MIME+-- payloads. Note the stress on _octets_; it is assumed that+-- you have already converted Unicode into a <=8-bit encoding+-- (UTF-8, most likely.)+encode :: String -> String+encode xs = encodeLength 0 xs++-- | @encodeLength llen str@ is the worker function during encoding.+-- The extra argument @llen@ tracks the current column for the line+-- being processed. Soft line breaks are inserted if a line exceeds+-- a max length.+encodeLength :: Int -> String -> String+encodeLength _ "" = ""+encodeLength n (x:xs)+ | n >= 72 = '=':'\r':'\n':encodeLength 0 (x:xs)+encodeLength _ ('=':xs) + = '=':'3':'D':encodeLength 0 xs+encodeLength n (x:xs)+ | ox >= 0x100 = error ("QuotedPrintable.encode: encountered > 8 bit character: " ++ show (x,ox))+ | n >= 72 = '=':'\r':'\n':encodeLength 0 (x:xs)+ | ox >= 0x21 && ox <= 0x7e = x : encodeLength (n+1) xs+ | ox == 0x09 || ox == 0x20 = x : encodeLength (n+1) xs+ | otherwise = '=':showH (ox `div` 0x10): showH (ox `mod` 0x10):encodeLength (n+3) xs+ where+ ox = ord x+ showH v+ | v < 10 = chr (ord_0 + v)+ | otherwise = chr (ord_A + (v-10))+ + ord_0 = ord '0'+ ord_A = ord 'A'
Codec/MIME/Type.hs view
@@ -1,187 +1,187 @@--------------------------------------------------------------------- --- | --- Module : Codec.MIME.Type --- Copyright : (c) 2006-2009, Galois, Inc. --- License : BSD3 --- --- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com> --- Stability : provisional --- Portability: portable --- --- --- Representing MIME types and values. --- --------------------------------------------------------------------- -module Codec.MIME.Type where - -import Data.List ( concatMap, isSuffixOf ) - -data Type - = Type - { mimeType :: MIMEType - , mimeParams :: [(String,String)] - } deriving ( Show, Ord, Eq ) - --- | The @null@ MIME record type value; currently a @text/plain@. -nullType :: Type -nullType = Type - { mimeType = Text "plain" - , mimeParams = [] - } - -showType :: Type -> String -showType t = showMIMEType (mimeType t) ++ showMIMEParams (mimeParams t) - -showMIMEParams :: [(String,String)] -> String -showMIMEParams ps = concatMap showP ps - where - showP (a,b) = ';':' ':a ++ '=':'"':b ++ "\"" - - -data MIMEType - = Application SubType - | Audio SubType - | Image SubType - | Message SubType - | Model SubType - | Multipart Multipart - | Text TextType - | Video SubType - | Other String SubType - deriving ( Show, Ord, Eq ) - -showMIMEType :: MIMEType -> String -showMIMEType t = - case t of - Application s -> "application/"++s - Audio s -> "audio/"++s - Image s -> "image/"++s - Message s -> "message/"++s - Model s -> "model/"++s - Multipart s -> "multipart/"++showMultipart s - Text s -> "text/"++s - Video s -> "video/"++s - Other a b -> a ++ '/':b - --- | a (type, subtype) MIME pair. -data MIMEPair - = MIMEPair String SubType - deriving ( Eq ) - -showMIMEPair :: MIMEPair -> String -showMIMEPair (MIMEPair a b) = a ++ '/':b - --- | default subtype representation. -type SubType = String - --- | subtype for text content; currently just a string. -type TextType = SubType - -subTypeString :: Type -> String -subTypeString t = - case break (=='/') (showMIMEType (mimeType t)) of - (_,"") -> "" - (_,_:bs) -> bs - -majTypeString :: Type -> String -majTypeString t = - case break (=='/') (showMIMEType (mimeType t)) of - (as,_) -> as - -data Multipart - = Alternative - | Byteranges - | Digest - | Encrypted - | FormData - | Mixed - | Parallel - | Related - | Signed - | Extension String -- ^ e.g., 'x-foo' (i.e., includes the 'x-' bit) - | OtherMulti String -- unrecognized\/uninterpreted. - -- (e.g., appledouble, voice-message, etc.) - deriving ( Show, Ord, Eq ) - -isXmlBased :: Type -> Bool -isXmlBased t = - case mimeType t of - Multipart{} -> False - _ -> "+xml" `isSuffixOf` subTypeString t - -isXmlType :: Type -> Bool -isXmlType t = isXmlBased t || - case mimeType t of - Application s -> s `elem` xml_media_types - Text s -> s `elem` xml_media_types - _ -> False - where - -- Note: xml-dtd isn't considered an XML type here. - xml_media_types :: [String] - xml_media_types = - [ "xml" - , "xml-external-parsed-entity" - ] - - -showMultipart :: Multipart -> String -showMultipart m = - case m of - Alternative -> "alternative" - Byteranges -> "byteranges" - Digest -> "digest" - Encrypted -> "encrypted" - FormData -> "form-data" - Mixed -> "mixed" - Parallel -> "parallel" - Related -> "related" - Signed -> "signed" - Extension e -> e - OtherMulti e -> e - -type Content = String - -data MIMEValue = MIMEValue - { mime_val_type :: Type - , mime_val_disp :: Maybe Disposition - , mime_val_content :: MIMEContent - , mime_val_headers :: [(String,String)] - , mime_val_inc_type :: Bool - } deriving ( Show, Eq ) - -nullMIMEValue :: MIMEValue -nullMIMEValue = MIMEValue - { mime_val_type = nullType - , mime_val_disp = Nothing - , mime_val_content = Multi [] - , mime_val_headers = [] - , mime_val_inc_type = True - } - -data MIMEContent - = Single Content - | Multi [MIMEValue] - deriving (Eq,Show) - -data Disposition - = Disposition - { dispType :: DispType - , dispParams :: [DispParam] - } deriving ( Show, Eq ) - -data DispType - = DispInline - | DispAttachment - | DispFormData - | DispOther String - deriving ( Show, Eq) - -data DispParam - = Name String - | Filename String - | CreationDate String - | ModDate String - | ReadDate String - | Size String - | OtherParam String String - deriving ( Show, Eq) +--------------------------------------------------------------------+-- |+-- Module : Codec.MIME.Type+-- Copyright : (c) 2006-2009, Galois, Inc. +-- License : BSD3+--+-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>+-- Stability : provisional+-- Portability: portable+--+-- +-- Representing MIME types and values.+-- +--------------------------------------------------------------------+module Codec.MIME.Type where++import Data.List ( concatMap, isSuffixOf )++data Type+ = Type+ { mimeType :: MIMEType+ , mimeParams :: [(String,String)]+ } deriving ( Show, Ord, Eq )++-- | The @null@ MIME record type value; currently a @text/plain@.+nullType :: Type+nullType = Type+ { mimeType = Text "plain"+ , mimeParams = []+ }++showType :: Type -> String+showType t = showMIMEType (mimeType t) ++ showMIMEParams (mimeParams t)++showMIMEParams :: [(String,String)] -> String+showMIMEParams ps = concatMap showP ps+ where + showP (a,b) = ';':' ':a ++ '=':'"':b ++ "\""+++data MIMEType+ = Application SubType+ | Audio SubType+ | Image SubType+ | Message SubType+ | Model SubType+ | Multipart Multipart+ | Text TextType+ | Video SubType+ | Other String SubType+ deriving ( Show, Ord, Eq )++showMIMEType :: MIMEType -> String+showMIMEType t = + case t of+ Application s -> "application/"++s+ Audio s -> "audio/"++s+ Image s -> "image/"++s+ Message s -> "message/"++s+ Model s -> "model/"++s+ Multipart s -> "multipart/"++showMultipart s+ Text s -> "text/"++s+ Video s -> "video/"++s+ Other a b -> a ++ '/':b++-- | a (type, subtype) MIME pair.+data MIMEPair+ = MIMEPair String SubType+ deriving ( Eq )++showMIMEPair :: MIMEPair -> String+showMIMEPair (MIMEPair a b) = a ++ '/':b++-- | default subtype representation.+type SubType = String++-- | subtype for text content; currently just a string.+type TextType = SubType++subTypeString :: Type -> String+subTypeString t = + case break (=='/') (showMIMEType (mimeType t)) of+ (_,"") -> ""+ (_,_:bs) -> bs++majTypeString :: Type -> String+majTypeString t = + case break (=='/') (showMIMEType (mimeType t)) of+ (as,_) -> as++data Multipart+ = Alternative+ | Byteranges+ | Digest+ | Encrypted+ | FormData+ | Mixed+ | Parallel+ | Related+ | Signed+ | Extension String -- ^ e.g., 'x-foo' (i.e., includes the 'x-' bit)+ | OtherMulti String -- unrecognized\/uninterpreted.+ -- (e.g., appledouble, voice-message, etc.)+ deriving ( Show, Ord, Eq )++isXmlBased :: Type -> Bool+isXmlBased t = + case mimeType t of+ Multipart{} -> False+ _ -> "+xml" `isSuffixOf` subTypeString t++isXmlType :: Type -> Bool+isXmlType t = isXmlBased t ||+ case mimeType t of+ Application s -> s `elem` xml_media_types+ Text s -> s `elem` xml_media_types+ _ -> False+ where+ -- Note: xml-dtd isn't considered an XML type here.+ xml_media_types :: [String]+ xml_media_types = + [ "xml"+ , "xml-external-parsed-entity"+ ]+ ++showMultipart :: Multipart -> String+showMultipart m = + case m of+ Alternative -> "alternative"+ Byteranges -> "byteranges"+ Digest -> "digest"+ Encrypted -> "encrypted"+ FormData -> "form-data"+ Mixed -> "mixed"+ Parallel -> "parallel"+ Related -> "related"+ Signed -> "signed"+ Extension e -> e+ OtherMulti e -> e+ +type Content = String++data MIMEValue = MIMEValue+ { mime_val_type :: Type+ , mime_val_disp :: Maybe Disposition+ , mime_val_content :: MIMEContent+ , mime_val_headers :: [(String,String)]+ , mime_val_inc_type :: Bool+ } deriving ( Show, Eq )++nullMIMEValue :: MIMEValue+nullMIMEValue = MIMEValue+ { mime_val_type = nullType+ , mime_val_disp = Nothing+ , mime_val_content = Multi []+ , mime_val_headers = []+ , mime_val_inc_type = True+ } ++data MIMEContent + = Single Content+ | Multi [MIMEValue]+ deriving (Eq,Show)+ +data Disposition+ = Disposition+ { dispType :: DispType+ , dispParams :: [DispParam]+ } deriving ( Show, Eq )++data DispType+ = DispInline+ | DispAttachment+ | DispFormData+ | DispOther String+ deriving ( Show, Eq)++data DispParam+ = Name String+ | Filename String+ | CreationDate String+ | ModDate String+ | ReadDate String+ | Size String+ | OtherParam String String+ deriving ( Show, Eq)
Codec/MIME/Utils.hs view
@@ -1,32 +1,32 @@--------------------------------------------------------------------- --- | --- Module : Codec.MIME.Utils --- Copyright : (c) 2006-2009, Galois, Inc. --- License : BSD3 --- --- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com> --- Stability : provisional --- Portability: portable --- --- Extracting content from MIME values and types. --- --------------------------------------------------------------------- -module Codec.MIME.Utils - ( findMultipartNamed -- :: String -> MIMEValue -> Maybe MIMEValue - ) where - -import Codec.MIME.Type -import Data.List ( find ) -import Control.Monad ( msum ) - --- | Given a parameter name, locate it within a MIME value, --- returning the corresponding (sub) MIME value. -findMultipartNamed :: String -> MIMEValue -> Maybe MIMEValue -findMultipartNamed nm mv = - case mime_val_content mv of - Multi ms -> msum (map (findMultipartNamed nm) ms) - Single {} -> do cd <- mime_val_disp mv - find (withDispName nm) (dispParams cd) - return mv - where withDispName a (Name b) = a == b - withDispName _ _ = False +--------------------------------------------------------------------+-- |+-- Module : Codec.MIME.Utils+-- Copyright : (c) 2006-2009, Galois, Inc. +-- License : BSD3+--+-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>+-- Stability : provisional+-- Portability: portable+--+-- Extracting content from MIME values and types.+-- +--------------------------------------------------------------------+module Codec.MIME.Utils+ ( findMultipartNamed -- :: String -> MIMEValue -> Maybe MIMEValue+ ) where++import Codec.MIME.Type+import Data.List ( find )+import Control.Monad ( msum )++-- | Given a parameter name, locate it within a MIME value,+-- returning the corresponding (sub) MIME value.+findMultipartNamed :: String -> MIMEValue -> Maybe MIMEValue+findMultipartNamed nm mv =+ case mime_val_content mv of+ Multi ms -> msum (map (findMultipartNamed nm) ms)+ Single {} -> do cd <- mime_val_disp mv+ find (withDispName nm) (dispParams cd)+ return mv+ where withDispName a (Name b) = a == b+ withDispName _ _ = False
LICENSE view
@@ -1,27 +1,27 @@-Copyright (c) Galois, Inc. 2006-2008 - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions -are met: -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the distribution. -3. Neither the name of the author nor the names of his contributors - may be used to endorse or promote products derived from this software - without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND -ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE -IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE -ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE -FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS -OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) -HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT -LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY -OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF -SUCH DAMAGE. +Copyright (c) Galois, Inc. 2006-2008++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:+1. Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.+2. Redistributions in binary form must reproduce the above copyright+ notice, this list of conditions and the following disclaimer in the+ documentation and/or other materials provided with the distribution.+3. Neither the name of the author nor the names of his contributors+ may be used to endorse or promote products derived from this software+ without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND+ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE+IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE+ARE DISCLAIMED. IN NO EVENT SHALL THE AUTHORS OR CONTRIBUTORS BE LIABLE+FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL+DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS+OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION)+HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT+LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY+OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF+SUCH DAMAGE.
Setup.hs view
@@ -1,4 +1,4 @@-module Main where - -import Distribution.Simple -main = defaultMain +module Main where++import Distribution.Simple+main = defaultMain
mime.cabal view
@@ -1,29 +1,24 @@-name: mime -version: 0.3.2 -synopsis: Working with MIME types. -description: Working with MIME types. -category: Codec -license: BSD3 -license-file: LICENSE -author: Sigbjorn Finne, Galois, Inc. -maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com> -Copyright: (c) 2006-2009 Galois Inc. -cabal-version: >= 1.2.0 -build-type: Simple -Extra-Source-Files: CHANGES - -flag split-base - -library - if flag(split-base) - build-depends: base >= 3 && <= 4 - else - build-depends: base >= 2 && <= 4 - - exposed-modules: Codec.MIME.Type - Codec.MIME.Parse - Codec.MIME.Utils - Codec.MIME.Base64 - Codec.MIME.Decode - Codec.MIME.QuotedPrintable - ghc-options: -Wall +name: mime+version: 0.3.3+synopsis: Working with MIME types.+description: Working with MIME types.+category: Codec+license: BSD3+license-file: LICENSE+author: Sigbjorn Finne, Galois, Inc.+maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>+Copyright: (c) 2006-2009 Galois Inc.+cabal-version: >= 1.2.0+build-type: Simple+Extra-Source-Files: CHANGES++library+ build-depends: base >= 3 && < 5++ exposed-modules: Codec.MIME.Type+ Codec.MIME.Parse+ Codec.MIME.Utils+ Codec.MIME.Base64+ Codec.MIME.Decode+ Codec.MIME.QuotedPrintable+ ghc-options: -Wall