From 92a67aaa55f5fee4a2b9a7357f1b9956a84cd188 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Kier=C3=A1n=20Meinhardt?= Date: Thu, 1 Oct 2020 20:58:23 +0200 Subject: State: add options for attachment saving use Data.Default for Much.State.State, Much.State.ColorConfig, Much.API.Config refactor saveAttachment and openAttachment actions --- config/kmein.hs | 93 ++++++++++++++++++++++++++++++-------------------- config/tv.hs | 3 +- much.cabal | 4 +++ src/Much/API/Config.hs | 6 ++-- src/Much/Config.hs | 2 ++ src/Much/Core.hs | 45 ++---------------------- src/Much/State.hs | 59 ++++++++++++++++++++++++++++++-- 7 files changed, 127 insertions(+), 85 deletions(-) diff --git a/config/kmein.hs b/config/kmein.hs index f6f0f04..ec6e516 100644 --- a/config/kmein.hs +++ b/config/kmein.hs @@ -4,19 +4,17 @@ module Main (main) where -import Much.Action -import Much.Core -import Much.State -import Much.TreeView -import qualified Notmuch -import qualified Notmuch.Message as Notmuch -import qualified Data.ByteString.Lazy.Char8 as LBS8 - import Blessings.String import Control.Monad +import Data.Default import Data.Maybe import Data.Time.Format +import Much.Action +import Much.Core +import Much.State +import Much.TreeView import Scanner +import System.Directory import System.Exit import System.FilePath import System.IO @@ -24,11 +22,14 @@ import System.Posix.Signals import System.Process import Text.Hyphenation import Text.LineBreak +import qualified Data.ByteString.Lazy.Char8 as LBS8 import qualified Data.Map as M 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 Notmuch +import qualified Notmuch.Message as Notmuch {- notmuch's special tags are: @@ -39,15 +40,12 @@ import qualified Data.Tree.Zipper as Z ref: https://notmuchmail.org/special-tags/ -} -attachmentDestination :: FilePath -attachmentDestination = "/tmp" - main :: IO () main = - mainWithState emptyState + mainWithState def { keymap = myKeymap , mousemap = myMousemap - , colorConfig = (colorConfig emptyState) + , colorConfig = def { boring = SGR [38,5,8] , alt = SGR [38,5,182] , search = SGR [38,5,13] @@ -74,25 +72,49 @@ main = , query = "tag:inbox" } - -saveAttachment :: State -> IO (Maybe FilePath, State) -saveAttachment q - | TVMessagePart message part <- Z.label (cursor q) = do - let messageId = Notmuch.unMessageID (Notmuch.messageId message) - Notmuch.notmuchShowPart messageId (Notmuch.partID part) >>= \case - Right part' -> - let - destination - | Just partFileName <- Notmuch.partContentFilename part = attachmentDestination T.unpack partFileName - | otherwise = concat ["much_", formatTime defaultTimeLocale "%s" (Notmuch.messageTime message), "_", show (Notmuch.partID part)] - q' = q { flashMessage = SGR [1] (Plain destination) <> Plain " saved" } - in case Notmuch.partContent part' of - Notmuch.ContentText text -> (Just destination, q') <$ T.writeFile destination text - Notmuch.ContentRaw raw _ -> (Just destination, q') <$ LBS8.writeFile destination raw - _ -> return (Nothing, q { flashMessage = "this part cannot be saved" }) - Left err -> return (Nothing, q { flashMessage = Plain err }) - | otherwise = return (Nothing, q { flashMessage = "cursor not on attachment" }) - +showCurrentMessagePart :: State -> IO (Maybe (Notmuch.Message, Notmuch.MessagePart)) +showCurrentMessagePart q = + case Z.label (cursor q) of + TVMessagePart message part -> do + let messageId = Notmuch.unMessageID (Notmuch.messageId message) + partResult <- Notmuch.notmuchShowPart messageId (Notmuch.partID part) + case partResult of + Right part' -> return $ Just (message, part') + Left _ -> return Nothing + _ -> return Nothing + +currentAttachmentPath :: State -> Notmuch.Message -> Notmuch.MessagePart -> FilePath +currentAttachmentPath q message part = + attachmentDirectory q attachmentFileName q message part + +saveAttachment :: State -> IO State +saveAttachment q = + showCurrentMessagePart q >>= \case + Nothing -> return q { flashMessage = "cursor not on attachment" } + Just (message, part) -> do + let destination = currentAttachmentPath q message part + alreadyDownloaded <- doesFileExist destination + if attachmentOverwrite q || not alreadyDownloaded + then case Notmuch.partContent part of + Notmuch.ContentText text -> + q { flashMessage = Plain destination } <$ + T.writeFile destination text + Notmuch.ContentRaw raw _ -> + q { flashMessage = Plain destination } <$ + LBS8.writeFile destination raw + _ -> return q { flashMessage = "this part cannot be saved" } + else + return q { flashMessage = "not overwriting attachment" } + +openAttachment :: State -> IO State +openAttachment q = + showCurrentMessagePart q >>= \case + Nothing -> return q { flashMessage = "cursor not on attachment" } + Just (message, part) -> do + let destination = currentAttachmentPath q message part + alreadyDownloaded <- doesFileExist destination + unless alreadyDownloaded (void $ saveAttachment q) + q <$ callProcess "xdg-open" [destination] reply :: State -> IO State reply q = q <$ spawnCommand "i3-sensible-terminal -e $EDITOR -c 'read !mail-reply'" @@ -114,11 +136,8 @@ myKeymap "\ESC[D" = moveTreeRight 10 -- right myKeymap "r" = notmuchSearch myKeymap "R" = reply -myKeymap "S" = fmap snd . saveAttachment -myKeymap "o" = saveAttachment >=> \case - (Nothing, q') -> return q' - (Just filePath, q') -> - q' <$ callProcess "xdg-open" [filePath] +myKeymap "S" = saveAttachment +myKeymap "o" = openAttachment myKeymap "q" = \q -> q <$ raiseSignal sigINT diff --git a/config/tv.hs b/config/tv.hs index a00756d..a1e1d18 100644 --- a/config/tv.hs +++ b/config/tv.hs @@ -15,6 +15,7 @@ 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 @@ -48,7 +49,7 @@ import qualified Notmuch.SearchResult as Notmuch main :: IO () main = - mainWithState emptyState + mainWithState def { keymap = myKeymap , mousemap = myMousemap } diff --git a/much.cabal b/much.cabal index 1e819a0..381c739 100644 --- a/much.cabal +++ b/much.cabal @@ -14,6 +14,7 @@ executable much-tv build-depends: much , base , blessings + , data-default , deepseq , transformers , aeson @@ -40,6 +41,8 @@ executable much-kmein , blessings , bytestring , containers + , data-default + , directory , filepath , hyphenation , linebreak @@ -88,6 +91,7 @@ library , bytestring , case-insensitive , containers + , data-default , deepseq , directory , docopt diff --git a/src/Much/API/Config.hs b/src/Much/API/Config.hs index 2e3b1cc..0a45068 100644 --- a/src/Much/API/Config.hs +++ b/src/Much/API/Config.hs @@ -1,11 +1,13 @@ module Much.API.Config where +import Data.Default + data Config = Config { socketPath :: FilePath } -emptyConfig :: Config -emptyConfig = +instance Default Config where + def = Config { socketPath = "/tmp/much.api.sock" } diff --git a/src/Much/Config.hs b/src/Much/Config.hs index 5f4d6db..53c2891 100644 --- a/src/Much/Config.hs +++ b/src/Much/Config.hs @@ -12,6 +12,8 @@ data Config = Config { colorConfig :: Maybe (ColorConfig (Maybe [Word8])) , query :: Maybe String , tagSymbols :: Maybe (M.Map T.Text T.Text) + , attachmentOverwrite :: Maybe Bool + , attachmentDirectory :: Maybe FilePath } deriving (Generic, Show) instance FromJSON Config diff --git a/src/Much/Core.hs b/src/Much/Core.hs index 47d6706..9fb1ed3 100644 --- a/src/Much/Core.hs +++ b/src/Much/Core.hs @@ -28,58 +28,17 @@ import System.IO import System.Posix.Signals import qualified Blessings.Internal as Blessings import qualified Data.Map as M -import qualified Data.Tree as Tree import qualified Data.Tree.Zipper as Z import qualified Much.Config as Config import qualified Notmuch import qualified System.Console.Terminal.Size as Term - - -emptyState :: State -emptyState = State - { cursor = Z.fromTree (Tree.Node (TVSearch "") []) - , 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 = [] - , query = "tag:inbox AND NOT tag:killed" - , keymap = displayKey - , mousemap = displayMouse - , colorConfig = ColorConfig - { tagMap = M.fromList - [ ("killed", SGR [38,5,088]) - , ("star", SGR [38,5,226]) - , ("draft", SGR [38,5,202]) - ] - , alt = SGR [38,5,182] - , search = SGR [38,5,162] - , focus = SGR [38,5,160] - , unprintableFocus = SGR [38,5,204] - , unprintableNormal = SGR [35] - , quote = SGR [38,5,242] - , boring = SGR [38,5,240] - , prefix = SGR [38,5,235] - , date = SGR [38,5,071] - , tags = SGR [38,5,036] - , boringMessage = SGR [38,5,023] - , unreadMessage = SGR [38,5,117] - , unreadSearch = SGR [38,5,250] - } - , tagSymbols = M.empty - , apiConfig = Much.API.emptyConfig - } - - importConfig :: Config.Config -> State -> State importConfig config state = state { tagSymbols = fromMaybe (tagSymbols state) (Config.tagSymbols config) , query = fromMaybe (query state) (Config.query config) + , attachmentDirectory = fromMaybe (attachmentDirectory state) (Config.attachmentDirectory config) + , attachmentOverwrite = fromMaybe (attachmentOverwrite state) (Config.attachmentOverwrite config) , colorConfig = let fromColorConfig key1 key2 = case Config.colorConfig config of Just colorC -> maybe (key1 (colorConfig state)) SGR (key2 colorC) diff --git a/src/Much/State.hs b/src/Much/State.hs index 8bc2de9..551cdd0 100644 --- a/src/Much/State.hs +++ b/src/Much/State.hs @@ -1,18 +1,22 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} module Much.State where -import Blessings.String (Blessings) +import Blessings import Data.Aeson +import Data.Default import Data.Time import GHC.Generics -import Much.TreeView (TreeView) +import Much.TreeView (TreeView(TVSearch)) import Scanner import System.Posix.Signals import qualified Data.Map as M import qualified Data.Text as T +import qualified Data.Tree as Tree import qualified Data.Tree.Zipper as Z import qualified Much.API.Config +import qualified Notmuch.Message as Notmuch data State = State { cursor :: Z.TreePos Z.Full TreeView @@ -31,6 +35,9 @@ data State = State , tagSymbols :: M.Map T.Text T.Text , colorConfig :: ColorConfig (Blessings String -> Blessings String) , apiConfig :: Much.API.Config.Config + , attachmentOverwrite :: Bool + , attachmentDirectory :: FilePath + , attachmentFileName :: Notmuch.Message -> Notmuch.MessagePart -> FilePath } instance Show (State -> IO ()) where @@ -53,4 +60,52 @@ data ColorConfig a = ColorConfig , unprintableNormal :: a } deriving (Generic, Show) +instance Default (ColorConfig (Blessings String -> Blessings String)) where + def = ColorConfig + { tagMap = M.fromList + [ ("killed", SGR [38,5,088]) + , ("star", SGR [38,5,226]) + , ("draft", SGR [38,5,202]) + ] + , alt = SGR [38,5,182] + , search = SGR [38,5,162] + , focus = SGR [38,5,160] + , unprintableFocus = SGR [38,5,204] + , unprintableNormal = SGR [35] + , quote = SGR [38,5,242] + , boring = SGR [38,5,240] + , prefix = SGR [38,5,235] + , date = SGR [38,5,071] + , tags = SGR [38,5,036] + , boringMessage = SGR [38,5,023] + , unreadMessage = SGR [38,5,117] + , unreadSearch = SGR [38,5,250] + } + instance FromJSON a => FromJSON (ColorConfig a) + +instance Default State where + def = State + { cursor = Z.fromTree (Tree.Node (TVSearch "") []) + , 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 = [] + , query = "tag:inbox AND NOT tag:killed" + , keymap = const return + , mousemap = const return + , colorConfig = def + , tagSymbols = M.empty + , apiConfig = def + , attachmentOverwrite = False + , attachmentDirectory = "/tmp" + , attachmentFileName = \message part -> + case Notmuch.partContentFilename part of + Just partFileName -> T.unpack partFileName + Nothing -> concat [ "much_" , formatTime defaultTimeLocale "%s" (Notmuch.messageTime message) , "_" , show (Notmuch.partID part) ] + } -- cgit v1.2.3