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.hs
new file mode 100644
index 0000000..5872964
--- /dev/null
+++ b/src/Much/Action.hs
@@ -0,0 +1,200 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Much.Action where
+
+import Blessings.String
+import Scanner
+import Much.State
+import Much.TagUtils
+import Much.TreeSearch
+import Much.TreeView
+import Much.TreeZipperUtils
+import qualified Data.Tree as Tree
+import qualified Data.Tree.Zipper as Z
+import qualified Notmuch
+import qualified Notmuch.Message as Notmuch
+import qualified Notmuch.SearchResult as Notmuch
+
+displayKey :: String -> State -> IO State
+displayKey s q = return q { flashMessage = Plain $ show s }
+
+
+displayMouse :: Scan -> State -> IO State
+displayMouse info q =
+    return q { flashMessage = SGR [38,5,202] $ Plain $ show info }
+
+defaultMouse1Click :: Monad m => Int -> State -> m State
+defaultMouse1Click y q@State{..} = do
+    let linearClickPos =
+            let i = (y - length headBuffer + yoffset) - 1 {-zero-based-}
+            in if 0 <= i && i < length treeBuffer
+                then Just i
+                else Nothing
+    case linearClickPos of
+        Nothing ->
+            return q
+                { flashMessage = Plain "nothing to click"
+                }
+        Just i ->
+            return q
+                { cursor = findNextN i $ Z.root cursor
+                }
+
+
+moveCursorDown :: Monad m => Int -> State -> m State
+moveCursorDown n q@State{..} =
+    let cursor' = findNextN n cursor
+        q' = q { cursor = cursor' }
+    in case botOverrun q' of
+        0 -> return q'
+        i -> moveTreeUp i q'
+
+
+moveCursorUp :: Monad m => Int -> State -> m State
+moveCursorUp n q@State{..} =
+    let cursor' = findPrevN n cursor
+        q' = q { cursor = cursor' }
+    in case topOverrun q' of
+        0 -> return q'
+        i -> moveTreeDown i q'
+
+
+moveTreeUp :: Monad m => Int -> State -> m State
+moveTreeUp n q@State{..} =
+    let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset + n) }
+    in case topOverrun q' of
+        0 -> return q'
+        i -> moveCursorDown i q'
+
+
+moveTreeDown :: Monad m => Int -> State -> m State
+moveTreeDown n q@State{..} =
+    let q' = q { yoffset = min (length treeBuffer - 1) $ max 0 (yoffset - n) }
+    in case botOverrun q' of
+        0 -> return q'
+        i -> moveCursorUp i q'
+
+
+moveTreeLeft :: Monad m => Int -> State -> m State
+moveTreeLeft n q@State{..} =
+    return q { xoffset = xoffset + n }
+
+moveTreeRight :: Monad m => Int -> State -> m State
+moveTreeRight n q@State{..} =
+    return q { xoffset = max 0 (xoffset - n) }
+
+
+moveToParent :: Monad m => State -> m State
+moveToParent q@State{..} =
+    case Z.parent cursor of
+        Nothing -> return q { flashMessage = "cannot go further up" }
+        Just cursor' ->
+            let q' = q { cursor = cursor' }
+            in case topOverrun q' of
+                0 -> return q'
+                i -> moveTreeDown i q'
+
+
+moveCursorToUnread
+    :: (Num a, Monad m, Eq a)
+    => (Z.TreePos Z.Full TreeView -> Maybe (Z.TreePos Z.Full TreeView))
+    -> (State -> a)
+    -> (a -> State -> m State)
+    -> State -> m State
+moveCursorToUnread cursorMove getTreeMoveCount treeMove q@State{..} =
+    case cursorMove cursor >>= rec of
+        Just cursor' ->
+            let q' = q { cursor = cursor' }
+            in case getTreeMoveCount q' of
+                0 -> return q'
+                i -> treeMove i q'
+        Nothing ->
+            return q { flashMessage = "no unread message in sight" }
+  where
+    rec loc =
+        if hasTag "unread" loc
+            then Just loc
+            else cursorMove loc >>= rec
+    hasTag tag loc =
+        case Z.label loc of
+            TVSearchResult sr ->
+                tag `elem` Notmuch.searchTags sr
+            TVMessage m ->
+                tag `elem` Notmuch.messageTags m
+            _ ->
+                False
+
+moveCursorUpToPrevUnread :: Monad m => State -> m State
+moveCursorUpToPrevUnread =
+    moveCursorToUnread findPrev topOverrun moveTreeDown
+
+moveCursorDownToNextUnread :: Monad m => State -> m State
+moveCursorDownToNextUnread =
+    moveCursorToUnread findNext botOverrun moveTreeUp
+
+
+openFold :: State -> IO State
+openFold q@State{..} =
+    handle <$> loadSubForest (Z.label cursor)
+  where
+    handle = \case
+        Left err ->
+            q { flashMessage = SGR [31] $ Plain err }
+        Right sf ->
+            q { cursor = Z.modifyTree (setSubForest sf) cursor }
+
+closeFold :: State -> IO State
+closeFold q@State{..} =
+    let sf = unloadSubForest (Z.tree cursor)
+     in return q { cursor = Z.modifyTree (setSubForest sf) cursor }
+
+toggleFold :: State -> IO State
+toggleFold q@State{..} =
+    if hasUnloadedSubForest (Z.tree cursor)
+        then openFold q
+        else closeFold q
+
+
+toggleTagAtCursor :: Tag -> State -> IO State
+toggleTagAtCursor tag q@State{..} = case Z.label cursor of
+
+    TVSearchResult sr -> do
+        let tagOp =
+                if tag `elem` Notmuch.searchTags sr
+                    then DelTag
+                    else AddTag
+            tagOps = [tagOp tag]
+        Notmuch.notmuchTag tagOps sr
+        let cursor' = Z.modifyTree (patchTreeTags tagOps) cursor
+        return q { cursor = cursor' }
+
+    TVMessage m -> do
+        let tagOp =
+                if tag `elem` Notmuch.messageTags m
+                    then DelTag
+                    else AddTag
+            tagOps = [tagOp tag]
+        Notmuch.notmuchTag tagOps m
+        let cursor' =
+                -- TODO this needs a nice name
+                modifyFirstParentLabelWhere isTVSearchResult f $
+                Z.modifyLabel f cursor
+            f = patchTags tagOps
+        return q { cursor = cursor' }
+
+    _ -> return q { flashMessage = "nothing happened" }
+
+
+topOverrun :: State -> Int
+topOverrun State{..} =
+    max 0 (- (linearPos cursor - yoffset))
+
+
+botOverrun :: State -> Int
+botOverrun State{..} =
+    max 0 (linearPos cursor - yoffset - (screenHeight - length headBuffer - 1))
+
+
+setSubForest :: Tree.Forest a -> Tree.Tree a -> Tree.Tree a
+setSubForest sf t = t { Tree.subForest = sf }
diff --git a/src/Much/Core.hs b/src/Much/Core.hs
new file mode 100644
index 0000000..353f248
--- /dev/null
+++ b/src/Much/Core.hs
@@ -0,0 +1,216 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Much.Core where
+
+import Much.Action
+import Blessings.String (Blessings(Plain,SGR),pp)
+import Control.Concurrent
+import Control.Monad
+import Data.Time
+import Much.Event
+import Much.RenderTreeView (renderTreeView)
+import Scanner (scan,Scan(..))
+import Much.Screen
+import Much.State
+import System.Console.Docopt.NoTH (getArgWithDefault, parseArgsOrExit, parseUsageOrExit, shortOption)
+import System.Environment
+import System.IO
+import System.Posix.Signals
+import Much.TreeSearch
+import Much.TreeView
+import Much.Utils
+import qualified Blessings.Internal as Blessings
+import qualified Data.Tree as Tree
+import qualified Data.Tree.Zipper as Z
+import qualified Notmuch
+import qualified System.Console.Terminal.Size as Term
+
+
+
+emptyState :: State
+emptyState = State
+    { cursor = Z.fromTree (Tree.Node (TVSearch "<emptyState>") [])
+    , xoffset = 0
+    , yoffset = 0
+    , flashMessage = "Welcome to much; quit with ^C"
+    , screenWidth = 0
+    , screenHeight = 0
+    , headBuffer = []
+    , treeBuffer = []
+    , now = UTCTime (fromGregorian 1984 5 23) 49062
+    , signalHandlers = []
+    , query = "tag:inbox AND NOT tag:killed"
+    , keymap = displayKey
+    , mousemap = displayMouse
+    , colorConfig = ColorConfig
+        { tagMap =
+            [ ("killed", SGR [38,5,088])
+            , ("star", SGR [38,5,226])
+            , ("draft", SGR [38,5,202])
+            ]
+        , alt = SGR [38,5,182]
+        , search = SGR [38,5,162]
+        , focus = SGR [38,5,160]
+        , quote = SGR [38,5,242]
+        , boring = SGR [38,5,240]
+        , prefix = SGR [38,5,235]
+        , date = SGR [38,5,071]
+        , tags = SGR [38,5,036]
+        , boringMessage = SGR [38,5,023]
+        , unreadMessage = SGR [38,5,117]
+        , unreadSearch = SGR [38,5,250]
+        }
+    , tagSymbols = []
+    }
+
+notmuchSearch :: State -> IO State
+notmuchSearch q@State{query} = do
+  r_ <- either error id <$> Notmuch.search
+                                [ "--offset=0"
+                                , "--limit=100"
+                                , query
+                                ]
+
+  return q { cursor = Z.fromTree $ fromSearchResults query r_ }
+
+mainWithState :: State -> IO ()
+mainWithState state = mainWithStateAndArgs state =<< getArgs
+
+mainWithStateAndArgs :: State -> [String] -> IO ()
+mainWithStateAndArgs state@State{query = defaultSearch} args = do
+    usage' <- parseUsageOrExit usage
+    args' <- parseArgsOrExit usage' args
+    let query = getArgWithDefault args' defaultSearch (shortOption 'q')
+    withScreen s0 (\_-> notmuchSearch state { query = query } >>= runState)
+  where
+    usage = unlines
+      [ "Command-line MUA using notmuch."
+      , ""
+      , "Usage:"
+      , "  much [-q <search-term>]"
+      , ""
+      , "Options:"
+      , "  -q <search-term>, --query=<search-term>"
+      , "        Open specific search, defaults to " ++ show defaultSearch
+      ]
+
+    s0 = Screen False NoBuffering (BlockBuffering $ Just 4096)
+            [ 1000 -- X & Y on button press and release
+            , 1005 -- UTF-8 mouse mode
+            , 1047 -- use alternate screen buffer
+            ]
+            [   25 -- hide cursor
+            ]
+
+runState :: State -> IO ()
+runState q0 = do
+
+    -- load-env hack
+    maybe (return ()) (setEnv "HOME") =<< lookupEnv "OLDHOME"
+
+    (putEvent, getEvent) <- do
+        v <- newEmptyMVar
+        return (putMVar v, takeMVar v)
+
+    let q1 = q0 { signalHandlers =
+                    [ (sigINT, putEvent EShutdown)
+                    , (28, winchHandler putEvent)
+                    ] }
+
+    installHandlers (signalHandlers q1)
+
+    threadIds <- mapM forkIO
+        [ forever $ scan stdin >>= putEvent . EScan
+        ]
+
+    winchHandler putEvent
+
+    run getEvent q1
+    mapM_ killThread threadIds
+
+
+installHandlers :: [(Signal, IO ())] -> IO ()
+installHandlers =
+    mapM_ (\(s, h) -> installHandler s (Catch h) Nothing)
+
+uninstallHandlers :: [(Signal, IO ())] -> IO ()
+uninstallHandlers =
+    mapM_ (\(s, _) -> installHandler s Ignore Nothing)
+
+
+winchHandler :: (Event -> IO ()) -> IO ()
+winchHandler putEvent =
+    Term.size >>= \case
+        Just Term.Window {Term.width = w, Term.height = h} ->
+            putEvent $ EResize w h
+        Nothing ->
+            return ()
+
+run :: IO Event -> State -> IO ()
+run getEvent = rec . Right where
+    rec = \case
+        Right q -> rec =<< do
+            t <- getCurrentTime
+            let q' = render q { now = t }
+            redraw q' >> getEvent >>= processEvent q'
+        Left _q -> return ()
+
+
+processEvent :: State -> Event -> IO (Either State State)
+processEvent q = \case
+    EFlash t ->
+        return $ Right q { flashMessage = t }
+    EScan (ScanKey s) ->
+        Right <$> keymap q s q
+    EScan info@ScanMouse{..} ->
+        Right <$> mousemap q info q
+    EShutdown ->
+        return $ Left q
+    EResize w h ->
+        return $ Right q
+            { screenWidth = w, screenHeight = h
+            , flashMessage = Plain $ "resize " <> show (w,h)
+            }
+    ev ->
+        return $ Right q
+            { flashMessage = SGR [31,1] $ Plain $ "unhandled event: " <> show ev
+            }
+
+
+render :: State -> State
+render q@State{..} =
+    q { treeBuffer = newTreeBuf
+      , headBuffer = newHeadBuf
+      }
+  where
+    newTreeBuf = renderTreeView q (Z.root cursor)
+    newHeadBuf =
+        [ Plain (show screenWidth) <> "x" <> Plain (show screenHeight)
+          <> " " <> Plain (show $ linearPos cursor - yoffset)
+          <> " " <> Plain (show $ topOverrun q)
+          <> " " <> Plain (show $ botOverrun q)
+          <> " " <> flashMessage
+          <> " " <> Plain (show (xoffset, yoffset))
+        ]
+
+render0 :: State -> [Blessings String]
+render0 _q@State{..} = do
+    let buffer =
+            map (Blessings.take screenWidth . Blessings.drop xoffset) $
+            take screenHeight $
+            headBuffer ++ drop yoffset treeBuffer
+    buffer ++ replicate (screenHeight - length buffer) "~"
+
+
+redraw :: State -> IO ()
+redraw q@State{..} = do
+    hPutStr stdout $ map (sub '\t' ' ') $ "\ESC[H" ++ pp (mintercalate "\n" $ map eraseRight $ render0 q)
+    hFlush stdout
+  where
+    sub x x' c = if c == x then x' else c
+    eraseRight s =
+        if Blessings.length s < screenWidth
+            then s <> "\ESC[K"
+            else s
diff --git a/src/Much/Event.hs b/src/Much/Event.hs
new file mode 100644
index 0000000..9842327
--- /dev/null
+++ b/src/Much/Event.hs
@@ -0,0 +1,12 @@
+module Much.Event where
+
+import Blessings
+import Scanner
+
+data Event =
+    EFlash (Blessings String) |
+    EScan Scan |
+    EShutdown |
+    EReload |
+    EResize Int Int
+  deriving Show
diff --git a/src/Much/MBox.hs b/src/Much/MBox.hs
new file mode 100644
index 0000000..9299eea
--- /dev/null
+++ b/src/Much/MBox.hs
@@ -0,0 +1,156 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+module Much.MBox
+    (
+      -- TODO don't re-export MBox but use our own Message type
+      module Export
+    , getMessageId
+    , toForest
+    ) where
+
+import qualified Data.MBox as Export
+
+import           Control.Applicative
+import qualified Data.CaseInsensitive as CI
+import qualified Data.List as List
+import           Data.Map.Strict   (Map)
+import qualified Data.Map.Strict as Map
+import           Data.Maybe
+import           Data.MBox
+import           Data.Ord
+import           Data.Set   (Set)
+import qualified Data.Set as Set
+import           Data.Text.Lazy   (Text)
+import           Data.Time
+import           Data.Tree   (Tree, Forest)
+import qualified Data.Tree as Tree
+import qualified MappedSets
+import qualified Data.Text.Lazy as Text
+import           Safe
+import           System.Locale
+import qualified Text.ParserCombinators.Parsec.Rfc2822 as P
+import qualified Text.ParserCombinators.Parsec as P
+
+
+type Ident = Text
+
+
+data IdentFields = IdentFields
+    { messageId :: Ident
+    , inReplyTo :: [Ident]
+    , references :: [Ident]
+    }
+  deriving Show
+
+
+toForest :: MBox -> Forest Message
+toForest mbox =
+    map (sortTree . fmap (\i -> fromMaybe (error "meh") $ Map.lookup i msgs)) $
+    concatMap (Tree.subForest . mkSubTree) (Set.toList $ roots refs)
+  where
+
+    mkSubTree rootLabel =
+        Tree.Node rootLabel $
+            map mkSubTree (maybe [] Set.toList $ Map.lookup rootLabel backRefs)
+
+    refs = mboxRefs mbox
+    backRefs = MappedSets.invert refs
+    msgs = unpackMBox mbox
+
+
+-- TODO finde a new home for roots
+roots :: Ord a => Map a (Set a) -> Set a
+roots refs =
+    Set.unions $ Map.elems $ Map.filter p refs
+  where
+    messageIDs = Set.fromList $ Map.keys refs
+    p = Set.null . Set.intersection messageIDs
+
+
+-- TODO finde a new home for sortTree
+sortTree :: Tree Message -> Tree Message
+sortTree t =
+    Tree.Node (Tree.rootLabel t) $
+        map sortTree $
+        List.sortOn (getMessageDate . Tree.rootLabel) $
+        Tree.subForest t
+
+
+getMessageDate :: Message -> Maybe UTCTime
+getMessageDate msg =
+    parseTime defaultTimeLocale rfc822DateFormat =<<
+    Text.unpack . snd <$>
+        (lastMay $
+         filter ((==CI.mk "Date") . CI.mk . Text.unpack . fst) $
+         headers msg)
+
+
+unpackMBox :: MBox -> Map Ident Message
+unpackMBox =
+    Map.fromList .
+    map (\msg -> (getMessageId $ headers msg, msg))
+
+
+getIdentFields :: Message -> IdentFields
+getIdentFields m =
+    IdentFields
+        { messageId = getMessageId hdrs
+        , inReplyTo = getInReplyTo hdrs
+        , references = getReferences hdrs
+        }
+  where
+    hdrs = headers m
+
+
+-- TODO generate default Message-ID if not present
+getMessageId :: [Header] -> Ident
+getMessageId =
+    head .
+    headerMessageIds "Message-ID"
+
+
+getInReplyTo :: [Header] -> [Ident]
+getInReplyTo =
+    headerMessageIds "In-Reply-To"
+
+
+getReferences :: [Header] -> [Ident]
+getReferences =
+    headerMessageIds "References"
+
+
+headerMessageIds :: P.SourceName -> [Header] -> [Ident]
+headerMessageIds headerName =
+    concatMap (
+        either ((:[]) . Text.pack . show) id .
+        parseMsgIds headerName .
+        snd
+    ) .
+    filter ((==CI.mk headerName) . CI.mk . Text.unpack . fst)
+
+
+parseMsgIds :: P.SourceName -> Text -> Either P.ParseError [Ident]
+parseMsgIds srcName =
+    fmap (map (Text.init . Text.tail . Text.pack)) .
+    P.parse obs_in_reply_to_parser srcName .
+    Text.unpack
+  where
+    --obs_in_reply_to_parser :: CharParser a [String]
+    obs_in_reply_to_parser =
+        --filter (not . null) <$> P.many (P.phrase >> return [] <|> P.msg_id)
+        P.many1 P.msg_id
+
+
+messageRefs :: IdentFields -> [Ident]
+messageRefs IdentFields{..} =
+    if null inReplyTo
+        then maybe [""] (:[]) (lastMay references)
+        else inReplyTo
+
+
+mboxRefs :: MBox -> Map Ident (Set Ident)
+mboxRefs =
+    MappedSets.mk .
+    map (\m ->
+          let x = getIdentFields m
+          in (messageId x, messageRefs x))
diff --git a/src/Much/MappedSets.hs b/src/Much/MappedSets.hs
new file mode 100644
index 0000000..ec0ae73
--- /dev/null
+++ b/src/Much/MappedSets.hs
@@ -0,0 +1,28 @@
+module Much.MappedSets (invert, mk) where
+
+import           Control.Arrow
+import           Data.Map.Strict   (Map)
+import qualified Data.Map.Strict as Map
+import           Data.Maybe
+import           Data.Set   (Set)
+import qualified Data.Set as Set
+
+
+mk :: (Ord a, Ord b) => [(a, [b])] -> Map a (Set b)
+mk =
+    Map.fromList . map (second Set.fromList)
+
+
+invert :: (Ord a, Ord b) => Map a (Set b) -> Map b (Set a)
+invert =
+    Map.foldrWithKey invert1 Map.empty
+
+
+invert1 :: (Ord a, Ord b) => a -> Set b -> Map b (Set a) -> Map b (Set a)
+invert1 k v a =
+    Set.foldr (upsert k) a v
+
+
+upsert :: (Ord a, Ord b) => a -> b -> Map b (Set a) -> Map b (Set a)
+upsert k =
+    Map.alter (Just . Set.insert k . fromMaybe Set.empty)
diff --git a/src/Much/ParseMail.hs b/src/Much/ParseMail.hs
new file mode 100644
index 0000000..e12737a
--- /dev/null
+++ b/src/Much/ParseMail.hs
@@ -0,0 +1,312 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+
+module Much.ParseMail (readMail) where
+
+import qualified Data.Attoparsec.ByteString.Char8 as A8
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Char8 as BS8
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as T
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LT
+import qualified Network.Email.Header.Parser as P
+import qualified Network.Email.Header.Types as H
+import qualified Network.Mail.Mime as M
+import Codec.MIME.Parse
+import qualified Codec.MIME.QuotedPrintable as QP
+import Codec.MIME.Type
+import Control.Applicative
+import Data.Char
+
+
+
+-- TODO eventually we want our completely own Address, i.e. w/o M.Address
+data Address = Mailbox M.Address | Group T.Text [M.Address]
+  deriving (Show)
+
+
+
+readMail :: T.Text -> M.Mail
+readMail =
+    fromMIMEValue . parseMIMEMessage
+
+
+fromMIMEValue :: MIMEValue -> M.Mail
+fromMIMEValue val0 =
+    let m = foldr f (M.emptyMail $ M.Address Nothing "anonymous@localhost")
+              $ fromMIMEParams
+              $ mime_val_headers val0
+    in m { M.mailParts = [part val0] }
+  where
+
+    part val =
+        case mime_val_content val of
+            Single content ->
+                (:[]) $
+                M.Part
+                    -- TODO actually check if we're utf-8 or ascii(?)
+                    { M.partType = "text/plain; charset=utf-8"
+                    , M.partEncoding = M.QuotedPrintableText
+                    , M.partFilename = Nothing
+                    , M.partHeaders = []
+                    , M.partContent = LT.encodeUtf8 $ LT.fromStrict content
+                    }
+            Multi vals ->
+                concatMap part vals
+
+    --f :: H.Header -> M.Mail -> M.Mail
+    f (k, v) m = case k of
+        "from" ->
+            m { M.mailFrom = case parseAddress (LBS.toStrict v) of
+                  Left msg -> error msg
+                  Right Nothing -> M.mailFrom m
+                  Right (Just (Mailbox a)) -> a
+                  Right (Just (Group _ _)) ->
+                      error "cannot use group in from header"
+                }
+        "to" ->
+            m { M.mailTo =
+                  mconcat $
+                      map (\case
+                            Mailbox a -> [a]
+                            Group _ as -> as
+                        ) $
+                      either error id $
+                      parseAddresses $
+                      LBS.toStrict v
+              }
+        "cc" ->
+            m { M.mailCc =
+                  mconcat $
+                      map (\case
+                            Mailbox a -> [a]
+                            Group _ as -> as
+                        ) $
+                      either error id $
+                      parseAddresses $
+                      LBS.toStrict v
+              }
+        "bcc" ->
+            m { M.mailBcc =
+                  mconcat $
+                      map (\case
+                            Mailbox a -> [a]
+                            Group _ as -> as
+                        ) $
+                      either error id $
+                      parseAddresses $
+                      LBS.toStrict v
+              }
+        _ ->
+            m { M.mailHeaders =
+                  ( CI.original k
+                  , either
+                      (const "I am made of stupid")
+                      LT.toStrict
+                      (LT.decodeUtf8' v)
+                  ) :
+                  M.mailHeaders m
+              }
+
+
+parseAddress :: BS.ByteString -> Either String (Maybe Address)
+parseAddress =
+    A8.parseOnly (P.cfws *> (Just <$> address <|> return Nothing) <* A8.endOfInput)
+
+
+parseAddresses :: BS.ByteString -> Either String [Address]
+parseAddresses =
+    A8.parseOnly (P.cfws *> address `A8.sepBy1` A8.char ',' <* A8.endOfInput)
+
+
+fromMIMEParams :: [MIMEParam] -> H.Headers
+fromMIMEParams =
+    map $ \(MIMEParam k v) ->
+        (CI.mk $ T.encodeUtf8 $ CI.original k, LT.encodeUtf8 $ LT.fromStrict v)
+
+
+-- TODO we should probably use email-header
+
+
+-- address     =  mailbox                      ; one addressee
+--             /  group                        ; named list
+address :: A8.Parser Address
+address =
+    (A8.<?> "address") $
+    Mailbox <$> mailbox
+    <|>
+    group
+
+
+-- group       =  phrase ":" [#mailbox] ";"
+group :: A8.Parser Address
+group =
+    (A8.<?> "group") $
+    Group
+        <$> T.intercalate "," <$> phrase
+        <* A8.char ':'
+        <*> mailbox `A8.sepBy` A8.many1 (A8.char ',')
+        <* A8.char ';'
+
+
+-- mailbox     =  addr-spec                    ; simple address
+--             /  phrase route-addr            ; name & addr-spec
+mailbox :: A8.Parser M.Address
+mailbox =
+    (A8.<?> "mailbox") $
+    M.Address Nothing <$> addrSpec <|>
+    M.Address . Just . T.intercalate " " <$> A8.option [] phrase <*> routeAddr
+
+
+-- route-addr  =  "<" [route] addr-spec ">"
+routeAddr :: A8.Parser T.Text
+routeAddr =
+    (A8.<?> "routeAddr") $
+    P.cfws *>
+    A8.char '<' *>
+    -- TODO A8.option [] route <*>
+    addrSpec <*
+    A8.char '>'
+
+
+---- route       =  1#("@" domain) ":"           ; path-relative
+--route :: A8.Parser [T.Text]
+--route =
+--    (A8.<?> "route") $
+--    A8.many1 (A8.char '@' *> domain) <* A8.char ':'
+
+
+-- addr-spec   =  local-part "@" domain        ; global address
+addrSpec :: A8.Parser T.Text
+addrSpec =
+    (A8.<?> "addrSpec") $ do
+        a <- localPart
+        b <- T.singleton <$> A8.char '@'
+        c <- domain
+        return $ a <> b <> c
+
+-- local-part  =  word *("." word)             ; uninterpreted
+--                                             ; case-preserved
+localPart :: A8.Parser T.Text
+localPart =
+    (A8.<?> "localPart") $
+     T.intercalate "." <$> (word `A8.sepBy1` A8.char '.')
+
+
+-- domain      =  sub-domain *("." sub-domain)
+domain :: A8.Parser T.Text
+domain =
+    (A8.<?> "domain") $
+    T.intercalate "." <$> (subDomain `A8.sepBy1` A8.char '.')
+
+-- sub-domain  =  domain-ref / domain-literal
+subDomain :: A8.Parser T.Text
+subDomain =
+    (A8.<?> "subDomain") $
+    domainRef <|> domainLiteral
+
+-- domain-ref  =  atom                         ; symbolic reference
+domainRef :: A8.Parser T.Text
+domainRef =
+    (A8.<?> "domainRef") $
+    atom
+
+
+-- atom        =  1*<any CHAR except specials, SPACE and CTLs>
+atom :: A8.Parser T.Text
+atom =
+    (A8.<?> "atom") $
+    P.cfws *>
+    (T.pack <$> A8.many1 (A8.satisfy $ A8.notInClass atomClass))
+
+
+-- domain-literal =  "[" *(dtext / quoted-pair) "]"
+domainLiteral :: A8.Parser T.Text
+domainLiteral =
+    (A8.<?> "domainLiteral") $
+    T.pack <$>
+        (A8.char '[' *> A8.many' (dtext <|> quotedPair) <* A8.char ']')
+
+
+-- dtext       =  <any CHAR excluding "[",     ; => may be folded
+--                 "]", "\" & CR, & including
+--                 linear-white-space>
+dtext :: A8.Parser Char
+dtext =
+    (A8.<?> "dtext") $
+    A8.satisfy (A8.notInClass "[]\\\CR")
+
+
+-- phrase      =  1*word
+phrase :: A8.Parser [T.Text]
+phrase =
+    (A8.<?> "phrase") $
+    A8.many1 word
+
+
+-- qtext       =  <any CHAR excepting <">,     ; => may be folded
+--                 "\" & CR, and including
+--                 linear-white-space>
+qtext :: A8.Parser Char
+qtext =
+    (A8.<?> "qtext") $
+    A8.satisfy (A8.notInClass "\"\\\CR")
+
+
+-- quoted-pair =  "\" CHAR
+quotedPair :: A8.Parser Char
+quotedPair =
+    (A8.<?> "quotedPair") $
+    A8.char '\\' *> A8.anyChar
+
+
+-- quoted-string = <"> *(qtext/quoted-pair) <">; Regular qtext or
+--                                             ;   quoted chars.
+quotedString :: A8.Parser T.Text
+quotedString =
+    (A8.<?> "quotedString") $
+    T.pack <$> (A8.char '"' *> A8.many' (qtext <|> quotedPair) <* A8.char '"')
+
+
+encodedWord :: A8.Parser T.Text
+encodedWord =
+    (A8.<?> "encodedWord") $ do
+        _ <- A8.string "=?"
+        _ <- A8.string "utf-8" -- TODO 1. CI, 2. other encodings
+        _ <- A8.string "?Q?"
+        w <- A8.manyTill A8.anyChar (A8.string "?=") -- TODO all of them
+        return
+            $ T.decodeUtf8
+            $ BS8.pack
+            $ QP.decode
+                -- ^ TODO this current doesn't decode
+                -- underscore to space
+            $ map (\c -> if c == '_' then ' ' else c)
+            $ w
+
+
+-- word        =  encoded-word / atom / quoted-string
+--                ^ TODO what's the correct term for that?
+word :: A8.Parser T.Text
+word =
+    (A8.<?> "word") $
+    encodedWord <|> atom <|> quotedString
+
+
+atomClass :: [Char]
+atomClass = specialClass ++ spaceClass ++ ctlClass
+
+
+specialClass :: [Char]
+specialClass = "()<>@,;:\\\".[]"
+
+
+spaceClass :: [Char]
+spaceClass = " "
+
+
+ctlClass :: [Char]
+ctlClass = map chr $ [0..31] ++ [127]
diff --git a/src/Much/RenderTreeView.hs b/src/Much/RenderTreeView.hs
new file mode 100644
index 0000000..60b48d6
--- /dev/null
+++ b/src/Much/RenderTreeView.hs
@@ -0,0 +1,210 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Much.RenderTreeView (renderTreeView) where
+
+import qualified Notmuch.Message as Notmuch
+import qualified Notmuch.SearchResult as Notmuch
+import qualified Data.CaseInsensitive as CI
+import qualified Data.List as L
+import qualified Data.Map as M
+import qualified Data.Text as T
+import qualified Data.Tree.Zipper as Z
+import qualified Much.TreeZipperUtils as Z
+import Blessings
+import Data.Char
+import Data.Maybe
+import Data.Time
+import Data.Time.Format.Human
+import Data.Tree
+import Much.State
+import Much.TagUtils (Tag)
+import Much.TreeView
+
+
+-- TODO make configurable
+humanTimeLocale :: HumanTimeLocale
+humanTimeLocale = defaultHumanTimeLocale
+    { justNow       = "now"
+    , secondsAgo    = \f -> (++ "s" ++ dir f)
+    , oneMinuteAgo  = \f -> "1m" ++ dir f
+    , minutesAgo    = \f -> (++ "m" ++ dir f)
+    , oneHourAgo    = \f -> "1h" ++ dir f
+    , aboutHoursAgo = \f -> (++ "h" ++ dir f)
+    , at            = \_ -> ("" ++)
+    , daysAgo       = \f -> (++ "d" ++ dir f)
+    , weekAgo       = \f -> (++ "w" ++ dir f)
+    , weeksAgo      = \f -> (++ "w" ++ dir f)
+    , onYear        = ("" ++)
+    , dayOfWeekFmt  = "%a %H:%M"
+    , thisYearFmt   = "%b %e"
+    , prevYearFmt   = "%b %e, %Y"
+    }
+  where dir True  = " from now"
+        dir False = " ago"
+
+
+renderTreeView
+    :: State
+    -> Z.TreePos Z.Full TreeView
+    -> [Blessings String]
+renderTreeView q@State{..} =
+    renderNode
+  where
+    isFocus = (Z.label cursor==) . Z.label
+
+    renderNode loc =
+        renderRootLabel loc :
+        maybeRenderSubForest (Z.firstChild loc)
+
+    renderRootLabel loc =
+        renderPrefix q loc <>
+        renderTreeView1 q (isFocus loc) (Z.label loc)
+
+    renderSubForest loc =
+        renderNode loc ++
+        maybeRenderSubForest (Z.next loc)
+
+    maybeRenderSubForest =
+        maybe mempty renderSubForest
+
+
+renderPrefix :: State -> Z.TreePos Z.Full TreeView -> Blessings String
+renderPrefix state =
+    mconcat . reverse . zipWith (curry prefix) [(1 :: Int)..] . Z.path
+  where
+    prefix (i, (_lhs, x, rhs)) = case x of
+        TVSearch _ -> ""
+        TVSearchResult _ -> spacePrefix state
+        TVMessage _ ->
+            case i of
+                1 ->
+                    if null rhs
+                        then endPrefix state
+                        else teePrefix state
+                _ ->
+                    if null rhs
+                        then spacePrefix state
+                        else pipePrefix state
+        _ ->
+            if not $ any (isTVMessage . rootLabel) rhs
+                then spacePrefix state
+                else pipePrefix state
+
+
+spacePrefix
+    , teePrefix
+    , pipePrefix
+    , endPrefix
+    :: State -> Blessings String
+spacePrefix q = prefix (colorConfig q) "  "
+teePrefix q = prefix (colorConfig q) "├╴"
+pipePrefix q = prefix (colorConfig q) "│ "
+endPrefix q = prefix (colorConfig q) "└╴"
+
+
+-- TODO locale-style: headerKey = \s -> SGR [..] (s <> ": ")
+
+
+renderTreeView1 :: State -> Bool -> TreeView -> Blessings String
+renderTreeView1 q@State{..} hasFocus x = case x of
+
+    TVSearch s ->
+        let c = if hasFocus then focus colorConfig else search colorConfig
+        in c $ Plain s
+
+    TVSearchResult sr ->
+        let c
+                | hasFocus = focus colorConfig
+                | isUnread = unreadSearch colorConfig
+                | otherwise = boring colorConfig
+            c_authors
+                | hasFocus = focus colorConfig
+                | isUnread = alt colorConfig
+                | otherwise = boring colorConfig
+
+            isUnread = "unread" `elem` Notmuch.searchTags sr
+
+            authors = Plain $ T.unpack $ Notmuch.searchAuthors sr
+            date = Much.State.date colorConfig $ renderDate now x
+            subject = Plain $ T.unpack $ Notmuch.searchSubject sr
+            tags = Much.State.tags colorConfig $ renderTags q (Notmuch.searchTags sr)
+            title = if subject /= "" then subject else c_authors authors
+        in
+          c $ title <> " " <> date <> " " <> tags
+
+    TVMessage m ->
+        let fromSGR
+                | hasFocus = focus colorConfig
+                | "unread" `elem` Notmuch.messageTags m = unreadMessage colorConfig
+                | otherwise = boringMessage colorConfig
+            from = fromSGR $ renderFrom (M.lookup "from" $ Notmuch.messageHeaders m)
+            date = Much.State.date colorConfig $ renderDate now x
+            tags = Much.State.tags colorConfig $ renderTags q (Notmuch.messageTags m) -- TODO filter common tags
+        in from <> " " <> date <> " " <> tags
+
+    TVMessageHeaderField m fieldName ->
+        let c = if hasFocus then focus colorConfig else boring colorConfig
+            k = Plain $ T.unpack $ CI.original fieldName
+            v = maybe "nothing"
+                      (Plain . T.unpack)
+                      (M.lookup fieldName $ Notmuch.messageHeaders m)
+        in c $ k <> ": " <> v
+
+    TVMessagePart _ p ->
+        let c = if hasFocus then focus colorConfig else boring colorConfig
+            i = Plain $ show $ Notmuch.partID p
+            t = Plain $ T.unpack $ CI.original $ Notmuch.partContentType p
+            filename = maybe "" (Plain . (" "<>) . show) $ Notmuch.partContentFilename p
+            charset = maybe "" (Plain . (" "<>) . show) $ Notmuch.partContentCharset p
+            size = Plain $ show $ Notmuch.contentSize (Notmuch.partContent p)
+        in c $ "part#" <> i <> " " <> t <> filename <> charset <> " " <> size
+
+    TVMessageQuoteLine _ _ _ s ->
+        if hasFocus
+            then focus colorConfig $ Plain s
+            else quote colorConfig $ Plain s
+
+    TVMessageLine _ _ _ s ->
+        if hasFocus
+            then focus colorConfig $ Plain s
+            else Plain s
+
+
+
+renderDate :: UTCTime -> TreeView -> Blessings String
+renderDate now = \case
+    TVSearchResult sr -> f humanTimeLocale (Notmuch.searchTime sr)
+    TVMessage m -> f humanTimeLocale (Notmuch.messageTime m)
+    _ -> SGR [35,1] "timeless"
+  where
+    f timeLocale time =
+        Plain $ humanReadableTimeI18N' timeLocale now time
+
+
+renderFrom :: Maybe T.Text -> Blessings String
+renderFrom = \case
+    Just fromLine -> Plain $ dropAddress $ T.unpack fromLine
+    Nothing -> SGR [35,1] "Anonymous"
+
+
+renderTags :: State -> [Tag] -> Blessings String
+renderTags state =
+    -- TODO sort somewhere else
+    mconcat . L.intersperse " " . map (renderTag state) . L.sort
+
+
+renderTag :: State -> Tag -> Blessings String
+renderTag state tag = case lookup tag (tagMap (colorConfig state)) of
+    Just visual -> visual plain
+    Nothing -> plain
+  where
+    plain = Plain $ T.unpack $ fromMaybe tag $ lookup tag (tagSymbols state)
+
+
+dropAddress :: String -> String
+dropAddress xs =
+    case L.elemIndices '<' xs of
+        [] -> xs
+        is -> L.dropWhileEnd isSpace $ take (last is) xs
diff --git a/src/Much/Screen.hs b/src/Much/Screen.hs
new file mode 100644
index 0000000..47bb90c
--- /dev/null
+++ b/src/Much/Screen.hs
@@ -0,0 +1,32 @@
+{-# LANGUAGE RecordWildCards #-}
+module Much.Screen (Screen(..), setScreen, withScreen) where
+
+import Control.Exception
+import Data.List
+import System.IO
+
+data Screen = Screen
+    { stdinEcho :: Bool
+    , stdinBufferMode :: BufferMode
+    , stdoutBufferMode :: BufferMode
+    , decsetPm :: [Int]
+    , decrstPm :: [Int]
+    }
+
+setScreen :: Screen -> IO Screen
+setScreen Screen{..} = get <* set where
+  get = Screen <$> hGetEcho stdin
+               <*> hGetBuffering stdin
+               <*> hGetBuffering stdout
+               <*> pure decrstPm
+               <*> pure decsetPm
+  set = do
+      hSetEcho stdin stdinEcho
+      hSetBuffering stdin stdinBufferMode
+      hSetBuffering stdout stdoutBufferMode
+      hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decsetPm) ++ "h"
+      hPutStr stdout $ "\ESC[?" ++ intercalate ";" (map show decrstPm) ++ "l"
+      hFlush stdout
+
+withScreen :: Screen -> (Screen -> IO a) -> IO a
+withScreen s = bracket (setScreen s) setScreen
diff --git a/src/Much/State.hs b/src/Much/State.hs
new file mode 100644
index 0000000..a522e99
--- /dev/null
+++ b/src/Much/State.hs
@@ -0,0 +1,42 @@
+module Much.State where
+
+import Blessings.String (Blessings)
+import qualified Data.Text as T
+import Data.Time
+import qualified Data.Tree.Zipper as Z
+import Scanner
+import System.Posix.Signals
+import Much.TreeView (TreeView)
+
+data State = State
+    { cursor :: Z.TreePos Z.Full TreeView
+    , xoffset :: Int
+    , yoffset :: Int
+    , flashMessage :: Blessings String
+    , screenWidth :: Int
+    , screenHeight :: Int
+    , headBuffer :: [Blessings String]
+    , treeBuffer :: [Blessings String]
+    , now :: UTCTime
+    , signalHandlers :: [(Signal, IO ())]
+    , query :: String
+    , keymap :: String -> State -> IO State
+    , mousemap :: Scan -> State -> IO State
+    , tagSymbols :: [(T.Text, T.Text)]
+    , colorConfig :: ColorConfig
+    }
+
+data ColorConfig = ColorConfig
+    { alt :: Blessings String -> Blessings String
+    , search :: Blessings String -> Blessings String
+    , focus :: Blessings String -> Blessings String
+    , quote :: Blessings String -> Blessings String
+    , boring :: Blessings String -> Blessings String
+    , prefix :: Blessings String -> Blessings String
+    , date :: Blessings String -> Blessings String
+    , tags :: Blessings String -> Blessings String
+    , unreadSearch :: Blessings String -> Blessings String
+    , unreadMessage :: Blessings String -> Blessings String
+    , boringMessage :: Blessings String -> Blessings String
+    , tagMap :: [(T.Text, Blessings String -> Blessings String)]
+    }
diff --git a/src/Much/TagUtils.hs b/src/Much/TagUtils.hs
new file mode 100644
index 0000000..d4e4d30
--- /dev/null
+++ b/src/Much/TagUtils.hs
@@ -0,0 +1,62 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Much.TagUtils where
+
+import qualified Data.Set as Set
+import qualified Data.Text as T
+import Data.Char
+import Data.List.Split (wordsBy)
+import Data.Tree
+import Notmuch.Message
+import Notmuch.SearchResult
+import Much.TreeView.Types
+
+
+type Tag = T.Text
+
+
+data TagOp = AddTag Tag | DelTag Tag
+
+
+parseTags :: String -> [Tag]
+parseTags =
+    mconcat . map (map T.pack . wordsBy isSpace . takeWhile (/='#')) . lines
+
+
+diffTags :: [Tag] -> [Tag] -> [TagOp]
+diffTags old new =
+    let oldTags = Set.fromList old
+        newTags = Set.fromList new
+    in map DelTag (Set.toList $ oldTags `Set.difference` newTags) ++
+       map AddTag (Set.toList $ newTags `Set.difference` oldTags)
+
+
+patchRootLabelTags :: [TagOp] -> Tree TreeView -> Tree TreeView
+patchRootLabelTags tagOps x =
+    x { rootLabel = patchTags tagOps $ rootLabel x }
+
+
+patchTreeTags :: [TagOp] -> Tree TreeView -> Tree TreeView
+patchTreeTags tagOps =
+    fmap (patchTags tagOps)
+
+
+tagOpsToArgs :: [TagOp] -> [String]
+tagOpsToArgs = map $ \case
+    AddTag t -> '+' : T.unpack t
+    DelTag t -> '-' : T.unpack t
+
+
+patchTags :: [TagOp] -> TreeView -> TreeView
+patchTags tagOps = \case
+    TVSearchResult sr ->
+        TVSearchResult sr { searchTags = foldr applyTagOp (searchTags sr) tagOps }
+    TVMessage m ->
+        TVMessage m { messageTags = foldr applyTagOp (messageTags m) tagOps }
+    x -> x -- nop
+
+
+applyTagOp :: TagOp -> [Tag] -> [Tag]
+applyTagOp = \case
+    AddTag t -> (t:)
+    DelTag t -> filter (/=t)
diff --git a/src/Much/TreeSearch.hs b/src/Much/TreeSearch.hs
new file mode 100644
index 0000000..d66eb83
--- /dev/null
+++ b/src/Much/TreeSearch.hs
@@ -0,0 +1,87 @@
+module Much.TreeSearch where
+
+import Data.Tree.Zipper
+
+
+findTree :: (a -> Bool) -> TreePos Full a -> Maybe (TreePos Full a)
+findTree p loc = if p (label loc)
+    then Just loc
+    else depthFirst loc >>= findTree p
+
+
+depthFirst :: TreePos Full a -> Maybe (TreePos Full a)
+depthFirst loc = case firstChild loc of
+    Just x -> Just x
+    Nothing -> case next loc of
+        Just x -> Just x
+        Nothing -> parentWithNext loc
+  where
+    parentWithNext x =
+        case parent x of
+            Nothing -> Nothing
+            Just x' -> case next x' of
+                Just x'' -> Just x''
+                Nothing -> parentWithNext x'
+
+
+findNext :: TreePos Full a -> Maybe (TreePos Full a)
+findNext = depthFirst
+
+
+findPrev :: TreePos Full a -> Maybe (TreePos Full a)
+findPrev loc =
+    case prev loc of
+        Just x -> trans_lastChild x
+        Nothing -> parent loc
+  where
+    trans_lastChild x =
+        case lastChild x of
+            Nothing -> Just x
+            Just x' -> trans_lastChild x'
+
+
+
+findNextN :: Eq a => Int -> TreePos Full a -> TreePos Full a
+findNextN n loc
+    | n <= 0 = loc
+    | otherwise =
+        maybe loc (findNextN $ n - 1) (skipSame findNext loc)
+
+
+findPrevN :: Eq a => Int -> TreePos Full a -> TreePos Full a
+findPrevN n loc
+    | n <= 0 = loc
+    | otherwise =
+        maybe loc (findPrevN $ n - 1) (skipSame findPrev loc)
+
+
+
+findParent :: (a -> Bool) -> TreePos Full a -> Maybe (TreePos Full a)
+findParent p loc =
+    if p (label loc)
+        then Just loc
+        else parent loc >>= findParent p
+
+
+linearPos :: TreePos Full a -> Int
+linearPos =
+    rec 0
+  where
+    rec i loc = case findPrev loc of
+        Just loc' -> rec (i + 1) loc'
+        Nothing -> i
+
+
+
+skipSame
+    :: Eq a =>
+      (TreePos Full a -> Maybe (TreePos Full a)) ->
+      TreePos Full a ->
+      Maybe (TreePos Full a)
+skipSame next' loc =
+    case next' loc of
+        Nothing -> Nothing
+        Just loc' ->
+            if label loc' == label loc
+                then skipSame next' loc'
+                else Just loc'
diff --git a/src/Much/TreeView.hs b/src/Much/TreeView.hs
new file mode 100644
index 0000000..9487f74
--- /dev/null
+++ b/src/Much/TreeView.hs
@@ -0,0 +1,229 @@
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE RecordWildCards #-}
+
+
+module Much.TreeView
+    ( module Export
+    , getMessage
+    , getSearchTerm
+    , isTVMessage
+    , isTVSearchResult
+    , fromSearchResults
+    , fromMessageForest
+    , fromMessageTree
+    , loadSubForest
+    , unloadSubForest
+    , hasUnloadedSubForest
+    ) where
+
+
+import qualified Data.Text as T
+import Data.Tree
+import Notmuch
+import Notmuch.Message
+import Notmuch.SearchResult
+import Much.TreeView.Types as Export
+
+
+getMessage :: TreeView -> Maybe Message
+getMessage = \case
+    TVMessage m -> Just m
+    TVMessageHeaderField m _ -> Just m
+    TVMessagePart m _ -> Just m
+    TVMessageQuoteLine m _ _ _ -> Just m
+    TVMessageLine m _ _ _ -> Just m
+    _ -> Nothing
+
+
+getSearchTerm :: TreeView -> Maybe String
+getSearchTerm = \case
+    TVSearch term -> Just term
+    _ -> Nothing
+
+
+isTVMessage :: TreeView -> Bool
+isTVMessage = \case
+    TVMessage _ -> True
+    _ -> False
+
+
+isTVMessagePart :: TreeView -> Bool
+isTVMessagePart = \case
+    TVMessagePart _ _ -> True
+    _ -> False
+
+
+isTVSearchResult :: TreeView -> Bool
+isTVSearchResult (TVSearchResult _) = True
+isTVSearchResult _ = False
+
+
+fromSearchResults :: String -> [SearchResult] -> Tree TreeView
+fromSearchResults query =
+    Node (TVSearch query) . map (\r -> Node (TVSearchResult r) [])
+
+
+fromMessageForest :: Forest Message -> Forest TreeView
+fromMessageForest = map fromMessageTree
+
+
+fromMessageTree :: Tree Message -> Tree TreeView
+fromMessageTree (Node m ms) =
+    Node (TVMessage m)
+         (xconvHead m <> xconvBody m <> map fromMessageTree ms)
+
+
+xconvHead :: Message -> Forest TreeView
+xconvHead m =
+    map conv [ "From", "To" ]
+    -- TODO add Subject if it differs from thread subject
+  where
+    conv k =
+      Node (TVMessageHeaderField m k) []
+
+
+xconvBody :: Message -> Forest TreeView
+xconvBody m = map (xconvPart m) (messageBody m)
+
+
+xconvPart :: Message -> MessagePart -> Tree TreeView
+xconvPart m p =
+    Node (TVMessagePart m p) contents
+  where
+    contents = case partContent p of
+        ContentText t ->
+            zipWith (curry $ xconvLine m p) [0..] (T.lines t)
+        ContentMultipart parts ->
+            map (xconvPart m) parts
+        ContentMsgRFC822 _ ->
+            []
+
+
+xconvLine
+  :: Message -> MessagePart -> (LineNr, T.Text) -> Tree TreeView
+xconvLine m p (i, s) =
+    Node (ctor m p i $ T.unpack s) []
+  where
+    ctor =
+        if isQuoteLine s
+            then TVMessageQuoteLine
+            else TVMessageLine
+
+
+isQuoteLine :: T.Text -> Bool
+isQuoteLine s0 = do
+    let s = T.stripStart s0
+
+    -- /^\s*>/
+    not (T.null s) && T.head s == '>'
+
+
+--
+-- Loading / Unloading
+--
+
+
+loadSubForest :: TreeView -> IO (Either String (Forest TreeView))
+loadSubForest = \case
+    TVMessage m ->
+        Right
+            . unloadPartsWithFilename
+            . map unloadReadSubForests
+            . concatMap subForest
+            . fromMessageForest
+            . findFirsts messageMatch
+            <$> notmuchShow (termFromMessage m)
+
+    TVMessagePart m mp ->
+        -- TODO parse --format=raw
+        notmuchShowPart (termFromMessage m) (partID mp) >>= return . \case
+            Left e -> Left $ show e
+            Right mp' ->
+                Right
+                    . unloadPartsWithFilename
+                    . subForest
+                    $ xconvPart m mp'
+
+    TVSearchResult sr ->
+        Right
+            . unloadPartsWithFilename
+            . map unloadReadSubForests
+            . fromMessageForest
+            <$> notmuchShow (termFromSearchResult sr)
+
+    TVSearch s ->
+        Right
+            . subForest
+            . fromSearchResults s
+            . either error id
+            <$> Notmuch.search [s]
+
+    _ ->
+        return $ Right []
+
+  where
+    termFromMessage = unMessageID . messageId
+    termFromSearchResult = unThreadID . searchThread
+
+
+unloadSubForest :: Tree TreeView -> Forest TreeView
+unloadSubForest t = case rootLabel t of
+    TVMessage _ ->
+        filter (isTVMessage . rootLabel) $ subForest t
+    TVMessagePart _ _ ->
+        filter (isTVMessagePart . rootLabel) $ subForest t
+    _ ->
+        []
+
+
+hasUnloadedSubForest :: Tree TreeView -> Bool
+hasUnloadedSubForest t = case rootLabel t of
+    TVMessage _ ->
+        all (isTVMessage . rootLabel) $ subForest t
+    TVMessagePart _ _ ->
+        all (isTVMessagePart . rootLabel) $ subForest t
+    _ ->
+        null $ subForest t
+
+
+unloadReadSubForests :: Tree TreeView -> Tree TreeView
+unloadReadSubForests t = case rootLabel t of
+    TVMessage m | "unread" `notElem` messageTags m ->
+        t { subForest =
+                map unloadReadSubForests $
+                filter (isTVMessage . rootLabel) $
+                subForest t
+          }
+    _ ->
+        t { subForest =
+                map unloadReadSubForests $
+                subForest t
+          }
+
+
+unloadPartsWithFilename :: Forest TreeView -> Forest TreeView
+unloadPartsWithFilename =
+    map rewriteTree
+  where
+    f x@Node{..} = case rootLabel of
+      TVMessagePart _ mp ->
+          case partContentFilename mp of
+              Nothing -> x
+              Just _ ->
+                  x { subForest = [] }
+      _ -> x
+
+    rewriteTree x =
+        let x' = f x
+        in x' { subForest = map rewriteTree $ subForest x' }
+
+
+findFirsts :: (a -> Bool) -> Forest a -> Forest a
+findFirsts p =
+    concatMap rec
+  where
+    rec t@Node{..} =
+      if p rootLabel
+          then [t]
+          else concatMap rec subForest
diff --git a/src/Much/TreeView/Types.hs b/src/Much/TreeView/Types.hs
new file mode 100644
index 0000000..6e4ac6b
--- /dev/null
+++ b/src/Much/TreeView/Types.hs
@@ -0,0 +1,63 @@
+{-# LANGUAGE LambdaCase #-}
+
+module Much.TreeView.Types where
+
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Text as T
+import Notmuch.Message
+import Notmuch.SearchResult
+
+
+type LineNr = Int
+
+
+data TreeView
+    = TVMessage Message
+    | TVMessageHeaderField Message (CI.CI T.Text)
+    | TVMessagePart Message MessagePart
+    | TVMessageQuoteLine Message MessagePart LineNr String
+    | TVMessageLine Message MessagePart LineNr String
+    | TVSearch String
+    | TVSearchResult SearchResult
+  deriving (Show)
+
+
+instance Eq TreeView where
+    x1 == x2 = treeViewId x1 == treeViewId x2
+
+
+data TreeViewId
+    = TVIDMessage T.Text
+    | TVIDMessageHeaderField T.Text T.Text
+    | TVIDMessagePart T.Text Int
+    | TVIDMessageLine T.Text Int Int
+    | TVIDSearch T.Text
+    | TVIDSearchResult T.Text
+  deriving (Eq,Show)
+
+
+treeViewId :: TreeView -> TreeViewId
+treeViewId = \case
+    TVMessage m ->
+        TVIDMessage (fromMessage m)
+
+    TVMessageHeaderField m mhf ->
+        TVIDMessageHeaderField (fromMessage m) (CI.foldedCase mhf)
+
+    TVMessagePart m mp ->
+        TVIDMessagePart (fromMessage m) (partID mp)
+
+    TVMessageLine m mp lineNr _ ->
+        TVIDMessageLine (fromMessage m) (partID mp) lineNr
+
+    TVMessageQuoteLine m mp lineNr _ ->
+        TVIDMessageLine (fromMessage m) (partID mp) lineNr
+
+    TVSearch s ->
+        TVIDSearch (T.pack s)
+
+    TVSearchResult sr ->
+        TVIDSearchResult (T.pack $ unThreadID $ searchThread sr)
+
+  where
+    fromMessage = T.pack . unMessageID . messageId
diff --git a/src/Much/TreeZipperUtils.hs b/src/Much/TreeZipperUtils.hs
new file mode 100644
index 0000000..5257c2f
--- /dev/null
+++ b/src/Much/TreeZipperUtils.hs
@@ -0,0 +1,52 @@
+module Much.TreeZipperUtils where
+
+import Data.Maybe
+import Data.Tree
+import Data.Tree.Zipper
+
+-- Return loc (as parent-like structure) and  parents.
+path :: TreePos Full a -> [(Forest a, a, Forest a)]
+path loc = toParent loc : parents loc
+
+-- Return parent stack compatible form of loc.
+toParent :: TreePos Full a -> (Forest a, a, Forest a)
+toParent loc = (before loc, label loc, after loc)
+
+
+modifyFirstParentLabelWhere
+    :: (a -> Bool)
+    -> (a -> a)
+    -> TreePos Full a
+    -> TreePos Full a
+modifyFirstParentLabelWhere p f loc0 =
+    case parent loc0 of
+        Nothing -> loc0
+        Just loc0' -> go (byChildIndex loc0) loc0'
+  where
+
+    go rewind loc =
+        if p (label loc)
+            then
+                rewind (modifyLabel f loc)
+            else
+                case parent loc of
+                    Nothing -> rewind loc
+                    Just loc' ->
+                        go (rewind . byChildIndex loc) loc'
+
+    -- generator for a rewind step
+    byChildIndex :: TreePos Full a -> (TreePos Full a -> TreePos Full a)
+    byChildIndex loc =
+        -- The use of fromJust is safe here because we're only modifying
+        -- labels and not the tree structure and thus the index is valid.
+        fromJust . childAt (childIndex loc)
+
+
+-- XXX This could be named more general, like countPrevSiblings?
+-- XXX Can we kill the recursion?
+childIndex :: TreePos Full a -> Int
+childIndex =
+    go 0
+  where
+    go index =
+        maybe index (go $ index + 1) . prev
diff --git a/src/Much/Utils.hs b/src/Much/Utils.hs
new file mode 100644
index 0000000..80615fc
--- /dev/null
+++ b/src/Much/Utils.hs
@@ -0,0 +1,28 @@
+module Much.Utils where
+
+import Control.Exception
+import System.Directory
+import System.IO
+
+
+withTempFile :: FilePath -> String -> ((FilePath, Handle) -> IO a) -> IO a
+withTempFile tmpdir template =
+    bracket (openTempFile tmpdir template) (removeFile . fst)
+
+
+mintercalate :: Monoid b => b -> [b] -> b
+mintercalate c (h:t) = foldl (\acc x -> acc <> c <> x) h t
+mintercalate _ [] = mempty
+
+
+padl :: Int -> a -> [a] -> [a]
+padl n c s =
+    if length s < n
+        then padl n c (c:s)
+        else s
+
+padr :: Int -> a -> [a] -> [a]
+padr n c s =
+    if length s < n
+        then padr n c (s ++ [c])
+        else s
diff --git a/src/Network/Mail/Mime.hs b/src/Network/Mail/Mime.hs
new file mode 100644
index 0000000..8fd9fe1
--- /dev/null
+++ b/src/Network/Mail/Mime.hs
@@ -0,0 +1,575 @@
+{-# LANGUAGE CPP, OverloadedStrings #-}
+module Network.Mail.Mime
+    ( -- * Datatypes
+      Boundary (..)
+    , Mail (..)
+    , emptyMail
+    , Address (..)
+    , Alternatives
+    , Part (..)
+    , Encoding (..)
+    , Headers
+      -- * Render a message
+    , renderMail
+    , renderMail'
+      -- * Sending messages
+    , sendmail
+    , sendmailCustom
+    , renderSendMail
+    , renderSendMailCustom
+      -- * High-level 'Mail' creation
+    , simpleMail
+    , simpleMail'
+    , simpleMailInMemory
+      -- * Utilities
+    , addPart
+    , addAttachment
+    , addAttachments
+    , addAttachmentBS
+    , addAttachmentsBS
+    , htmlPart
+    , plainPart
+    , randomString
+    , quotedPrintable
+    ) where
+
+import qualified Data.ByteString.Lazy as L
+import Blaze.ByteString.Builder.Char.Utf8
+import Blaze.ByteString.Builder
+import System.Random
+import Control.Arrow
+import System.Process
+import System.IO
+import System.Exit
+import System.FilePath (takeFileName)
+import qualified Data.ByteString.Base64 as Base64
+import Control.Monad ((<=<), foldM)
+import Control.Exception (throwIO, ErrorCall (ErrorCall))
+import Data.List (intersperse)
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LT
+import Data.ByteString.Char8 ()
+import Data.Bits ((.&.), shiftR)
+import Data.Char (isAscii)
+import Data.Word (Word8)
+import qualified Data.ByteString as S
+import Data.Text (Text)
+import qualified Data.Text as T
+import qualified Data.Text.Encoding as TE
+
+-- | Generates a random sequence of alphanumerics of the given length.
+randomString :: RandomGen d => Int -> d -> (String, d)
+randomString len =
+    first (map toChar) . sequence' (replicate len (randomR (0, 61)))
+  where
+    sequence' [] g = ([], g)
+    sequence' (f:fs) g =
+        let (f', g') = f g
+            (fs', g'') = sequence' fs g'
+         in (f' : fs', g'')
+    toChar i
+        | i < 26 = toEnum $ i + fromEnum 'A'
+        | i < 52 = toEnum $ i + fromEnum 'a' - 26
+        | otherwise = toEnum $ i + fromEnum '0' - 52
+
+-- | MIME boundary between parts of a message.
+newtype Boundary = Boundary { unBoundary :: Text }
+  deriving (Eq, Show)
+instance Random Boundary where
+    randomR = const random
+    random = first (Boundary . T.pack) . randomString 10
+
+-- | An entire mail message.
+data Mail = Mail
+    { mailFrom :: Address
+    , mailTo   :: [Address]
+    , mailCc   :: [Address]
+    , mailBcc  :: [Address]
+    -- | Other headers, excluding from, to, cc and bcc.
+    , mailHeaders :: Headers
+    -- | A list of different sets of alternatives. As a concrete example:
+    --
+    -- > mailParts = [ [textVersion, htmlVersion], [attachment1], [attachment1]]
+    --
+    -- Make sure when specifying alternatives to place the most preferred
+    -- version last.
+    , mailParts :: [Alternatives]
+    }
+  deriving Show
+
+-- | A mail message with the provided 'from' address and no other
+-- fields filled in.
+emptyMail :: Address -> Mail
+emptyMail from = Mail
+    { mailFrom    = from
+    , mailTo      = []
+    , mailCc      = []
+    , mailBcc     = []
+    , mailHeaders = []
+    , mailParts   = []
+    }
+
+data Address = Address
+    { addressName  :: Maybe Text
+    , addressEmail :: Text
+    }
+  deriving (Eq, Show)
+
+-- | How to encode a single part. You should use 'Base64' for binary data.
+data Encoding = None | Base64 | QuotedPrintableText | QuotedPrintableBinary
+  deriving (Eq, Show)
+
+-- | Multiple alternative representations of the same data. For example, you
+-- could provide a plain-text and HTML version of a message.
+type Alternatives = [Part]
+
+-- | A single part of a multipart message.
+data Part = Part
+    { partType :: Text -- ^ content type
+    , partEncoding :: Encoding
+    -- | The filename for this part, if it is to be sent with an attachemnt
+    -- disposition.
+    , partFilename :: Maybe Text
+    , partHeaders :: Headers
+    , partContent :: L.ByteString
+    }
+  deriving (Eq, Show)
+
+type Headers = [(S.ByteString, Text)]
+type Pair = (Headers, Builder)
+
+partToPair :: Part -> Pair
+partToPair (Part contentType encoding disposition headers content) =
+    (headers', builder)
+  where
+    headers' =
+        (:) ("Content-Type", contentType)
+      $ (case encoding of
+            None -> id
+            Base64 -> (:) ("Content-Transfer-Encoding", "base64")
+            QuotedPrintableText ->
+                (:) ("Content-Transfer-Encoding", "quoted-printable")
+            QuotedPrintableBinary ->
+                (:) ("Content-Transfer-Encoding", "quoted-printable"))
+      $ (case disposition of
+            Nothing -> id
+            Just fn ->
+                (:) ("Content-Disposition", "attachment; filename="
+                                            `T.append` fn))
+      headers
+    builder =
+        case encoding of
+            None -> fromWriteList writeByteString $ L.toChunks content
+            Base64 -> base64 content
+            QuotedPrintableText -> quotedPrintable True content
+            QuotedPrintableBinary -> quotedPrintable False content
+
+showPairs :: RandomGen g
+          => Text -- ^ multipart type, eg mixed, alternative
+          -> [Pair]
+          -> g
+          -> (Pair, g)
+showPairs _ [] _ = error "renderParts called with null parts"
+showPairs _ [pair] gen = (pair, gen)
+showPairs mtype parts gen =
+    ((headers, builder), gen')
+  where
+    (Boundary b, gen') = random gen
+    headers =
+        [ ("Content-Type", T.concat
+            [ "multipart/"
+            , mtype
+            , "; boundary=\""
+            , b
+            , "\""
+            ])
+        ]
+    builder = mconcat
+        [ mconcat $ intersperse (fromByteString "\r\n")
+                  $ map (showBoundPart $ Boundary b) parts
+        , showBoundEnd $ Boundary b
+        ]
+
+-- | Render a 'Mail' with a given 'RandomGen' for producing boundaries.
+renderMail :: RandomGen g => g -> Mail -> (L.ByteString, g)
+renderMail g0 (Mail from to cc bcc headers parts) =
+    (toLazyByteString builder, g'')
+  where
+    addressHeaders = map showAddressHeader [("From", [from]), ("To", to), ("Cc", cc), ("Bcc", bcc)]
+    pairs = map (map partToPair) parts
+    (pairs', g') = helper g0 $ map (showPairs "alternative") pairs
+    helper :: g -> [g -> (x, g)] -> ([x], g)
+    helper g [] = ([], g)
+    helper g (x:xs) =
+        let (b, g_) = x g
+            (bs, g__) = helper g_ xs
+         in (b : bs, g__)
+    ((finalHeaders, finalBuilder), g'') = showPairs "mixed" pairs' g'
+    builder = mconcat
+        [ mconcat addressHeaders
+        , mconcat $ map showHeader headers
+        , showHeader ("MIME-Version", "1.0")
+        , mconcat $ map showHeader finalHeaders
+        , fromByteString "\r\n"
+        , finalBuilder
+        ]
+
+showHeader :: (S.ByteString, Text) -> Builder
+showHeader (k, v) = mconcat
+    [ fromByteString k
+    , fromByteString ": "
+    , encodeIfNeeded v
+    , fromByteString "\r\n"
+    ]
+
+showAddressHeader :: (S.ByteString, [Address]) -> Builder
+showAddressHeader (k, as) =
+  if null as
+  then mempty
+  else mconcat
+    [ fromByteString k
+    , fromByteString ": "
+    , mconcat (intersperse (fromByteString ", ") . map showAddress $ as)
+    , fromByteString "\r\n"
+    ]
+
+-- |
+--
+-- Since 0.4.3
+showAddress :: Address -> Builder
+showAddress a = mconcat
+    [ maybe mempty ((`mappend` fromByteString " ") . encodedWord) (addressName a)
+    , fromByteString "<"
+    , fromText (addressEmail a)
+    , fromByteString ">"
+    ]
+
+showBoundPart :: Boundary -> (Headers, Builder) -> Builder
+showBoundPart (Boundary b) (headers, content) = mconcat
+    [ fromByteString "--"
+    , fromText b
+    , fromByteString "\r\n"
+    , mconcat $ map showHeader headers
+    , fromByteString "\r\n"
+    , content
+    ]
+
+showBoundEnd :: Boundary -> Builder
+showBoundEnd (Boundary b) = mconcat
+    [ fromByteString "\r\n--"
+    , fromText b
+    , fromByteString "--"
+    ]
+
+-- | Like 'renderMail', but generates a random boundary.
+renderMail' :: Mail -> IO L.ByteString
+renderMail' m = do
+    g <- getStdGen
+    let (lbs, g') = renderMail g m
+    setStdGen g'
+    return lbs
+
+-- | Send a fully-formed email message via the default sendmail
+-- executable with default options.
+sendmail :: L.ByteString -> IO ()
+sendmail = sendmailCustom sendmailPath ["-t"]
+
+sendmailPath :: String
+#ifdef MIME_MAIL_SENDMAIL_PATH
+sendmailPath = MIME_MAIL_SENDMAIL_PATH
+#else
+sendmailPath = "/usr/sbin/sendmail"
+#endif
+
+-- | Render an email message and send via the default sendmail
+-- executable with default options.
+renderSendMail :: Mail -> IO ()
+renderSendMail = sendmail <=< renderMail'
+
+-- | Send a fully-formed email message via the specified sendmail
+-- executable with specified options.
+sendmailCustom :: FilePath        -- ^ sendmail executable path
+                  -> [String]     -- ^ sendmail command-line options
+                  -> L.ByteString -- ^ mail message as lazy bytestring
+                  -> IO ()
+sendmailCustom sm opts lbs = do
+    (Just hin, _, _, phandle) <- createProcess $
+                                 (proc sm opts) { std_in = CreatePipe }
+    L.hPut hin lbs
+    hClose hin
+    exitCode <- waitForProcess phandle
+    case exitCode of
+        ExitSuccess -> return ()
+        _ -> throwIO $ ErrorCall ("sendmail exited with error code " ++ show exitCode)
+
+-- | Render an email message and send via the specified sendmail
+-- executable with specified options.
+renderSendMailCustom :: FilePath    -- ^ sendmail executable path
+                        -> [String] -- ^ sendmail command-line options
+                        -> Mail     -- ^ mail to render and send
+                        -> IO ()
+renderSendMailCustom sm opts = sendmailCustom sm opts <=< renderMail'
+
+-- FIXME usage of FilePath below can lead to issues with filename encoding
+
+-- | A simple interface for generating an email with HTML and plain-text
+-- alternatives and some file attachments.
+--
+-- Note that we use lazy IO for reading in the attachment contents.
+simpleMail :: Address -- ^ to
+           -> Address -- ^ from
+           -> Text -- ^ subject
+           -> LT.Text -- ^ plain body
+           -> LT.Text -- ^ HTML body
+           -> [(Text, FilePath)] -- ^ content type and path of attachments
+           -> IO Mail
+simpleMail to from subject plainBody htmlBody attachments =
+      addAttachments attachments
+    . addPart [plainPart plainBody, htmlPart htmlBody]
+    $ mailFromToSubject from to subject
+
+-- | A simple interface for generating an email with only plain-text body.
+simpleMail' :: Address -- ^ to
+            -> Address -- ^ from
+            -> Text -- ^ subject
+            -> LT.Text -- ^ body
+            -> Mail
+simpleMail' to from subject body = addPart [plainPart body]
+                                 $ mailFromToSubject from to subject
+
+-- | A simple interface for generating an email with HTML and plain-text
+-- alternatives and some 'ByteString' attachments.
+--
+-- Since 0.4.7
+simpleMailInMemory :: Address -- ^ to
+           -> Address -- ^ from
+           -> Text -- ^ subject
+           -> LT.Text -- ^ plain body
+           -> LT.Text -- ^ HTML body
+           -> [(Text, Text, L.ByteString)] -- ^ content type, file name and contents of attachments
+           -> Mail
+simpleMailInMemory to from subject plainBody htmlBody attachments =
+      addAttachmentsBS attachments
+    . addPart [plainPart plainBody, htmlPart htmlBody]
+    $ mailFromToSubject from to subject
+
+mailFromToSubject :: Address -- ^ from
+                  -> Address -- ^ to
+                  -> Text -- ^ subject
+                  -> Mail
+mailFromToSubject from to subject =
+    (emptyMail from) { mailTo = [to]
+                     , mailHeaders = [("Subject", subject)]
+                     }
+
+-- | Add an 'Alternative' to the 'Mail's parts.
+--
+-- To e.g. add a plain text body use
+-- > addPart [plainPart body] (emptyMail from)
+addPart :: Alternatives -> Mail -> Mail
+addPart alt mail = mail { mailParts = alt : mailParts mail }
+
+-- | Construct a UTF-8-encoded plain-text 'Part'.
+plainPart :: LT.Text -> Part
+plainPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body
+  where cType = "text/plain; charset=utf-8"
+
+-- | Construct a UTF-8-encoded html 'Part'.
+htmlPart :: LT.Text -> Part
+htmlPart body = Part cType QuotedPrintableText Nothing [] $ LT.encodeUtf8 body
+  where cType = "text/html; charset=utf-8"
+
+-- | Add an attachment from a file and construct a 'Part'.
+addAttachment :: Text -> FilePath -> Mail -> IO Mail
+addAttachment ct fn mail = do
+    content <- L.readFile fn
+    let part = Part ct Base64 (Just $ T.pack (takeFileName fn)) [] content
+    return $ addPart [part] mail
+
+addAttachments :: [(Text, FilePath)] -> Mail -> IO Mail
+addAttachments xs mail = foldM fun mail xs
+  where fun m (c, f) = addAttachment c f m
+
+-- | Add an attachment from a 'ByteString' and construct a 'Part'.
+--
+-- Since 0.4.7
+addAttachmentBS :: Text -- ^ content type
+                -> Text -- ^ file name
+                -> L.ByteString -- ^ content
+                -> Mail -> Mail
+addAttachmentBS ct fn content mail =
+    let part = Part ct Base64 (Just fn) [] content
+    in addPart [part] mail
+
+-- |
+-- Since 0.4.7
+addAttachmentsBS :: [(Text, Text, L.ByteString)] -> Mail -> Mail
+addAttachmentsBS xs mail = foldl fun mail xs
+  where fun m (ct, fn, content) = addAttachmentBS ct fn content m
+
+data QP = QPPlain S.ByteString
+        | QPNewline
+        | QPTab
+        | QPSpace
+        | QPEscape S.ByteString
+
+data QPC = QPCCR
+         | QPCLF
+         | QPCSpace
+         | QPCTab
+         | QPCPlain
+         | QPCEscape
+    deriving Eq
+
+toQP :: Bool -- ^ text?
+     -> L.ByteString
+     -> [QP]
+toQP isText =
+    go
+  where
+    go lbs =
+        case L.uncons lbs of
+            Nothing -> []
+            Just (c, rest) ->
+                case toQPC c of
+                    QPCCR -> go rest
+                    QPCLF -> QPNewline : go rest
+                    QPCSpace -> QPSpace : go rest
+                    QPCTab -> QPTab : go rest
+                    QPCPlain ->
+                        let (x, y) = L.span ((== QPCPlain) . toQPC) lbs
+                         in QPPlain (toStrict x) : go y
+                    QPCEscape ->
+                        let (x, y) = L.span ((== QPCEscape) . toQPC) lbs
+                         in QPEscape (toStrict x) : go y
+
+    toStrict = S.concat . L.toChunks
+
+    toQPC :: Word8 -> QPC
+    toQPC 13 | isText = QPCCR
+    toQPC 10 | isText = QPCLF
+    toQPC 9 = QPCTab
+    toQPC 0x20 = QPCSpace
+    toQPC 61 = QPCEscape
+    toQPC w
+        | 33 <= w && w <= 126 = QPCPlain
+        | otherwise = QPCEscape
+
+buildQPs :: [QP] -> Builder
+buildQPs =
+    go (0 :: Int)
+  where
+    go _ [] = mempty
+    go currLine (qp:qps) =
+        case qp of
+            QPNewline -> copyByteString "\r\n" `mappend` go 0 qps
+            QPTab -> wsHelper (copyByteString "=09") (fromWord8 9)
+            QPSpace -> wsHelper (copyByteString "=20") (fromWord8 0x20)
+            QPPlain bs ->
+                let toTake = 75 - currLine
+                    (x, y) = S.splitAt toTake bs
+                    rest
+                        | S.null y = qps
+                        | otherwise = QPPlain y : qps
+                 in helper (S.length x) (copyByteString x) (S.null y) rest
+            QPEscape bs ->
+                let toTake = (75 - currLine) `div` 3
+                    (x, y) = S.splitAt toTake bs
+                    rest
+                        | S.null y = qps
+                        | otherwise = QPEscape y : qps
+                 in if toTake == 0
+                        then copyByteString "=\r\n" `mappend` go 0 (qp:qps)
+                        else helper (S.length x * 3) (escape x) (S.null y) rest
+      where
+        escape =
+            S.foldl' add mempty
+          where
+            add builder w =
+                builder `mappend` escaped
+              where
+                escaped = fromWord8 61 `mappend` hex (w `shiftR` 4)
+                                       `mappend` hex (w .&. 15)
+
+        helper added builder noMore rest =
+            builder' `mappend` go newLine rest
+           where
+             (newLine, builder')
+                | not noMore || (added + currLine) >= 75 =
+                    (0, builder `mappend` copyByteString "=\r\n")
+                | otherwise = (added + currLine, builder)
+
+        wsHelper enc raw
+            | null qps =
+                if currLine <= 73
+                    then enc
+                    else copyByteString "\r\n=" `mappend` enc
+            | otherwise = helper 1 raw (currLine < 76) qps
+
+-- | The first parameter denotes whether the input should be treated as text.
+-- If treated as text, then CRs will be stripped and LFs output as CRLFs. If
+-- binary, then CRs and LFs will be escaped.
+quotedPrintable :: Bool -> L.ByteString -> Builder
+quotedPrintable isText = buildQPs . toQP isText
+
+hex :: Word8 -> Builder
+hex x
+    | x < 10 = fromWord8 $ x + 48
+    | otherwise = fromWord8 $ x + 55
+
+encodeIfNeeded :: Text -> Builder
+encodeIfNeeded t =
+  if needsEncodedWord t
+  then encodedWord t
+  else fromText t
+
+needsEncodedWord :: Text -> Bool
+needsEncodedWord = not . T.all isAscii
+
+encodedWord :: Text -> Builder
+encodedWord t = mconcat
+    [ fromByteString "=?utf-8?Q?"
+    , S.foldl' go mempty $ TE.encodeUtf8 t
+    , fromByteString "?="
+    ]
+  where
+    go front w = front `mappend` go' w
+    go' 32 = fromWord8 95 -- space
+    go' 95 = go'' 95 -- _
+    go' 63 = go'' 63 -- ?
+    go' 61 = go'' 61 -- =
+
+    -- The special characters from RFC 2822. Not all of these always give
+    -- problems, but at least @[];"<>, gave problems with some mail servers
+    -- when used in the 'name' part of an address.
+    go' 34 = go'' 34 -- "
+    go' 40 = go'' 40 -- (
+    go' 41 = go'' 41 -- )
+    go' 44 = go'' 44 -- ,
+    go' 46 = go'' 46 -- .
+    go' 58 = go'' 58 -- ;
+    go' 59 = go'' 59 -- ;
+    go' 60 = go'' 60 -- <
+    go' 62 = go'' 62 -- >
+    go' 64 = go'' 64 -- @
+    go' 91 = go'' 91 -- [
+    go' 92 = go'' 92 -- \
+    go' 93 = go'' 93 -- ]
+    go' w
+        | 33 <= w && w <= 126 = fromWord8 w
+        | otherwise = go'' w
+    go'' w = fromWord8 61 `mappend` hex (w `shiftR` 4)
+                          `mappend` hex (w .&. 15)
+
+-- 57 bytes, when base64-encoded, becomes 76 characters.
+-- Perform the encoding 57-bytes at a time, and then append a newline.
+base64 :: L.ByteString -> Builder
+base64 lbs
+    | L.null lbs = mempty
+    | otherwise = fromByteString x64 `mappend`
+                  fromByteString "\r\n" `mappend`
+                  base64 y
+  where
+    (x', y) = L.splitAt 57 lbs
+    x = S.concat $ L.toChunks x'
+    x64 = Base64.encode x
diff --git a/src/Notmuch.hs b/src/Notmuch.hs
new file mode 100644
index 0000000..f86bd3d
--- /dev/null
+++ b/src/Notmuch.hs
@@ -0,0 +1,200 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Notmuch where
+
+import qualified Data.ByteString.Lazy as LBS
+import qualified Data.ByteString.Lazy.Char8 as LBS8
+import qualified Data.Text.Lazy as LT
+import qualified Data.Text.Lazy.Encoding as LT
+import qualified Network.Mail.Mime as M
+import Control.Concurrent
+import Control.DeepSeq (rnf)
+import Control.Exception
+import Data.Aeson.Extends
+import Data.Tree
+import Notmuch.Class
+import Notmuch.Message
+import Notmuch.SearchResult
+import Much.ParseMail (readMail)
+import System.Exit
+import System.IO
+import System.Process
+import Much.TagUtils
+
+
+-- | Fork a thread while doing something else, but kill it if there's an
+-- exception.
+--
+-- This is important in the cases above because we want to kill the thread
+-- that is holding the Handle lock, because when we clean up the process we
+-- try to close that handle, which could otherwise deadlock.
+--
+withForkWait :: IO () -> (IO () ->  IO a) -> IO a
+withForkWait async body = do
+  waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ()))
+  mask $ \restore -> do
+    tid <- forkIO $ try (restore async) >>= putMVar waitVar
+    let wait = takeMVar waitVar >>= either throwIO return
+    restore (body wait) `onException` killThread tid
+
+
+
+
+notmuch :: [String] -> IO LBS.ByteString
+notmuch args = do
+    (_, Just hout, _, ph) <- createProcess (proc "notmuch" args)
+                                          { std_out = CreatePipe }
+    output <- LBS.hGetContents hout
+
+
+    withForkWait (evaluate $ rnf output) $ \waitOut -> do
+
+      ---- now write any input
+      --unless (null input) $
+      --  ignoreSigPipe $ hPutStr inh input
+      -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
+      --ignoreSigPipe $ hClose inh
+
+      -- wait on the output
+      waitOut
+      hClose hout
+
+    -- wait on the process
+    _ex <- waitForProcess ph
+    --return (ex, output)
+
+    --case ex of
+    --    ExitSuccess   -> return output
+    --    ExitFailure r -> processFailedException "readProcess" cmd args r
+
+    return output
+
+
+notmuch' :: [String] -> IO (ExitCode, LBS.ByteString, LBS.ByteString)
+notmuch' args = do
+    (_, Just hout, Just herr, ph) <-
+        createProcess (proc "notmuch" args)
+            { std_out = CreatePipe
+            , std_err = CreatePipe
+            }
+    out <- LBS.hGetContents hout
+    err <- LBS.hGetContents herr
+
+    withForkWait (evaluate $ rnf out) $ \waitOut -> do
+        withForkWait (evaluate $ rnf err) $ \waitErr -> do
+
+          ---- now write any input
+          --unless (null input) $
+          --  ignoreSigPipe $ hPutStr inh input
+          -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
+          --ignoreSigPipe $ hClose inh
+
+          -- wait on the output
+          waitOut
+          waitErr
+          hClose hout
+          hClose herr
+
+    -- wait on the process
+    exitCode <- waitForProcess ph
+
+    return (exitCode, out, err)
+
+
+notmuchWithInput
+    :: [String]
+    -> LBS.ByteString
+    -> IO (ExitCode, LBS.ByteString, LBS.ByteString)
+notmuchWithInput args input = do
+    (Just hin, Just hout, Just herr, ph) <-
+        createProcess (proc "notmuch" args)
+            { std_in = CreatePipe
+            , std_out = CreatePipe
+            , std_err = CreatePipe
+            }
+    LBS.hPut hin input
+    hClose hin
+
+    out <- LBS.hGetContents hout
+    err <- LBS.hGetContents herr
+
+    withForkWait (evaluate $ rnf out) $ \waitOut -> do
+        withForkWait (evaluate $ rnf err) $ \waitErr -> do
+
+          ---- now write any input
+          --unless (null input) $
+          --  ignoreSigPipe $ hPutStr inh input
+          -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE
+          --ignoreSigPipe $ hClose inh
+
+          -- wait on the output
+          waitOut
+          waitErr
+          hClose hout
+          hClose herr
+
+    -- wait on the process
+    exitCode <- waitForProcess ph
+
+    return (exitCode, out, err)
+
+
+search :: [String] -> IO (Either String [SearchResult])
+search args =
+    eitherDecodeLenient' <$>
+        notmuch ("search" : "--format=json" : "--format-version=2" : args)
+
+
+data ReplyTo = ToAll | ToSender
+instance Show ReplyTo where
+    show ToAll = "all"
+    show ToSender = "sender"
+
+--notmuchReply :: String -> IO (Either String [SearchResult])
+notmuchReply :: ReplyTo -> String -> IO LBS.ByteString
+notmuchReply replyTo term =
+    notmuch
+        [ "reply"
+        , "--reply-to=" ++ show replyTo
+        , term
+        ]
+ --       >>= return . eitherDecodeLenient'
+
+
+notmuchShow :: String -> IO (Forest Message)
+notmuchShow term = do
+    c' <- notmuch [ "show", "--format=json", "--format-version=2"
+                   , term ]
+    -- TODO why head?
+    return $ threadForest $ head $
+        either error id (eitherDecodeLenient' c')
+
+
+notmuchShowPart :: String -> Int -> IO (Either String MessagePart)
+notmuchShowPart term partId = do
+    -- TODO handle partId == 0 and partId > N
+    (exitCode, out, err) <-
+        notmuch' [ "show", "--format=json", "--format-version=2"
+                 , "--part=" <> show partId
+                 , term ]
+    return $ case exitCode of
+        ExitSuccess -> eitherDecodeLenient' out
+        _ -> Left $ show exitCode <> ": " <> LBS8.unpack err
+
+
+notmuchShowMail :: String -> IO (Either String M.Mail)
+notmuchShowMail term =
+    notmuch' [ "show", "--format=raw", "--format-version=2", term ]
+    >>= return . \case
+      (ExitSuccess, out, _) ->
+          case LT.decodeUtf8' out of
+              Right x -> Right (readMail $ LT.toStrict x)
+              Left ex -> Left $ "meh" ++ show ex
+      (exitCode, _, err) ->
+          Left $ "notmuch failed with exit code " ++ show exitCode ++
+                 ": " ++ LBS8.unpack err
+
+
+notmuchTag :: HasNotmuchId a => [TagOp] -> a -> IO ()
+notmuchTag tagOps x =
+    notmuch ("tag" : tagOpsToArgs tagOps ++ [notmuchId x]) >> return ()
diff --git a/src/Notmuch/Class.hs b/src/Notmuch/Class.hs
new file mode 100644
index 0000000..2d2b416
--- /dev/null
+++ b/src/Notmuch/Class.hs
@@ -0,0 +1,4 @@
+module Notmuch.Class where
+
+class HasNotmuchId a where
+    notmuchId :: a -> String
diff --git a/src/Notmuch/Message.hs b/src/Notmuch/Message.hs
new file mode 100644
index 0000000..d08be39
--- /dev/null
+++ b/src/Notmuch/Message.hs
@@ -0,0 +1,123 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Notmuch.Message where
+
+import Data.Aeson
+import Data.Aeson.Types (Parser)
+import Data.Time.Calendar
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
+import Notmuch.Class
+import qualified Data.Text as T
+import qualified Data.Map as M
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Vector as V
+
+import qualified Data.Tree as TR
+
+
+newtype MessageID = MessageID { unMessageID :: String }
+  deriving (Show, Read, Eq, FromJSON)
+
+type MessageHeaders = M.Map (CI.CI T.Text) T.Text
+
+data MessageContent = ContentText T.Text
+                    | ContentMultipart [MessagePart]
+                    | ContentMsgRFC822 [(MessageHeaders, [MessagePart])]
+  deriving (Show)
+
+data MessagePart = MessagePart {
+      partID :: Int
+    , partContentType :: CI.CI T.Text
+    , partContentCharset :: Maybe (CI.CI T.Text)
+    , partContentFilename :: Maybe T.Text
+    , partContent :: MessageContent
+}
+  deriving (Show)
+
+instance Eq MessagePart where
+    a == b = partID a == partID b
+
+
+contentSize :: MessageContent -> Int
+contentSize (ContentText text) = T.length text
+contentSize (ContentMultipart parts) = sum $ map (contentSize . partContent) parts
+contentSize (ContentMsgRFC822 xs) = sum $ map (sum . map (contentSize . partContent) . snd) xs
+
+
+parseRFC822 :: V.Vector Value -> Parser MessageContent
+parseRFC822 lst = ContentMsgRFC822 . V.toList <$> V.mapM p lst
+    where
+        p (Object o) = do h <- M.mapKeys CI.mk <$> o .: "headers"
+                          b <- o .: "body"
+                          return (h, b)
+        p _ = fail "Invalid rfc822 body"
+
+instance FromJSON MessagePart where
+    parseJSON (Object v) = do
+        i <- v .: "id"
+        t <- CI.mk . T.toLower <$> v .: "content-type"
+        x <- v .:? "content"
+        f <- v .:? "filename"
+        cs <- fmap CI.mk <$> v .:? "content-charset"
+        let ctype = CI.map (T.takeWhile (/= '/')) t
+        case (ctype, x) of
+            ("multipart", Just (Array _)) -> MessagePart i t cs f . ContentMultipart <$> v .: "content"
+            ("message", Just (Array lst)) | t == "message/rfc822" -> MessagePart i t cs f <$> parseRFC822 lst
+            (_, Just (String c)) -> return $ MessagePart i t cs f $ ContentText c
+            (_, Just _) -> return $ MessagePart i t cs f $ ContentText $ "Unknown content-type: " <> CI.original t
+            (_, Nothing) -> return $ MessagePart i t cs f $ ContentText ""
+
+    parseJSON x = fail $ "Error parsing part: " ++ show x
+
+
+data Message = Message {
+      messageId :: MessageID
+    , messageTime :: UTCTime
+    , messageHeaders :: MessageHeaders
+    , messageBody :: [MessagePart]
+    , messageExcluded :: Bool
+    , messageMatch :: Bool
+    , messageTags :: [T.Text]
+    , messageFilename :: FilePath
+}
+  deriving (Show)
+
+instance Eq Message where
+    a == b = messageId a == messageId b
+
+
+instance HasNotmuchId Message where
+    notmuchId = unMessageID . messageId
+
+
+instance FromJSON Message where
+    parseJSON (Object v) = Message <$> (MessageID . ("id:"<>) <$> v .: "id")
+                                   <*> (posixSecondsToUTCTime . fromInteger <$> v .: "timestamp")
+                                   <*> (M.mapKeys CI.mk <$> v .: "headers")
+                                   <*> v .: "body"
+                                   <*> v .: "excluded"
+                                   <*> v .: "match"
+                                   <*> v .: "tags"
+                                   <*> v .: "filename"
+    parseJSON (Array _) = return $ Message (MessageID "") defTime M.empty [] True False [] ""
+        where defTime = UTCTime (ModifiedJulianDay 0) 0
+    parseJSON x = fail $ "Error parsing message: " ++ show x
+
+hasTag :: T.Text -> Message -> Bool
+hasTag tag = (tag `elem`) . messageTags
+
+
+
+newtype Thread = Thread { threadForest :: TR.Forest Message }
+
+instance FromJSON Thread where
+    parseJSON (Array vs) = Thread <$> mapM parseTree (V.toList vs)
+    parseJSON _ = fail "Thread is not an array"
+
+parseTree :: Value -> Parser (TR.Tree Message)
+parseTree vs@(Array _) = do
+    (msg, Thread t) <- parseJSON vs
+    return $ TR.Node msg t
+parseTree _ = fail "Tree is not an array"
diff --git a/src/Notmuch/SearchResult.hs b/src/Notmuch/SearchResult.hs
new file mode 100644
index 0000000..a59fa9c
--- /dev/null
+++ b/src/Notmuch/SearchResult.hs
@@ -0,0 +1,61 @@
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE OverloadedStrings #-}
+module Notmuch.SearchResult where
+
+import Data.Aeson
+import Data.Text
+import Data.Time.Clock
+import Data.Time.Clock.POSIX
+import Notmuch.Class
+
+
+newtype ThreadID = ThreadID { unThreadID :: String }
+  deriving (Show,Read,Eq,FromJSON,ToJSON)
+
+
+-- | A single entry returned from the notmuch search command.
+data SearchResult = SearchResult {
+      searchThread :: ThreadID
+    , searchTime :: UTCTime
+    , searchDateRel :: Text
+    , searchSubject :: Text
+    , searchAuthors :: Text
+    , searchQuery :: [Maybe Text] -- TODO (Text, Maybe Text)
+    , searchTags :: [Text]
+    , searchMatched :: Int
+    , searchTotal :: Int
+    }
+  deriving (Show)
+
+
+instance Eq SearchResult where
+    s1 == s2 =
+        searchThread s1 == searchThread s2
+
+
+instance HasNotmuchId SearchResult where
+    notmuchId = unThreadID . searchThread
+
+
+instance FromJSON SearchResult where
+    parseJSON (Object v) = SearchResult <$> (ThreadID . ("thread:"++) <$> v .: "thread")
+                                        <*> (posixSecondsToUTCTime . fromInteger <$> v .: "timestamp")
+                                        <*> v .: "date_relative"
+                                        <*> v .:? "subject" .!= ""
+                                        <*> v .:? "authors" .!= ""
+                                        <*> v .:? "query" .!= []
+                                        <*> v .: "tags"
+                                        <*> v .: "matched"
+                                        <*> v .: "total"
+    parseJSON x = fail $ "Error parsing search: " ++ show x
+
+--instance ToJSON SearchResult where
+--    toJSON s = object [ "thread" .= searchThread s
+--                      , "time" .= searchTime s
+--                      , "date_relative" .= searchDateRel s
+--                      , "subject" .= searchSubject s
+--                      , "authors" .= searchAuthors s
+--                      , "tags" .= searchTags s
+--                      , "matched" .= searchMatched s
+--                      , "total" .= searchTotal s
+--                      ]