diff options
Diffstat (limited to 'Codec/MIME')
| -rw-r--r-- | Codec/MIME/Parse.hs | 47 | ||||
| -rw-r--r-- | Codec/MIME/Type.hs | 12 |
2 files changed, 30 insertions, 29 deletions
diff --git a/Codec/MIME/Parse.hs b/Codec/MIME/Parse.hs index f9dfeb2..803e4b2 100644 --- a/Codec/MIME/Parse.hs +++ b/Codec/MIME/Parse.hs @@ -28,6 +28,8 @@ import Codec.MIME.Type import Codec.MIME.Decode import Control.Arrow(second) +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI import Data.Char import Data.Maybe import qualified Data.List as L @@ -44,7 +46,7 @@ doTrace | enableTrace = trace parseMIMEBody :: [MIMEParam] -> T.Text -> MIMEValue -parseMIMEBody headers_in body = result { mime_val_headers = headers } +parseMIMEBody headers body = result { mime_val_headers = headers } where result = case mimeType mty of Multipart{} -> fst (parseMultipart mty body) @@ -53,7 +55,6 @@ parseMIMEBody headers_in body = result { mime_val_headers = headers } , mime_val_disp = parseContentDisp headers , mime_val_content = Single (processBody headers body) } - headers = [ MIMEParam (T.toLower k) v | (MIMEParam k v) <- headers_in ] mty = fromMaybe defaultType (parseContentType =<< lookupField "content-type" (paramPairs headers)) defaultType :: Type @@ -66,32 +67,31 @@ parseContentDisp headers = (processDisp . dropFoldingWSP) =<< lookupField "content-disposition" (paramPairs headers) where processDisp t | T.null t = Nothing - | T.null bs = Just $ Disposition { dispType = toDispType (T.toLower as) + | T.null bs = Just $ Disposition { dispType = toDispType as , dispParams = [] } - | otherwise = Just $ Disposition { dispType = toDispType (T.toLower as) + | otherwise = Just $ Disposition { dispType = toDispType 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 + procP (MIMEParam k val) + | "name" == k = Name val + | "filename" == k = Filename val + | "creation-date" == k = CreationDate val + | "modification-date" == k = ModDate val + | "read-date" == k = ReadDate val + | "size" == k = Size val + | otherwise = OtherParam k val 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 :: [MIMEParam] -> [(CI T.Text, T.Text)] paramPairs = map paramPair where paramPair (MIMEParam a b) = (a,b) @@ -117,7 +117,7 @@ parseMIMEMessage entity = parseHeaders :: T.Text -> ([MIMEParam], T.Text) parseHeaders str = case findFieldName "" str of - Left (nm, rs) -> parseFieldValue nm (dropFoldingWSP rs) + Left (nm, rs) -> parseFieldValue (CI.mk nm) (dropFoldingWSP rs) Right body -> ([],body) where findFieldName acc t @@ -183,21 +183,21 @@ parseMIMEType = parseContentType 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 + | otherwise = Just Type { mimeType = toType (CI.mk 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 + toType a b = case lookupField 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 + nm = CI.mk nm_raw in if T.null vs0 then [] else let vs = T.tail vs0 in @@ -211,7 +211,7 @@ parseParams t | T.null t = [] 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 :: [(CI T.Text, T.Text -> MIMEType)] mediaTypes = [ ("multipart", (Multipart . toMultipart)) , ("application", Application) @@ -222,11 +222,11 @@ mediaTypes = , ("text", Text) , ("video", Video) ] - where toMultipart b = fromMaybe other (lookupField (T.toLower b) multipartTypes) + where toMultipart b = fromMaybe other (lookupField (CI.mk b) multipartTypes) where other | T.isPrefixOf "x-" b = Extension b | otherwise = OtherMulti b -multipartTypes :: [(T.Text, Multipart)] +multipartTypes :: [(CI T.Text, Multipart)] multipartTypes = [ ("alternative", Alternative) , ("byteranges", Byteranges) @@ -283,7 +283,7 @@ takeUntilCRLF str = go "" str | otherwise = go (T.take 1 t <> acc) $ T.tail t -- case in-sensitive lookup of field names or attributes\/parameters. -lookupField :: T.Text -> [(T.Text,a)] -> Maybe a +lookupField :: CI T.Text -> [(CI 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 @@ -291,6 +291,5 @@ lookupField n ns = case lookup n ns of x@Just{} -> x Nothing -> - let nl = T.toLower n in - fmap snd $ L.find ((nl==) . T.toLower . fst) ns + fmap snd $ L.find ((n==) . fst) ns diff --git a/Codec/MIME/Type.hs b/Codec/MIME/Type.hs index 2ae9abd..72ec94f 100644 --- a/Codec/MIME/Type.hs +++ b/Codec/MIME/Type.hs @@ -15,10 +15,12 @@ -------------------------------------------------------------------- module Codec.MIME.Type where +import Data.CaseInsensitive (CI) +import qualified Data.CaseInsensitive as CI import qualified Data.Text as T import Data.Monoid ((<>)) -data MIMEParam = MIMEParam { paramName :: T.Text +data MIMEParam = MIMEParam { paramName :: CI T.Text , paramValue :: T.Text } deriving (Show, Ord, Eq) @@ -40,7 +42,7 @@ showType t = showMIMEType (mimeType t) <> showMIMEParams (mimeParams t) showMIMEParams :: [MIMEParam] -> T.Text showMIMEParams ps = T.concat $ map showP ps where - showP (MIMEParam a b) = "; " <> a <> "=\"" <> b <> "\"" + showP (MIMEParam k v) = "; " <> CI.original k <> "=\"" <> v <> "\"" data MIMEType @@ -52,7 +54,7 @@ data MIMEType | Multipart Multipart | Text TextType | Video SubType - | Other {otherType :: T.Text, otherSubType :: SubType} + | Other {otherType :: CI T.Text, otherSubType :: SubType} deriving ( Show, Ord, Eq ) showMIMEType :: MIMEType -> T.Text @@ -66,7 +68,7 @@ showMIMEType t = Multipart s -> "multipart/"<>showMultipart s Text s -> "text/"<>s Video s -> "video/"<>s - Other a b -> a <> "/" <> b + Other a b -> CI.original a <> "/" <> b -- | a (type, subtype) MIME pair. data MIMEPair @@ -183,5 +185,5 @@ data DispParam | ModDate T.Text | ReadDate T.Text | Size T.Text - | OtherParam T.Text T.Text + | OtherParam (CI T.Text) T.Text deriving ( Show, Eq) |