summaryrefslogtreecommitdiffstats
path: root/Codec/MIME
diff options
context:
space:
mode:
Diffstat (limited to 'Codec/MIME')
-rw-r--r--Codec/MIME/Base64.hs147
-rw-r--r--Codec/MIME/Decode.hs76
-rw-r--r--Codec/MIME/Parse.hs296
-rw-r--r--Codec/MIME/QuotedPrintable.hs66
-rw-r--r--Codec/MIME/Type.hs187
-rw-r--r--Codec/MIME/Utils.hs33
6 files changed, 805 insertions, 0 deletions
diff --git a/Codec/MIME/Base64.hs b/Codec/MIME/Base64.hs
new file mode 100644
index 0000000..f60419b
--- /dev/null
+++ b/Codec/MIME/Base64.hs
@@ -0,0 +1,147 @@
+--------------------------------------------------------------------
+-- |
+-- Module : Codec.MIME.Base64
+-- Copyright : (c) 2006-2009, Galois, Inc.
+-- License : BSD3
+--
+-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>
+-- 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
new file mode 100644
index 0000000..278d6f6
--- /dev/null
+++ b/Codec/MIME/Decode.hs
@@ -0,0 +1,76 @@
+--------------------------------------------------------------------
+-- |
+-- Module : Codec.MIME.Decode
+-- Copyright : (c) 2006-2009, Galois, Inc.
+-- License : BSD3
+--
+-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>
+-- 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
new file mode 100644
index 0000000..f9dfeb2
--- /dev/null
+++ b/Codec/MIME/Parse.hs
@@ -0,0 +1,296 @@
+{-# LANGUAGE OverloadedStrings #-}
+--------------------------------------------------------------------
+-- |
+-- Module : Codec.MIME.Pare
+-- Copyright : (c) 2006-2009, Galois, Inc.
+-- License : BSD3
+--
+-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>
+-- 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` "()<>@,;:\\\"/[]?=" -- "
+
+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
+
diff --git a/Codec/MIME/QuotedPrintable.hs b/Codec/MIME/QuotedPrintable.hs
new file mode 100644
index 0000000..cdc2266
--- /dev/null
+++ b/Codec/MIME/QuotedPrintable.hs
@@ -0,0 +1,66 @@
+--------------------------------------------------------------------
+-- |
+-- Module : Codec.MIME.QuotedPrintable
+-- Copyright : (c) 2006-2009, Galois, Inc.
+-- License : BSD3
+--
+-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>
+-- 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
new file mode 100644
index 0000000..2ae9abd
--- /dev/null
+++ b/Codec/MIME/Type.hs
@@ -0,0 +1,187 @@
+{-# LANGUAGE OverloadedStrings #-}
+--------------------------------------------------------------------
+-- |
+-- Module : Codec.MIME.Type
+-- Copyright : (c) 2006-2009, Galois, Inc.
+-- License : BSD3
+--
+-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>
+-- 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)
diff --git a/Codec/MIME/Utils.hs b/Codec/MIME/Utils.hs
new file mode 100644
index 0000000..dd54860
--- /dev/null
+++ b/Codec/MIME/Utils.hs
@@ -0,0 +1,33 @@
+--------------------------------------------------------------------
+-- |
+-- Module : Codec.MIME.Utils
+-- Copyright : (c) 2006-2009, Galois, Inc.
+-- License : BSD3
+--
+-- Maintainer: Sigbjorn Finne <sigbjorn.finne@gmail.com>
+-- 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
generated by cgit v1.2.3 (git 2.25.1) at 2024-11-22 00:44:29 +0000