test5 attachFilesToDraft: use ExcepT

2 files changed, 137 insertions, 37 deletions

diff --git a/Notmuch/Message.hs b/Notmuch/Message.hs
index dd1e809..8c3d1ed 100644
--- a/Notmuch/Message.hs
+++ b/Notmuch/Message.hs
@@ -105,7 +105,9 @@ instance FromJSON Message where
     parseJSON (Array _) = return $ Message (MessageID "") defTime M.empty [] True False [] ""
         where defTime = UTCTime (ModifiedJulianDay 0) (fromInteger 0)
     parseJSON x = fail $ "Error parsing message: " ++ show x
-
+
+hasTag :: T.Text -> Message -> Bool
+hasTag tag = (tag `elem`) . messageTags
 
 
 
diff --git a/test5.hs b/test5.hs
index d91f5e7..b95377d 100644
--- a/test5.hs
+++ b/test5.hs
@@ -5,6 +5,7 @@
 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
@@ -20,6 +21,8 @@ import Control.Applicative
 import Control.Concurrent
 import Control.Exception
 import Control.Monad
+import Control.Monad.Trans.Class (lift)
+import Control.Monad.Trans.Except
 import Data.Foldable (foldrM)
 import Data.List (intercalate)
 import Data.Maybe
@@ -48,6 +51,22 @@ 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
 
 
 data State = State
@@ -513,42 +532,121 @@ toggleTagAtCursor tag q@State{..} = case Z.label cursor of
 
 
 attachFilesToDraft :: State -> IO State
-attachFilesToDraft q@State{..} = case getMessage (Z.label cursor) of
-    Nothing ->
-        return q { flashMessage = "no message" }
-    Just m -> do
-        let msgId = Notmuch.unMessageID $ Notmuch.messageId m
-        filenames <- either (const []) lines <$> prompt "add files"
-        Notmuch.notmuchShowMail msgId >>= \case
-            Left err ->
-                return q { flashMessage = Plain $ "Error: " ++ show err }
-            Right mail ->
-                    return mail
-                >>= return . removeHeaders -- TODO mk unforgettable
-                    [ "Content-Type"
-                    , "Content-Transfer-Encoding"
-                    , "MIME-Version"
-                    ]
-                >>= attachFiles filenames
-                >>= return . removeHeader "Date"
-                >>= return . addDateHeader now
-                >>= M.renderMail'
-                >>= Notmuch.notmuchWithInput
-                    [ "insert"
-                    , "--no-hooks"
-                    -- TODO dont hardcode which tags (and use TagOps)
-                    , "+draft"
-                    , "+attachment"
-                    , "-inbox"
-                    , "-unread"
-                    ]
-                >>= \case
-                    (ExitFailure code, _, _) ->
-                        return q { flashMessage =
-                            Plain $ "notmuch insert exit code = " ++ show code
-                        }
-                    _ ->
-                        return q { flashMessage = "draft created" }
+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"
+
+
+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
+
+
+liftE :: IO a -> ExceptT String IO a
+liftE io =
+    lift (try io) >>= either (throwE . transformException) return
+  where
+    transformException :: IOException -> String
+    transformException = ("IO: "++) . show
+
+
+
+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
+
+
+attachFilesE :: [FilePath] -> M.Mail -> ExceptT String IO M.Mail
+attachFilesE paths =
+    liftE . attachFiles paths
 
 
 attachFiles :: [FilePath] -> M.Mail -> IO M.Mail