State: add options for attachment saving

use Data.Default for Much.State.State, Much.State.ColorConfig, Much.API.Config
refactor saveAttachment and openAttachment actions

2 files changed, 58 insertions, 38 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
       }