summaryrefslogtreecommitdiffstats
path: root/Codec/MIME
diff options
context:
space:
mode:
authorSigbjorn Finne <sof@galois.com>2008-09-08 22:08:39 -0700
committerSigbjorn Finne <sof@galois.com>2008-09-08 22:08:39 -0700
commit9610758f52baa3661eecdb8bd92ade9ce4ab2f59 (patch)
tree096af3c6a649ef3c9a08e09d71ac1f4c0acac89e /Codec/MIME
parent1b247fa906776273a49060ab32b03fa9cb1068f1 (diff)
robustified (wrt. casing) field lookups
Diffstat (limited to 'Codec/MIME')
-rw-r--r--Codec/MIME/Parse.hs35
1 files changed, 25 insertions, 10 deletions
diff --git a/Codec/MIME/Parse.hs b/Codec/MIME/Parse.hs
index f82824d..e37578e 100644
--- a/Codec/MIME/Parse.hs
+++ b/Codec/MIME/Parse.hs
@@ -31,7 +31,7 @@ parseMIMEBody headers_in body =
where headers = [ (map toLower k,v) | (k,v) <- headers_in ]
mty = fromMaybe defaultType
- (parseContentType =<< lookup "content-type" headers)
+ (parseContentType =<< lookupField "content-type" headers)
defaultType :: Type
defaultType = Type { mimeType = Text "plain"
, mimeParams = [("charset", "us-ascii")]
@@ -39,7 +39,7 @@ defaultType = Type { mimeType = Text "plain"
parseContentDisp :: [(String,String)] -> Maybe Disposition
parseContentDisp headers =
- (processDisp . dropFoldingWSP) =<< lookup "content-disposition" headers
+ (processDisp . dropFoldingWSP) =<< lookupField "content-disposition" headers
where
processDisp "" = Nothing
processDisp xs = Just $
@@ -72,7 +72,7 @@ parseContentDisp headers =
processBody :: [(String,String)] -> String -> String
processBody headers body =
- case lookup "content-transfer-encoding" headers of
+ case lookupField "content-transfer-encoding" headers of
Nothing -> body
Just v -> decodeBody v body
@@ -99,7 +99,7 @@ parseHeaders str =
parseMultipart :: Type -> String -> (MIMEValue, String)
parseMultipart mty body =
- case lookup "boundary" (mimeParams mty) of
+ case lookupField "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), "")
@@ -148,7 +148,7 @@ parseContentType str =
}
_ -> trace ("unable to parse content-type: " ++ show str) $ Nothing
where
- toType a b = case lookup (map toLower a) mediaTypes of
+ toType a b = case lookupField (map toLower a) mediaTypes of
Just ctor -> ctor b
_ -> Other a b
@@ -157,8 +157,8 @@ parseParams :: String -> [(String,String)]
parseParams "" = []
parseParams (';':xs) =
case break (=='=') (dropFoldingWSP xs) of
- (nm1,_:vs) ->
- let nm = map toLower nm1 in
+ (_,[]) -> []
+ (nm_raw,_:vs) ->
case vs of
'"':vs1 ->
case break (=='"') vs1 of
@@ -166,9 +166,10 @@ parseParams (';':xs) =
(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 ("curious: " ++ show cs) []
+parseParams cs = trace ("Codec.MIME.Parse.parseParams: curious param value -- " ++ show cs) []
mediaTypes :: [(String, String -> MIMEType)]
mediaTypes =
@@ -181,7 +182,7 @@ mediaTypes =
, ("text", Text)
, ("video", Video)
]
- where toMultipart b = fromMaybe other (lookup (map toLower b) multipartTypes)
+ where toMultipart b = fromMaybe other (lookupField (map toLower b) multipartTypes)
where other = case b of
'x':'-':_ -> Extension b
_ -> OtherMulti b
@@ -240,3 +241,17 @@ takeUntilCRLF str = go "" str
| 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
+