summaryrefslogtreecommitdiffstats
path: root/Codec/MIME
diff options
context:
space:
mode:
authorIavor S. Diatchki <iavor.diatchki@gmail.com>2014-02-03 18:31:23 -0800
committerIavor S. Diatchki <iavor.diatchki@gmail.com>2014-02-03 18:31:23 -0800
commita85e57deb287abdcdac8fb065ab0b20efe074d96 (patch)
tree7c8c0537f528b8d30eb29c4305b26f5ac713706c /Codec/MIME
parent5c2f21e06ebc2c3be936efadfe92872fecd82db9 (diff)
parent1823a3dd5443d98eab577988e9627fe74f3491fc (diff)
Merge pull request #4 from odr/master
Text API
Diffstat (limited to 'Codec/MIME')
-rw-r--r--Codec/MIME/Parse.hs319
-rw-r--r--Codec/MIME/Type.hs98
-rw-r--r--Codec/MIME/Utils.hs3
3 files changed, 214 insertions, 206 deletions
diff --git a/Codec/MIME/Parse.hs b/Codec/MIME/Parse.hs
index dfe2115..2843903 100644
--- a/Codec/MIME/Parse.hs
+++ b/Codec/MIME/Parse.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------
-- |
-- Module : Codec.MIME.Pare
@@ -12,14 +13,15 @@
--
--------------------------------------------------------------------
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)
+ ( parseMIMEBody -- :: [(T.Text,T.Text)] -> T.Text -> MIMEValue
+ , parseMIMEType -- :: T.Text -> Maybe Type
+ , parseMIMEMessage -- :: T.Text -> MIMEValue
+
+ , parseHeaders -- :: T.Text -> ([(T.Text,T.Text)], T.Text)
+ , parseMultipart -- :: Type -> T.Text -> (MIMEValue, T.Text)
+ , parseContentType -- :: T.Text -> Maybe Type
+ , splitMulti -- :: T.Text -> T.Text -> ([MIMEValue], T.Text)
+ , normalizeCRLF
) where
import Codec.MIME.Type
@@ -27,8 +29,10 @@ import Codec.MIME.Decode
import Data.Char
import Data.Maybe
-import Data.List
+import qualified Data.List as L
import Debug.Trace ( trace )
+import qualified Data.Text as T
+import Data.Monoid(Monoid(..), (<>))
enableTrace :: Bool
enableTrace = False
@@ -38,7 +42,7 @@ doTrace | enableTrace = trace
| otherwise = \_ x -> x
-parseMIMEBody :: [(String,String)] -> String -> MIMEValue
+parseMIMEBody :: [MIMEParam] -> T.Text -> MIMEValue
parseMIMEBody headers_in body = result { mime_val_headers = headers }
where
result = case mimeType mty of
@@ -48,84 +52,89 @@ parseMIMEBody headers_in body = result { mime_val_headers = headers }
, mime_val_disp = parseContentDisp headers
, mime_val_content = Single (processBody headers body)
}
- headers = [ (map toLower k,v) | (k,v) <- headers_in ]
+ headers = [ MIMEParam (T.toLower k) v | (MIMEParam k v) <- headers_in ]
mty = fromMaybe defaultType
- (parseContentType =<< lookupField "content-type" headers)
+ (parseContentType =<< lookupField "content-type" (paramPairs headers))
defaultType :: Type
defaultType = Type { mimeType = Text "plain"
- , mimeParams = [("charset", "us-ascii")]
+ , mimeParams = [MIMEParam "charset" "us-ascii"]
}
-parseContentDisp :: [(String,String)] -> Maybe Disposition
+parseContentDisp :: [MIMEParam] -> Maybe Disposition
parseContentDisp headers =
- (processDisp . dropFoldingWSP) =<< lookupField "content-disposition" headers
+ (processDisp . dropFoldingWSP) =<< lookupField "content-disposition" (paramPairs 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
+ processDisp t | T.null t = Nothing
+ | T.null bs = Just $ Disposition { dispType = toDispType (T.toLower as)
+ , dispParams = []
+ }
+ | otherwise = Just $ Disposition { dispType = toDispType (T.toLower as)
+ , dispParams = processParams (parseParams bs)
+ }
+ where (as,bs) = T.break (\ch -> isSpace ch || ch == ';') t
+
+ processParams = map procP
+ where
+ procP (MIMEParam 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 asl val
+ where asl = T.toLower as
+
+ toDispType t = if t == "inline" then DispInline
+ else if t == "attachment" then DispAttachment
+ else if t == "form-data" then DispFormData
+ else DispOther t
+
+paramPairs :: [MIMEParam] -> [(T.Text, T.Text)]
+paramPairs = map paramPair
+ where
+ paramPair (MIMEParam a b) = (a,b)
+
+processBody :: [MIMEParam] -> T.Text -> T.Text
processBody headers body =
- case lookupField "content-transfer-encoding" headers of
+ case lookupField "content-transfer-encoding" $ paramPairs headers of
Nothing -> body
- Just v -> decodeBody v body
-
-normalizeCRLF :: String -> String
-normalizeCRLF ('\r':'\n':xs) = '\r':'\n':normalizeCRLF xs
-normalizeCRLF ('\r':xs) = '\r':'\n':normalizeCRLF xs
-normalizeCRLF ('\n':xs) = '\r':'\n':normalizeCRLF xs
-normalizeCRLF (x:xs) = x:normalizeCRLF xs
-normalizeCRLF [] = []
+ Just v -> T.pack $ decodeBody (T.unpack v) $ T.unpack body
+
+normalizeCRLF :: T.Text -> T.Text
+normalizeCRLF t
+ | T.null t = ""
+ | "\r\n" `T.isPrefixOf` t = "\r\n" <> normalizeCRLF (T.drop 2 t)
+ | any (`T.isPrefixOf` t) ["\r", "\n"] = "\r\n" <> normalizeCRLF (T.drop 1 t)
+ | otherwise = let (a,b) = T.break (`elem` "\r\n") t in a <> normalizeCRLF b
-parseMIMEMessage :: String -> MIMEValue
+parseMIMEMessage :: T.Text -> MIMEValue
parseMIMEMessage entity =
case parseHeaders (normalizeCRLF entity) of
(as,bs) -> parseMIMEBody as bs
-parseHeaders :: String -> ([(String,String)], String)
+parseHeaders :: T.Text -> ([MIMEParam], T.Text)
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)
+ findFieldName acc t
+ | T.null t = Right ""
+ | "\r\n" `T.isPrefixOf` t = Right $ T.drop 2 t
+ | ":" `T.isPrefixOf` t = Left (T.reverse $ T.dropWhile isHSpace acc, T.drop 1 t)
+ | otherwise = findFieldName (T.take 1 t <> acc) $ T.drop 1 t
+
+ parseFieldValue nm xs
+ | T.null bs = ([MIMEParam nm as], "")
+ | otherwise = let (zs,ys) = parseHeaders bs in (MIMEParam nm as :zs, ys)
+ where
+ (as,bs) = takeUntilCRLF xs
+
+parseMultipart :: Type -> T.Text -> (MIMEValue, T.Text)
parseMultipart mty body =
- case lookupField "boundary" (mimeParams mty) of
- Nothing -> doTrace ("Multipart mime type, " ++ showType mty ++
+ case lookupField "boundary" (paramPairs $ mimeParams mty) of
+ Nothing -> doTrace ("Multipart mime type, " ++ T.unpack (showType mty) ++
", has no required boundary parameter. Defaulting to text/plain") $
(nullMIMEValue{ mime_val_type = defaultType
, mime_val_disp = Nothing
@@ -137,71 +146,71 @@ parseMultipart mty body =
}, rs)
where (vals,rs) = splitMulti bnd body
-splitMulti :: String -> String -> ([MIMEValue], String)
+splitMulti :: T.Text -> T.Text -> ([MIMEValue], T.Text)
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
+ let body | "--" `T.isPrefixOf` body_in = "\r\n" <> body_in
+ | otherwise = body_in
in case untilMatch dashBoundary body of
- Nothing -> ([],"")
- Just ('-':'-':xs) -> ([],xs)
- Just xs -> splitMulti1 (dropTrailer xs)
+ Nothing -> mempty
+ Just xs | "--" `T.isPrefixOf` xs -> ([], T.drop 2 xs)
+ | otherwise -> 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
+ dashBoundary = ("\r\n--" <> bnd)
+
+ splitMulti1 xs
+ | T.null as && T.null bs = ([], "")
+ | T.null bs = ([parseMIMEMessage as],"")
+ | T.isPrefixOf "--" bs = ([parseMIMEMessage as], dropTrailer bs)
+ | otherwise = let (zs,ys) = splitMulti1 (dropTrailer bs)
+ in ((parseMIMEMessage as) : zs,ys)
+
+ where
+ (as,bs) = matchUntil dashBoundary xs
+
+ dropTrailer xs
+ | "\r\n" `T.isPrefixOf` xs1 = T.drop 2 xs1
+ | otherwise = xs1 -- hmm, flag an error?
+ where
+ xs1 = T.dropWhile isHSpace xs
+
+parseMIMEType :: T.Text -> 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)
- }
- _ -> doTrace ("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 = doTrace ("Codec.MIME.Parse.parseParams: curious param value -- " ++ show cs) []
-
-mediaTypes :: [(String, String -> MIMEType)]
+parseContentType :: T.Text -> Maybe Type
+parseContentType str
+ | T.null minor0 = doTrace ("unable to parse content-type: " ++ show str) $ Nothing
+ | otherwise = Just Type { mimeType = toType maj as
+ , mimeParams = parseParams (T.dropWhile isHSpace bs)
+ }
+ where
+ (maj, minor0) = T.break (=='/') (dropFoldingWSP str)
+ minor = T.drop 1 minor0
+ (as, bs) = T.break (\ ch -> isHSpace ch || isTSpecial ch) minor
+ toType a b = case lookupField (T.toLower a) mediaTypes of
+ Just ctor -> ctor b
+ _ -> Other a b
+
+parseParams :: T.Text -> [MIMEParam]
+parseParams t | T.null t = []
+ | ';' == T.head t = let (nm_raw, vs0) = T.break (=='=') (dropFoldingWSP $ T.tail t)
+ nm = T.toLower nm_raw in
+ if T.null vs0
+ then []
+ else let vs = T.tail vs0 in
+ if not (T.null vs) && T.head vs == '"'
+ then let vs1 = T.tail vs
+ (val, zs0) = T.break (=='"') vs1 in
+ if T.null zs0
+ then [MIMEParam nm val]
+ else MIMEParam nm val : parseParams (T.dropWhile isHSpace $ T.tail zs0)
+ else let (val, zs) = T.break (\ch -> isHSpace ch || isTSpecial ch) vs in
+ MIMEParam nm val : parseParams (T.dropWhile isHSpace zs)
+ | otherwise = doTrace ("Codec.MIME.Parse.parseParams: curious param value -- " ++ show t) []
+
+mediaTypes :: [(T.Text, T.Text -> MIMEType)]
mediaTypes =
[ ("multipart", (Multipart . toMultipart))
, ("application", Application)
@@ -212,12 +221,11 @@ mediaTypes =
, ("text", Text)
, ("video", Video)
]
- where toMultipart b = fromMaybe other (lookupField (map toLower b) multipartTypes)
- where other = case b of
- 'x':'-':_ -> Extension b
- _ -> OtherMulti b
+ where toMultipart b = fromMaybe other (lookupField (T.toLower b) multipartTypes)
+ where other | T.isPrefixOf "x-" b = Extension b
+ | otherwise = OtherMulti b
-multipartTypes :: [(String, Multipart)]
+multipartTypes :: [(T.Text, Multipart)]
multipartTypes =
[ ("alternative", Alternative)
, ("byteranges", Byteranges)
@@ -230,18 +238,19 @@ multipartTypes =
, ("signed", Signed)
]
-untilMatch :: String -> String -> Maybe String
-untilMatch "" a = Just a
-untilMatch _ "" = Nothing
-untilMatch a b | a `isPrefixOf` b = Just $ drop (length a) b
-untilMatch a (_:bs) = untilMatch a bs
+untilMatch :: T.Text -> T.Text -> Maybe T.Text
+untilMatch a b | T.null a = Just b
+ | T.null b = Nothing
+ | a `T.isPrefixOf` b = Just $ T.drop (T.length a) b
+ | otherwise = untilMatch a $ T.tail b
-matchUntil :: String -> String -> (String, String)
+matchUntil :: T.Text -> T.Text -> (T.Text, T.Text)
matchUntil _ "" = ("", "")
matchUntil str xs
+ | T.null xs = mempty
-- 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)
+ | str `T.isPrefixOf` xs = ("", T.drop (T.length str) xs)
+ | otherwise = let (as,bs) = matchUntil str $ T.tail xs in (T.take 1 xs <> as, bs)
isHSpace :: Char -> Bool
isHSpace c = c == ' ' || c == '\t'
@@ -249,25 +258,25 @@ 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
+dropFoldingWSP :: T.Text -> T.Text
+dropFoldingWSP t | T.null t = ""
+ | isHSpace (T.head t) = dropFoldingWSP $ T.tail t
+ | "\r\n" `T.isPrefixOf` t && not (T.null $ T.drop 2 t) && isHSpace (T.head $ T.drop 2 t)
+ = dropFoldingWSP $ T.drop 3 t
+ | otherwise = t
-takeUntilCRLF :: String -> (String, String)
+takeUntilCRLF :: T.Text -> (T.Text, T.Text)
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
+ go acc t | T.null t = (T.reverse (T.dropWhile isHSpace acc), "")
+ | "\r\n" `T.isPrefixOf` t && not (T.null $ T.drop 2 t) && isHSpace (T.head $ T.drop 2 t)
+ = go (" " <> acc) (T.drop 3 t)
+ | "\r\n" `T.isPrefixOf` t && not (T.null $ T.drop 2 t)
+ = (T.reverse (T.dropWhile isHSpace acc), T.drop 2 t)
+ | otherwise = go (T.take 1 t <> acc) $ T.tail t
-- case in-sensitive lookup of field names or attributes\/parameters.
-lookupField :: String -> [(String,a)] -> Maybe a
+lookupField :: T.Text -> [(T.Text,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
@@ -275,8 +284,6 @@ lookupField n ns =
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
+ let nl = T.toLower n in
+ fmap snd $ L.find ((nl==) . T.toLower . fst) ns
diff --git a/Codec/MIME/Type.hs b/Codec/MIME/Type.hs
index 675d29e..2ae9abd 100644
--- a/Codec/MIME/Type.hs
+++ b/Codec/MIME/Type.hs
@@ -1,3 +1,4 @@
+{-# LANGUAGE OverloadedStrings #-}
--------------------------------------------------------------------
-- |
-- Module : Codec.MIME.Type
@@ -14,12 +15,16 @@
--------------------------------------------------------------------
module Codec.MIME.Type where
-import Data.List ( isSuffixOf )
+import qualified Data.Text as T
+import Data.Monoid ((<>))
-data Type
- = Type
+data MIMEParam = MIMEParam { paramName :: T.Text
+ , paramValue :: T.Text }
+ deriving (Show, Ord, Eq)
+
+data Type = Type
{ mimeType :: MIMEType
- , mimeParams :: [(String,String)]
+ , mimeParams :: [MIMEParam]
} deriving ( Show, Ord, Eq )
-- | The @null@ MIME record type value; currently a @text/plain@.
@@ -29,13 +34,13 @@ nullType = Type
, mimeParams = []
}
-showType :: Type -> String
-showType t = showMIMEType (mimeType t) ++ showMIMEParams (mimeParams t)
+showType :: Type -> T.Text
+showType t = showMIMEType (mimeType t) <> showMIMEParams (mimeParams t)
-showMIMEParams :: [(String,String)] -> String
-showMIMEParams ps = concatMap showP ps
- where
- showP (a,b) = ';':' ':a ++ '=':'"':b ++ "\""
+showMIMEParams :: [MIMEParam] -> T.Text
+showMIMEParams ps = T.concat $ map showP ps
+ where
+ showP (MIMEParam a b) = "; " <> a <> "=\"" <> b <> "\""
data MIMEType
@@ -47,46 +52,41 @@ data MIMEType
| Multipart Multipart
| Text TextType
| Video SubType
- | Other String SubType
+ | Other {otherType :: T.Text, otherSubType :: SubType}
deriving ( Show, Ord, Eq )
-showMIMEType :: MIMEType -> String
+showMIMEType :: MIMEType -> T.Text
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
+ 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
+ = MIMEPair T.Text SubType
deriving ( Eq )
-showMIMEPair :: MIMEPair -> String
-showMIMEPair (MIMEPair a b) = a ++ '/':b
+showMIMEPair :: MIMEPair -> T.Text
+showMIMEPair (MIMEPair a b) = a <> "/" <> b
-- | default subtype representation.
-type SubType = String
+type SubType = T.Text
-- | subtype for text content; currently just a string.
type TextType = SubType
-subTypeString :: Type -> String
-subTypeString t =
- case break (=='/') (showMIMEType (mimeType t)) of
- (_,"") -> ""
- (_,_:bs) -> bs
+subTypeString :: Type -> T.Text
+subTypeString t = T.drop 1 $ snd $ T.break (=='/') (showMIMEType (mimeType t))
-majTypeString :: Type -> String
-majTypeString t =
- case break (=='/') (showMIMEType (mimeType t)) of
- (as,_) -> as
+majTypeString :: Type -> T.Text
+majTypeString t = fst $ T.break (=='/') (showMIMEType (mimeType t))
data Multipart
= Alternative
@@ -98,8 +98,8 @@ data Multipart
| Parallel
| Related
| Signed
- | Extension String -- ^ e.g., 'x-foo' (i.e., includes the 'x-' bit)
- | OtherMulti String -- unrecognized\/uninterpreted.
+ | Extension T.Text -- ^ e.g., 'x-foo' (i.e., includes the 'x-' bit)
+ | OtherMulti T.Text -- unrecognized\/uninterpreted.
-- (e.g., appledouble, voice-message, etc.)
deriving ( Show, Ord, Eq )
@@ -107,7 +107,7 @@ isXmlBased :: Type -> Bool
isXmlBased t =
case mimeType t of
Multipart{} -> False
- _ -> "+xml" `isSuffixOf` subTypeString t
+ _ -> "+xml" `T.isSuffixOf` subTypeString t
isXmlType :: Type -> Bool
isXmlType t = isXmlBased t ||
@@ -117,14 +117,14 @@ isXmlType t = isXmlBased t ||
_ -> False
where
-- Note: xml-dtd isn't considered an XML type here.
- xml_media_types :: [String]
+ xml_media_types :: [T.Text]
xml_media_types =
[ "xml"
, "xml-external-parsed-entity"
]
-showMultipart :: Multipart -> String
+showMultipart :: Multipart -> T.Text
showMultipart m =
case m of
Alternative -> "alternative"
@@ -139,13 +139,13 @@ showMultipart m =
Extension e -> e
OtherMulti e -> e
-type Content = String
+type Content = T.Text
data MIMEValue = MIMEValue
{ mime_val_type :: Type
, mime_val_disp :: Maybe Disposition
, mime_val_content :: MIMEContent
- , mime_val_headers :: [(String,String)]
+ , mime_val_headers :: [MIMEParam]
, mime_val_inc_type :: Bool
} deriving ( Show, Eq )
@@ -173,15 +173,15 @@ data DispType
= DispInline
| DispAttachment
| DispFormData
- | DispOther String
+ | DispOther T.Text
deriving ( Show, Eq)
data DispParam
- = Name String
- | Filename String
- | CreationDate String
- | ModDate String
- | ReadDate String
- | Size String
- | OtherParam String String
+ = Name T.Text
+ | Filename T.Text
+ | CreationDate T.Text
+ | ModDate T.Text
+ | ReadDate T.Text
+ | Size T.Text
+ | OtherParam T.Text T.Text
deriving ( Show, Eq)
diff --git a/Codec/MIME/Utils.hs b/Codec/MIME/Utils.hs
index 8606342..dd54860 100644
--- a/Codec/MIME/Utils.hs
+++ b/Codec/MIME/Utils.hs
@@ -18,10 +18,11 @@ module Codec.MIME.Utils
import Codec.MIME.Type
import Data.List ( find )
import Control.Monad ( msum )
+import Data.Text(Text)
-- | Given a parameter name, locate it within a MIME value,
-- returning the corresponding (sub) MIME value.
-findMultipartNamed :: String -> MIMEValue -> Maybe MIMEValue
+findMultipartNamed :: Text -> MIMEValue -> Maybe MIMEValue
findMultipartNamed nm mv =
case mime_val_content mv of
Multi ms -> msum (map (findMultipartNamed nm) ms)