From 8e92e6e11d2b3b0bfb5ac9d68f347219493e6380 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kier=C3=A1n=20Meinhardt?= Date: Wed, 23 Sep 2020 17:44:40 +0200 Subject: split into library + executables --- Codec/MIME/Base64.hs | 147 --------------------- Codec/MIME/Decode.hs | 76 ----------- Codec/MIME/Parse.hs | 295 ------------------------------------------ Codec/MIME/QuotedPrintable.hs | 66 ---------- Codec/MIME/Type.hs | 189 --------------------------- Codec/MIME/Utils.hs | 33 ----- 6 files changed, 806 deletions(-) delete mode 100644 Codec/MIME/Base64.hs delete mode 100644 Codec/MIME/Decode.hs delete mode 100644 Codec/MIME/Parse.hs delete mode 100644 Codec/MIME/QuotedPrintable.hs delete mode 100644 Codec/MIME/Type.hs delete mode 100644 Codec/MIME/Utils.hs (limited to 'Codec') diff --git a/Codec/MIME/Base64.hs b/Codec/MIME/Base64.hs deleted file mode 100644 index f60419b..0000000 --- a/Codec/MIME/Base64.hs +++ /dev/null @@ -1,147 +0,0 @@ --------------------------------------------------------------------- --- | --- 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 - diff --git a/Codec/MIME/Decode.hs b/Codec/MIME/Decode.hs deleted file mode 100644 index 278d6f6..0000000 --- a/Codec/MIME/Decode.hs +++ /dev/null @@ -1,76 +0,0 @@ --------------------------------------------------------------------- --- | --- 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 - - diff --git a/Codec/MIME/Parse.hs b/Codec/MIME/Parse.hs deleted file mode 100644 index c5392fe..0000000 --- a/Codec/MIME/Parse.hs +++ /dev/null @@ -1,295 +0,0 @@ -{-# 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.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -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 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) - } - 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 as - , dispParams = [] - } - | 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 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] -> [(CI 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" :: String)) 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 (CI.mk 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 (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 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 = CI.mk 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 :: [(CI 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 (CI.mk b) multipartTypes) - where other | T.isPrefixOf "x-" b = Extension b - | otherwise = OtherMulti b - -multipartTypes :: [(CI 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 :: 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 - -- to a second try where we do normalize before giving up. - case lookup n ns of - x@Just{} -> x - Nothing -> - fmap snd $ L.find ((n==) . fst) ns - diff --git a/Codec/MIME/QuotedPrintable.hs b/Codec/MIME/QuotedPrintable.hs deleted file mode 100644 index cdc2266..0000000 --- a/Codec/MIME/QuotedPrintable.hs +++ /dev/null @@ -1,66 +0,0 @@ --------------------------------------------------------------------- --- | --- 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' diff --git a/Codec/MIME/Type.hs b/Codec/MIME/Type.hs deleted file mode 100644 index 72ec94f..0000000 --- a/Codec/MIME/Type.hs +++ /dev/null @@ -1,189 +0,0 @@ -{-# 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 Data.CaseInsensitive (CI) -import qualified Data.CaseInsensitive as CI -import qualified Data.Text as T -import Data.Monoid ((<>)) - -data MIMEParam = MIMEParam { paramName :: CI 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 k v) = "; " <> CI.original k <> "=\"" <> v <> "\"" - - -data MIMEType - = Application SubType - | Audio SubType - | Image SubType - | Message SubType - | Model SubType - | Multipart Multipart - | Text TextType - | Video SubType - | Other {otherType :: CI 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 -> CI.original 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 (CI T.Text) T.Text - deriving ( Show, Eq) diff --git a/Codec/MIME/Utils.hs b/Codec/MIME/Utils.hs deleted file mode 100644 index dd54860..0000000 --- a/Codec/MIME/Utils.hs +++ /dev/null @@ -1,33 +0,0 @@ --------------------------------------------------------------------- --- | --- 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 -- cgit v1.2.3