From 8df7be6bce1193bfb2dd1192676ceb261baec012 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kier=C3=A1n=20Meinhardt?= Date: Tue, 22 Sep 2020 21:47:01 +0200 Subject: config: add tv --- config/tv.hs | 740 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ test5.hs | 740 ----------------------------------------------------------- 2 files changed, 740 insertions(+), 740 deletions(-) create mode 100644 config/tv.hs delete mode 100644 test5.hs 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 ]" + , "" + , "Options:" + , " -q , --query=" + , " 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 + +-- +keymap "\ESC[11~" = \q@State{..} -> + return q { flashMessage = Plain $ show $ treeViewId $ Z.label cursor } + +-- +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 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 ]" - , "" - , "Options:" - , " -q , --query=" - , " 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 - --- -keymap "\ESC[11~" = \q@State{..} -> - return q { flashMessage = Plain $ show $ treeViewId $ Z.label cursor } - --- -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 -- cgit v1.2.3