split into library + executables

27 files changed, 3512 insertions, 0 deletions

diff --git a/src/Codec/MIME/Base64.hs b/src/Codec/MIME/Base64.hs
new file mode 100644
index 0000000..4372a7f
--- /dev/null
+++ b/src/Codec/MIME/Base64.hs
@@ -0,0 +1,146 @@
+--------------------------------------------------------------------
+-- |
+-- 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/src/Codec/MIME/Decode.hs b/src/Codec/MIME/Decode.hs
new file mode 100644
index 0000000..278d6f6
--- /dev/null
+++ b/src/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/src/Codec/MIME/Parse.hs b/src/Codec/MIME/Parse.hs
new file mode 100644
index 0000000..c5392fe
--- /dev/null
+++ b/src/Codec/MIME/Parse.hs
@@ -0,0 +1,295 @@
+{-# 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.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/src/Codec/MIME/QuotedPrintable.hs b/src/Codec/MIME/QuotedPrintable.hs
new file mode 100644
index 0000000..cdc2266
--- /dev/null
+++ b/src/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/src/Codec/MIME/Type.hs b/src/Codec/MIME/Type.hs
new file mode 100644
index 0000000..72ec94f
--- /dev/null
+++ b/src/Codec/MIME/Type.hs
@@ -0,0 +1,189 @@
+{-# 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           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/src/Codec/MIME/Utils.hs b/src/Codec/MIME/Utils.hs
new file mode 100644
index 0000000..dd54860
--- /dev/null
+++ b/src/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
diff --git a/src/Data/Aeson/Extends.hs b/src/Data/Aeson/Extends.hs
new file mode 100644
index 0000000..d78f81d
--- /dev/null
+++ b/src/Data/Aeson/Extends.hs
@@ -0,0 +1,15 @@
+module Data.Aeson.Extends (module Data.Aeson.Extends) where
+
+import Data.Aeson as Data.Aeson.Extends
+
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.Text.Encoding.Error as TE
+import qualified Data.Text.Lazy.Encoding as LT
+
+
+eitherDecodeLenient' :: FromJSON a => LBS.ByteString -> Either String a
+eitherDecodeLenient' s =
+    either (const $ eitherDecode' $ lenientReencode s) id (eitherDecode' s)
+  where
+    lenientReencode = LT.encodeUtf8 . LT.decodeUtf8With TE.lenientDecode
+
diff --git a/src/Much/Action.hs b/src/Much/Action