mime-0.4.0.2/0000755000000000000000000000000012513502410010761 5ustar0000000000000000mime-0.4.0.2/mime.cabal0000644000000000000000000000165012513502410012676 0ustar0000000000000000name: mime version: 0.4.0.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 Copyright: (c) 2006-2009 Galois Inc. cabal-version: >= 1.6 build-type: Simple homepage: https://github.com/GaloisInc/mime Extra-Source-Files: CHANGES library build-depends: base >= 4 && < 5 , text >= 0.9 exposed-modules: Codec.MIME.Type Codec.MIME.Parse Codec.MIME.Utils Codec.MIME.Base64 Codec.MIME.Decode Codec.MIME.QuotedPrintable ghc-options: -Wall source-repository head type: git location: git://github.com/GaloisInc/mime.git mime-0.4.0.2/LICENSE0000644000000000000000000000266112513502410011773 0ustar0000000000000000Copyright (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. mime-0.4.0.2/CHANGES0000644000000000000000000000025412513502410011755 0ustar0000000000000000Version 0.3.2: released 2009-12-21 * sub-point release. * extend exports of Codec.MIME.Parse to include misc local utility functions: parseMIMEMessage, parseContentType mime-0.4.0.2/Setup.hs0000644000000000000000000000010112513502410012405 0ustar0000000000000000module Main where import Distribution.Simple main = defaultMain mime-0.4.0.2/Codec/0000755000000000000000000000000012513502410011776 5ustar0000000000000000mime-0.4.0.2/Codec/MIME/0000755000000000000000000000000012513502410012525 5ustar0000000000000000mime-0.4.0.2/Codec/MIME/Decode.hs0000644000000000000000000000423712513502410014252 0ustar0000000000000000-------------------------------------------------------------------- -- | -- Module : Codec.MIME.Decode -- Copyright : (c) 2006-2009, Galois, Inc. -- License : BSD3 -- -- Maintainer: Sigbjorn Finne -- 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" -> Base64.decodeToString 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 mime-0.4.0.2/Codec/MIME/Type.hs0000644000000000000000000001102012513502410013774 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------- -- | -- Module : Codec.MIME.Type -- Copyright : (c) 2006-2009, Galois, Inc. -- License : BSD3 -- -- Maintainer: Sigbjorn Finne -- Stability : provisional -- Portability: portable -- -- -- Representing MIME types and values. -- -------------------------------------------------------------------- module Codec.MIME.Type where import qualified Data.Text as T import Data.Monoid ((<>)) data MIMEParam = MIMEParam { paramName :: T.Text , paramValue :: T.Text } deriving (Show, Ord, Eq) data Type = Type { mimeType :: MIMEType , mimeParams :: [MIMEParam] } deriving ( Show, Ord, Eq ) -- | The @null@ MIME record type value; currently a @text/plain@. nullType :: Type nullType = Type { mimeType = Text "plain" , mimeParams = [] } showType :: Type -> T.Text 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 <> "\"" data MIMEType = Application SubType | Audio SubType | Image SubType | Message SubType | Model SubType | Multipart Multipart | Text TextType | Video SubType | Other {otherType :: T.Text, otherSubType :: SubType} deriving ( Show, Ord, Eq ) 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 -- | a (type, subtype) MIME pair. data MIMEPair = MIMEPair T.Text SubType deriving ( Eq ) showMIMEPair :: MIMEPair -> T.Text showMIMEPair (MIMEPair a b) = a <> "/" <> b -- | default subtype representation. type SubType = T.Text -- | subtype for text content; currently just a string. type TextType = SubType subTypeString :: Type -> T.Text subTypeString t = T.drop 1 $ snd $ T.break (=='/') (showMIMEType (mimeType t)) majTypeString :: Type -> T.Text majTypeString t = fst $ T.break (=='/') (showMIMEType (mimeType t)) data Multipart = Alternative | Byteranges | Digest | Encrypted | FormData | Mixed | Parallel | Related | Signed | 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 ) isXmlBased :: Type -> Bool isXmlBased t = case mimeType t of Multipart{} -> False _ -> "+xml" `T.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 :: [T.Text] xml_media_types = [ "xml" , "xml-external-parsed-entity" ] showMultipart :: Multipart -> T.Text 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 = T.Text data MIMEValue = MIMEValue { mime_val_type :: Type , mime_val_disp :: Maybe Disposition , mime_val_content :: MIMEContent , mime_val_headers :: [MIMEParam] , 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 T.Text deriving ( Show, Eq) data DispParam = 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) mime-0.4.0.2/Codec/MIME/Base64.hs0000644000000000000000000001117712513502410014114 0ustar0000000000000000-------------------------------------------------------------------- -- | -- Module : Codec.MIME.Base64 -- Copyright : (c) 2006-2009, Galois, Inc. -- License : BSD3 -- -- Maintainer: Sigbjorn Finne -- 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 mime-0.4.0.2/Codec/MIME/QuotedPrintable.hs0000644000000000000000000000451712513502410016172 0ustar0000000000000000-------------------------------------------------------------------- -- | -- Module : Codec.MIME.QuotedPrintable -- Copyright : (c) 2006-2009, Galois, Inc. -- License : BSD3 -- -- Maintainer: Sigbjorn Finne -- 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' mime-0.4.0.2/Codec/MIME/Utils.hs0000644000000000000000000000211312513502410014156 0ustar0000000000000000-------------------------------------------------------------------- -- | -- Module : Codec.MIME.Utils -- Copyright : (c) 2006-2009, Galois, Inc. -- License : BSD3 -- -- Maintainer: Sigbjorn Finne -- 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 ) import Data.Text(Text) -- | Given a parameter name, locate it within a MIME value, -- returning the corresponding (sub) MIME value. findMultipartNamed :: Text -> 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 mime-0.4.0.2/Codec/MIME/Parse.hs0000644000000000000000000002657312513502410014150 0ustar0000000000000000{-# LANGUAGE OverloadedStrings #-} -------------------------------------------------------------------- -- | -- Module : Codec.MIME.Pare -- Copyright : (c) 2006-2009, Galois, Inc. -- License : BSD3 -- -- Maintainer: Sigbjorn Finne -- Stability : provisional -- Portability: portable -- -- Parsing MIME content. -- -------------------------------------------------------------------- module Codec.MIME.Parse ( 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 import Codec.MIME.Decode import Control.Arrow(second) import Data.Char import Data.Maybe import qualified Data.List as L import Debug.Trace ( trace ) import qualified Data.Text as T import Data.Monoid(Monoid(..), (<>)) enableTrace :: Bool enableTrace = False doTrace :: String -> b -> b doTrace | enableTrace = trace | otherwise = \_ x -> x parseMIMEBody :: [MIMEParam] -> T.Text -> MIMEValue parseMIMEBody headers_in body = result { mime_val_headers = headers } where result = 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) } headers = [ MIMEParam (T.toLower k) v | (MIMEParam k v) <- headers_in ] mty = fromMaybe defaultType (parseContentType =<< lookupField "content-type" (paramPairs headers)) defaultType :: Type defaultType = Type { mimeType = Text "plain" , mimeParams = [MIMEParam "charset" "us-ascii"] } parseContentDisp :: [MIMEParam] -> Maybe Disposition 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) , 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" $ paramPairs headers of Nothing -> body 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 :: T.Text -> MIMEValue parseMIMEMessage entity = case parseHeaders (normalizeCRLF entity) of (as,bs) -> parseMIMEBody as bs 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 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" (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 , 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 :: 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 | "--" `T.isPrefixOf` body_in = "\r\n" <> body_in | otherwise = body_in in case untilMatch dashBoundary body of Nothing -> mempty Just xs | "--" `T.isPrefixOf` xs -> ([], T.drop 2 xs) | otherwise -> splitMulti1 (dropTrailer xs) where 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 :: 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) , ("audio", Audio) , ("image", Image) , ("message", Message) , ("model", Model) , ("text", Text) , ("video", Video) ] where toMultipart b = fromMaybe other (lookupField (T.toLower b) multipartTypes) where other | T.isPrefixOf "x-" b = Extension b | otherwise = OtherMulti b multipartTypes :: [(T.Text, Multipart)] multipartTypes = [ ("alternative", Alternative) , ("byteranges", Byteranges) , ("digest", Digest) , ("encrypted", Encrypted) , ("form-data", FormData) , ("mixed", Mixed) , ("parallel", Parallel) , ("related", Related) , ("signed", Signed) ] 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 :: T.Text -> T.Text -> (T.Text, T.Text) -- searching str; returning parts before str and after str matchUntil str = second (T.drop $ T.length str) . T.breakOn str {- 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 `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' isTSpecial :: Char -> Bool isTSpecial x = x `elem` ("()<>@,;:\\\"/[]?="::String) -- " 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 :: T.Text -> (T.Text, T.Text) takeUntilCRLF str = go "" str where 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 :: 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 -- to a second try where we do normalize before giving up. case lookup n ns of x@Just{} -> x Nothing -> let nl = T.toLower n in fmap snd $ L.find ((nl==) . T.toLower . fst) ns