State: add options for attachment saving

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

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 "<emptyState>") [])
-    , 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 "<emptyState>") [])
+      , 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) ]
+      }