config: add tv

1 files changed, 0 insertions, 740 deletions

diff --git a/test5.hs b/test5.hs
deleted file mode 100644
index f3012b9..0000000
--- a/test5.hs
+++ /dev/null
@@ -1,740 +0,0 @@
-{-# 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