summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--test5.hs265
1 files changed, 136 insertions, 129 deletions
diff --git a/test5.hs b/test5.hs
index 723527b..2fc7f09 100644
--- a/test5.hs
+++ b/test5.hs
@@ -474,10 +474,6 @@ moveCursorDownToNextUnread =
moveCursorToUnread findNext botOverrun moveTreeUp
-setSubForest :: Tree.Forest a -> Tree.Tree a -> Tree.Tree a
-setSubForest sf t = t { Tree.subForest = sf }
-
-
toggleFold :: State -> IO State
toggleFold q@State{..} =
getNewSubForest >>= return . \case
@@ -566,129 +562,6 @@ attachFilesToDraft q0 =
>> 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
-
-
-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
-
-
-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
-
-
replyToAll :: State -> IO State
replyToAll q0 =
runExceptT (go q0) >>= \result ->
@@ -786,6 +659,14 @@ editTagsAtCursor q0 =
_ <- readNotmuchE ("tag" : tagOpsToArgs tagOps ++ ["--", searchTerm]) ""
return q { cursor = select (==Z.label cursor) (patch tagOps cursor) }
+
+--
+-- utilities
+--
+
+
+setSubForest :: Tree.Forest a -> Tree.Tree a -> Tree.Tree a
+setSubForest sf t = t { Tree.subForest = sf }
patchMessage
@@ -839,15 +720,18 @@ addDateHeader t m@M.Mail{..} = do
) :
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
@@ -915,3 +799,126 @@ 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