config: add tv

1 files changed, 740 insertions, 0 deletions

diff --git a/config/tv.hs b/config/tv.hs
new file mode 100644
index 0000000..f3012b9
--- /dev/null
+++ b/config/tv.hs
@@ -0,0 +1,740 @@
+{-# LANGUAGE LambdaCase #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards #-}
+
+module Main (main, mainWithArgs) where
+
+import qualified Data.ByteString as BS
+import qualified Data.ByteString.Lazy.Char8 as LBS8
+import           Data.CaseInsensitive   (CI)
+import qualified Data.CaseInsensitive as CI
+import qualified Data.Text as T
+import qualified Data.Text.IO as T
+import qualified Data.Tree as Tree
+import qualified Data.Tree.Zipper as Z
+import qualified Network.Mail.Mime as M
+import qualified Notmuch
+import qualified Notmuch.Message as Notmuch
+import qualified Notmuch.SearchResult as Notmuch
+import qualified System.Console.Terminal.Size as Term
+import Blessings.String (Blessings(Plain,SGR),pp)
+import qualified Blessings.Internal as Blessings
+import Action
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Except
+import Data.Aeson (eitherDecode')
+import Data.Foldable (foldrM)
+import Data.List (intercalate)
+import Data.Maybe
+import Data.Time
+import Event
+import ParseMail (readMail)
+import RenderTreeView (renderTreeView)
+import Scanner (scan,Scan(..))
+import Screen
+import Safe
+import State
+import System.Directory
+import System.Console.Docopt.NoTH (getArgWithDefault, parseArgsOrExit, parseUsageOrExit, shortOption)
+import System.Environment
+import System.Exit
+import System.IO
+import System.Posix.Signals
+import System.Process
+import TagUtils
+import Text.Hyphenation
+import Text.LineBreak
+import TreeSearch
+import TreeView
+import TreeZipperUtils (modifyFirstParentLabelWhere)
+import Utils
+
+import Control.DeepSeq (rnf)
+
+-- | 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
+
+
+initState :: String -> IO State
+initState query = do
+    r_ <- either error id <$> Notmuch.search
+                                [ "--offset=0"
+                                , "--limit=100"
+                                , query
+                                ]
+
+    return State
+        { cursor = Z.fromTree $ fromSearchResults query r_
+        , 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 = []
+        }
+
+
+main :: IO ()
+main =
+    getArgs >>= mainWithArgs
+
+
+mainWithArgs :: [String] -> IO ()
+mainWithArgs args = do
+    usage' <- parseUsageOrExit usage
+    args' <- parseArgsOrExit usage' args
+    let query = getArgWithDefault args' defaultSearch (shortOption 'q')
+    withScreen s0 (\_-> initState 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)
+      ]
+    defaultSearch = "tag:inbox AND NOT tag:killed"
+
+    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)
+
+withoutHandlers :: (State -> IO State) -> State -> IO State
+withoutHandlers f q@State{..} =
+    bracket_ (uninstallHandlers signalHandlers)
+             (installHandlers signalHandlers)
+             (f q)
+
+
+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 s q
+    EScan info@ScanMouse{..} ->
+        Right <$> mousemap 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 now cursor (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 ++ take (screenHeight - length buffer) (repeat "~")
+
+
+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
+
+
+
+
+keymap :: String -> State -> IO State
+
+keymap "A" = attachFilesToDraft
+keymap "a" = toggleTagAtCursor "inbox"
+keymap "s" = toggleTagAtCursor "unread"
+keymap "&" = toggleTagAtCursor "killed"
+keymap "*" = toggleTagAtCursor "star"
+keymap "r" = replyToAll
+keymap "e" = withoutHandlers viewSource
+keymap "t" = withoutHandlers editTagsAtCursor
+keymap "k" = moveCursorUp 1
+keymap "j" = moveCursorDown 1
+keymap "K" = moveTreeDown 1
+keymap "J" = moveTreeUp 1
+keymap "\ESC[A" = moveCursorUp 1
+keymap "\ESC[B" = moveCursorDown 1
+keymap "\ESC[a" = moveTreeDown 1
+keymap "\ESC[b" = moveTreeUp 1
+keymap "\ESC[c" = moveTreeLeft 1  -- S-Right
+keymap "\ESC[d" = moveTreeRight 1 -- S-Left
+keymap "\ESC[5~" = \q -> moveTreeDown (screenHeight q `div` 2) q  -- PgUp
+keymap "\ESC[6~" = \q -> moveTreeUp (screenHeight q `div` 2) q    -- PgDn
+keymap "\n" = toggleFold
+keymap "\ESC[Z" = moveCursorUpToPrevUnread -- S-Tab
+keymap "\t" = moveCursorDownToNextUnread
+keymap "\DEL" = moveToParent  -- backspace
+
+-- TODO wrap/unwrap to separate module
+keymap "=" = \q@State{..} ->
+    let cursor' = case Z.label cursor of
+            TVMessageLine a b c s ->
+                wrap (TVMessageLine a b c) cursor s
+            _ -> cursor
+    in return q { cursor = cursor' }
+  where
+
+    --unwrap = error "WIP"
+        -- 1. get current id (must be TVMessageLine)
+        -- 2. find first adjoined TVMessageLine with same id
+        -- 3. find last adjoined TVMessageLine with same id
+        -- 4. join lines (with space?)
+
+    wrap ctor loc s =
+        fromMaybe (error "die hard") $
+        Z.nextTree $
+        foldr (insert . ctor)
+              (Z.delete loc)
+              $ hy s
+
+    insert a =
+        Z.prevSpace . Z.insert (Tree.Node a [])
+
+    hy s =
+        breakStringLn bf s
+      where
+        shy = '\173'
+        hyp = Just german_1996
+        bf = BreakFormat 80 8 shy hyp
+
+keymap "\ESCq" = editSearchTerm
+
+-- <F1>
+keymap "\ESC[11~" = \q@State{..} ->
+    return q { flashMessage = Plain $ show $ treeViewId $ Z.label cursor }
+
+-- <F2>
+keymap "\ESC[12~" = \q@State{..} ->
+    return q { flashMessage =
+                  Plain $
+                  show $
+                  maybe Nothing (Just . Notmuch.messageFilename) $
+                  getMessage $
+                  Z.label cursor
+              }
+
+-- TODO Stuff Vim sends after exit (also there is more...)
+keymap "\ESC[2;2R" = \q -> return q { flashMessage = flashMessage q <> " " <> Plain "stupid" }
+keymap "\ESC[>85;95;0c" = \q -> return q { flashMessage = flashMessage q <> " " <> Plain "stupid" }
+
+keymap s = \q ->
+    return q { flashMessage = Plain $ show s }
+
+
+mousemap :: Scan -> State -> IO State
+
+mousemap ScanMouse{mouseButton=1,mouseY=y} = defaultMouse1Click y
+mousemap ScanMouse{mouseButton=3,mouseY=y} = \q -> defaultMouse1Click y q >>= toggleFold
+mousemap ScanMouse{mouseButton=4} = moveTreeDown 3
+mousemap ScanMouse{mouseButton=5} = moveTreeUp 3
+mousemap ScanMouse{mouseButton=0} = return
+mousemap info = \q ->
+    return q { flashMessage = SGR [38,5,202] $ Plain $ show info }
+
+
+attachFilesToDraft :: State -> IO State
+attachFilesToDraft q0 =
+    runExceptT (go q0) >>= return . \result ->
+        q0 { flashMessage = Plain (show result) }
+  where
+    go :: State -> ExceptT String IO String
+    go State{cursor=cursor,now=now} = do
+        msg <- maybe (throwE "not a message") return $
+            getMessage (Z.label cursor)
+
+        unless (Notmuch.hasTag "draft" msg) $
+            throwE "message has no draft tag"
+
+        paths <- filter (not . null) . lines <$> promptE "add files"
+        when (null paths) (throwE "Aborted")
+
+        newTags <-
+            lines . LBS8.unpack . fst <$>
+            readNotmuchE ["config", "get", "new.tags"] ""
+
+        let tagOps =
+                map AddTag ("attachment" : Notmuch.messageTags msg) ++
+                map DelTag (map T.pack newTags)
+
+        loadMailE (Notmuch.messageId msg)
+
+            >>= attachFilesE paths
+                -- ^ this will catch invalid paths
+                -- TODO if it fails, then re-prompt
+
+            >>= return . (addDateHeader now . removeHeader "Date")
+
+            >>= liftE . M.renderMail' . removeHeaders
+                [ "Content-Type"
+                , "Content-Transfer-Encoding"
+                , "MIME-Version"
+                ]
+            >>= readNotmuchE ("insert" : "--no-hooks" : tagOpsToArgs tagOps)
+            >>  liftE (removeFile $ Notmuch.messageFilename msg)
+            >>  readNotmuchE ["new", "--no-hooks", "--quiet"] ""
+
+            >>  return "files attached"
+
+
+replyToAll :: State -> IO State
+replyToAll q0 =
+    runExceptT (go q0) >>= \result ->
+        toggleFold q0 { flashMessage = Plain (show result) }
+  where
+    go :: State -> ExceptT String IO String
+    go State{cursor=cursor,now=now} = do
+        msg <- maybe (throwE "not a message") return $
+            getMessage (Z.label cursor)
+
+        let msgId = Notmuch.unMessageID $ Notmuch.messageId msg
+
+        newTags <-
+            lines . LBS8.unpack . fst <$>
+            readNotmuchE ["config", "get", "new.tags"] ""
+
+        let tagOps =
+                map AddTag ["draft"] ++
+                map DelTag (map T.pack newTags)
+
+        readNotmuchE ["reply", msgId] ""
+            >>= return . LBS8.unpack . fst
+
+            -- TODO abort if nothing has been edited
+            >>= editMailE
+
+            >>= return . T.pack
+            >>= return . readMail
+            >>= return . addDateHeader now
+            >>= liftE . M.renderMail'
+            >>= readNotmuchE ("insert" : "--no-hooks" : tagOpsToArgs tagOps)
+            >>  return "draft created"
+
+
+viewSource :: State -> IO State
+viewSource q0 =
+    runExceptT (go q0) >>= return . \result ->
+        q0 { flashMessage = Plain (show result) }
+  where
+    go State{cursor=cursor} = do
+        msg <- maybe (throwE "not a message") return $
+            getMessage (Z.label cursor)
+
+        liftE (readFile $ Notmuch.messageFilename msg) >>= viewMailE
+
+
+editSearchTerm :: State -> IO State
+editSearchTerm q0 =
+    runExceptT (go q0) >>= return . \case
+        Right q' -> q'
+        Left err -> q0 { flashMessage = Plain $ "error: " ++ show err }
+  where
+    go :: State -> ExceptT String IO State
+    go q@State{..} = do
+
+        let parse = filter (/='\n') -- TODO proper parse
+            s = fromMaybe "" $ getSearchTerm $ Z.label $ Z.root cursor
+
+        s' <- editStringE s
+
+        result <-
+            either throwE return . eitherDecode' . fst =<<
+            readNotmuchE ["search", "--format=json", "--format-version=2", s'] ""
+            -- ^ TODO duplicates Notmuch.search
+
+        return q { cursor = Z.fromTree $ fromSearchResults (parse s') result }
+
+
+
+editTagsAtCursor :: State -> IO State
+editTagsAtCursor q0 =
+    runExceptT (go q0) >>= return . \case
+        Right q' -> q'
+        Left err -> q0 { flashMessage = Plain $ "error: " ++ show err }
+  where
+    go :: State -> ExceptT String IO State
+    go q@State{..} = do
+        -- TODO does this scream for a type class? :)
+        (searchTerm, tags, patch) <- case Z.label cursor of
+            TVSearchResult sr -> return
+                ( Notmuch.unThreadID $ Notmuch.searchThread sr
+                , Notmuch.searchTags sr
+                , patchSearchResult
+                )
+            TVMessage m -> return
+                ( Notmuch.unMessageID $ Notmuch.messageId m
+                , Notmuch.messageTags m
+                , patchMessage
+                )
+            _ -> throwE "cannot edit tags here"
+
+        tagOps <- editTagsE tags
+        when (null tagOps) (throwE "nothing happened")
+
+        _ <- readNotmuchE ("tag" : tagOpsToArgs tagOps ++ ["--", searchTerm]) ""
+
+        return q { cursor = select (==Z.label cursor) (patch tagOps cursor) }
+
+--
+-- utilities
+--
+
+patchMessage
+    :: [TagOp] -> Z.TreePos Z.Full TreeView -> Z.TreePos Z.Full TreeView
+patchMessage tagOps loc =
+    Z.modifyTree (patchTreeTags tagOps) loc
+
+
+patchSearchResult
+     :: [TagOp] -> Z.TreePos Z.Full TreeView -> Z.TreePos Z.Full TreeView
+patchSearchResult tagOps loc =
+    -- TODO this needs test cases
+    let
+        -- patch message
+        loc' = Z.modifyTree (patchRootLabelTags tagOps) loc
+
+        -- find search result of message
+        srloc = fromMaybe (error "could not find search result of message")
+                          (findParent isTVSearchResult loc')
+
+        -- patch search result
+        srloc' = Z.modifyTree (patchRootLabelTags tagOps) srloc
+    in
+        -- return message
+        fromMaybe (error "could not find message again")
+                  (findTree (==Z.label loc) srloc')
+
+
+-- TODO rename select
+select :: (a -> Bool) -> Z.TreePos Z.Full a -> Z.TreePos Z.Full a
+select p loc =
+    let root = Z.root loc
+    in fromMaybe root $ findTree p root
+
+
+withTempFile' :: FilePath -> ((FilePath, Handle) -> IO a) -> IO a
+withTempFile' s f = do
+    logname <- getEnv "LOGNAME"
+    tmpdir <- getTemporaryDirectory
+    withTempFile tmpdir (logname ++ "_much_" ++ s) f
+
+
+addDateHeader :: UTCTime -> M.Mail -> M.Mail
+addDateHeader t m@M.Mail{..} = do
+    m { M.mailHeaders =
+          ( "Date"
+          , T.pack $
+            formatTime defaultTimeLocale
+                       rfc822DateFormat
+                       t
+          ) :
+          mailHeaders
+      }
+
+
+removeHeader :: CI BS.ByteString -> M.Mail -> M.Mail
+removeHeader h m@M.Mail{..} =
+    m { M.mailHeaders = filter (\(k, _) -> CI.mk k /= h) mailHeaders }
+
+
+removeHeaders :: [CI BS.ByteString] -> M.Mail -> M.Mail
+removeHeaders hs m@M.Mail{..} =
+    m { M.mailHeaders = filter (\(k, _) -> CI.mk k `notElem` hs) mailHeaders }
+
+
+editMail :: String -> IO (Either ExitCode String)
+editMail s =
+    withTempFile' "edit.mail" $ \(path, h_tempFile) -> do
+        hPutStr h_tempFile s
+        hClose h_tempFile
+        editor <- getEnv "EDITOR"
+        runInteractive editor [path] >>= \case
+            ExitSuccess -> Right <$> readFile path
+            code -> return (Left code)
+
+
+editString :: String -> IO (Either ExitCode String)
+editString s =
+    withTempFile' "edit.string" $ \(path, h_tempFile) -> do
+        hPutStr h_tempFile s
+        hClose h_tempFile
+        editor <- getEnv "EDITOR"
+        runInteractive editor [path] >>= \case
+            ExitSuccess -> Right <$> readFile path
+            code -> return (Left code)
+
+
+editTags :: [Tag] -> IO (Either ExitCode [TagOp])
+editTags tags =
+    withTempFile' "edit.tags" $ \(path, h_tempFile) -> do
+        T.hPutStrLn h_tempFile $ T.intercalate " " tags
+        hClose h_tempFile
+        editor <- getEnv "EDITOR"
+        runInteractive editor [path] >>= \case
+            ExitSuccess -> Right . diffTags tags . parseTags <$> readFile path
+                                                   -- ^ TODO parseTags can fail
+            code -> return (Left code)
+
+
+viewMail :: String -> IO (Either ExitCode ())
+viewMail s = do
+    pager <- getEnv "PAGER"
+    (Just h_in, _, _, h_proc) <-
+        createProcess (shell pager) { std_in = CreatePipe }
+    hPutStr h_in s
+    hClose h_in
+    waitForProcess h_proc >>= \case
+        ExitSuccess -> return (Right ())
+        code -> return (Left code)
+
+
+prompt :: String -> IO (Either ExitCode String)
+prompt ps =
+    withTempFile' "prompt" $ \(path, h_tempFile) -> do
+        mapM_ (hPutStrLn h_tempFile) $ "" : map comment (lines ps)
+        hClose h_tempFile
+        editor <- getEnv "EDITOR"
+        runInteractive editor [path] >>= \case
+            ExitSuccess -> Right . removeComments <$> readFile path
+            code -> return (Left code)
+  where
+    comment = ("# "++)
+    removeComments =
+        unlines .
+        filter (maybe True (/='#') . headMay) .
+        lines
+
+
+runInteractive :: FilePath -> [String] -> IO ExitCode
+runInteractive cmd args = do
+    (_, _, _, h_proc) <- createProcess (proc cmd args)
+    waitForProcess h_proc
+
+
+liftE :: IO a -> ExceptT String IO a
+liftE io =
+    lift (try io) >>= either (throwE . transformException) return
+  where
+    transformException :: IOException -> String
+    transformException = ("IO: "++) . show
+
+
+editMailE :: String -> ExceptT String IO String
+editMailE ps =
+    liftE (editMail ps) >>= \case
+        Right r -> return r
+        Left code -> throwE $ "edit mail error: " ++ show code
+
+
+editStringE :: String -> ExceptT String IO String
+editStringE s =
+    liftE (editString s) >>= \case
+        Right r -> return r
+        Left code -> throwE $ "edit string error: " ++ show code
+
+
+editTagsE :: [Tag] -> ExceptT String IO [TagOp]
+editTagsE ps =
+    liftE (editTags ps) >>= \case
+        Right r -> return r
+        Left code -> throwE $ "edit tags error: " ++ show code
+
+
+viewMailE :: String -> ExceptT String IO ()
+viewMailE ps =
+    liftE (viewMail ps) >>= \case
+        Right r -> return r
+        Left code -> throwE $ "view mail error: " ++ show code
+
+
+promptE :: String -> ExceptT String IO String
+promptE ps =
+    liftE (prompt ps) >>= \case
+        Right r -> return r
+        Left code -> throwE $ "prompt error: " ++ show code
+
+
+loadMailE :: Notmuch.MessageID -> ExceptT String IO M.Mail
+loadMailE msgId =
+    liftE (Notmuch.notmuchShowMail $ Notmuch.unMessageID msgId) >>= \case
+        Right m -> return m
+        Left err -> throwE $ "load mail error: " ++ show err
+
+
+readNotmuchE
+    :: [String]
+    -> LBS8.ByteString
+    -> ExceptT String IO (LBS8.ByteString, LBS8.ByteString)
+readNotmuchE args input = do
+    (exitCode, out, err) <- liftE $ do
+        (Just hin, Just hout, Just herr, ph) <-
+            createProcess (proc "notmuch" args)
+                { std_in = CreatePipe
+                , std_out = CreatePipe
+                , std_err = CreatePipe
+                }
+        LBS8.hPut hin input
+        hClose hin
+
+        out <- LBS8.hGetContents hout
+        err <- LBS8.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)
+
+    case exitCode of
+        ExitSuccess -> return (out, err)
+        ExitFailure code ->
+            throwE $ "notmuch " ++ intercalate " " args ++
+                     " exit code: " ++ show code ++ "; stderr:\n" ++
+                     LBS8.unpack err
+
+
+attachFilesE :: [FilePath] -> M.Mail -> ExceptT String IO M.Mail
+attachFilesE paths =
+    liftE . attachFiles paths
+
+
+attachFiles :: [FilePath] -> M.Mail -> IO M.Mail
+attachFiles filenames mail0 =
+    foldrM attachFile mail0 filenames
+
+
+attachFile :: FilePath -> M.Mail -> IO M.Mail
+attachFile filePath mail = do
+    fileType <- fromMaybe "application/octet-stream" <$> getFileType filePath
+    M.addAttachment (T.pack fileType) filePath mail
+
+
+getFileType :: FilePath -> IO (Maybe String)
+getFileType path =
+    -- XXX GNU file's exit code is 0 even if path doesn't exist
+    doesFileExist path >>= \case
+        True -> do
+            (_, out, _) <- readProcessWithExitCode "file" ["-Lib", path] ""
+            return $ Just (init out)
+        False ->
+            return Nothing