summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--config/tv.hs467
1 files changed, 4 insertions, 463 deletions
diff --git a/config/tv.hs b/config/tv.hs
index a1e1d18..84a978d 100644
--- a/config/tv.hs
+++ b/config/tv.hs
@@ -4,48 +4,19 @@
module Main (main) where
-import Much.Action
import Blessings.String
-import Control.Concurrent
-import Control.DeepSeq (rnf)
-import Control.Exception
-import Control.Monad
-import Control.Monad.Trans.Class (lift)
-import Control.Monad.Trans.Except
-import Much.Core
-import Data.Aeson (eitherDecode')
-import Data.CaseInsensitive (CI)
import Data.Default
-import Data.Foldable (foldrM)
-import Data.List (intercalate)
import Data.Maybe
-import Data.Time
-import Much.ParseMail (readMail)
-import Safe
-import Scanner
+import Much.Action
+import Much.Core
import Much.State
-import System.Directory
-import System.Environment
-import System.Exit
-import System.IO
-import System.Process
-import Much.TagUtils
+import Much.TreeView
+import Scanner
import Text.Hyphenation
import Text.LineBreak
-import Much.TreeSearch
-import Much.TreeView
-import Much.Utils
-import qualified Data.ByteString as BS
-import qualified Data.ByteString.Lazy.Char8 as LBS8
-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
main :: IO ()
main =
@@ -56,14 +27,10 @@ main =
myKeymap :: String -> State -> IO State
-myKeymap "A" = attachFilesToDraft
myKeymap "a" = toggleTagAtCursor "inbox"
myKeymap "s" = toggleTagAtCursor "unread"
myKeymap "&" = toggleTagAtCursor "killed"
myKeymap "*" = toggleTagAtCursor "star"
-myKeymap "r" = replyToAll
-myKeymap "e" = withoutHandlers viewSource
-myKeymap "t" = withoutHandlers editTagsAtCursor
myKeymap "k" = moveCursorUp 1
myKeymap "j" = moveCursorDown 1
myKeymap "K" = moveTreeDown 1
@@ -113,8 +80,6 @@ myKeymap "=" = \q@State{..} ->
hyp = Just german_1996
bf = BreakFormat 80 8 shy hyp
-myKeymap "\ESCq" = editSearchTerm
-
-- <F1>
myKeymap "\ESC[11~" = \q@State{..} ->
return q { flashMessage = Plain $ show $ treeViewId $ Z.label cursor }
@@ -143,427 +108,3 @@ myMousemap ScanMouse{mouseButton=4} = moveTreeDown 3
myMousemap ScanMouse{mouseButton=5} = moveTreeUp 3
myMousemap ScanMouse{mouseButton=0} = return
myMousemap info = displayMouse info
-
-
-withoutHandlers :: (State -> IO State) -> State -> IO State
-withoutHandlers f q@State{..} =
- bracket_ (uninstallHandlers signalHandlers)
- (installHandlers signalHandlers)
- (f q)
-
-
--- | 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
-
-
-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