Automatic mark mail as read

purebred.cabal

@@ -55,6 +55,7 @@ library
                      , xdg-basedir
                      , filepath
                      , unix
+                     , mtl
 
 executable purebred
   hs-source-dirs:      app
@@ -76,8 +77,9 @@ test-suite unittests
                      , purebred
                      , brick
                      , tasty-hunit
+                     , tasty-quickcheck
+                     , quickcheck-text
                      , tasty
-                     , tasty-golden
                      , directory
                      , process
                      , unbounded-delays

src/Storage/Notmuch.hs

@@ -1,53 +1,96 @@
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE LambdaCase #-}
 -- | module for integrating notmuch within purebred
 module Storage.Notmuch where
 
 import Types (NotmuchMail(..))
-import           Notmuch
-import           Notmuch.Search
+import Notmuch
+import Notmuch.Search
 
-import           Data.Maybe     (fromMaybe)
-import qualified Data.Vector    as Vec
-import           System.Process (readProcess)
+import Control.Monad (void)
+import Control.Monad.IO.Class (liftIO)
+import Control.Monad.Except (runExceptT)
+import Data.Traversable (traverse)
+import Data.List (union)
+import Data.Maybe (fromMaybe)
+import Data.Bifunctor (first)
+import qualified Data.Vector as Vec
+import System.Process (readProcess)
+import Control.Exception (bracket)
 import qualified Data.Text as T
-import Data.Text.Encoding (decodeUtf8)
-import Types (NotmuchSettings, nmDatabase, nmNewTag)
+import Data.Text.Encoding (decodeUtf8, encodeUtf8)
+import Types (NotmuchSettings, nmDatabase, mailId, mailTags)
 import Control.Lens.Getter (view)
+import Control.Lens.Setter (over)
 
 
 -- | creates a vector of parsed mails from a not much search
 -- Note, that at this point in time only free form searches are supported. Also,
 -- we filter out the tag which we use to mark mails as new mails
-getMessages :: T.Text -> NotmuchSettings FilePath -> IO (Vec.Vector NotmuchMail)
-getMessages s settings = do
-  db' <- databaseOpen (view nmDatabase settings)
-  case db' of
-    Left status -> do
-        error $ show status
-    Right db -> do
-        q <- query db (FreeForm $ T.unpack s)
-        msgs <- messages q
-        mails <- mapM (messageToMail $ view nmNewTag settings) msgs
-        return $ Vec.fromList mails
+getMessages :: T.Text
+            -> NotmuchSettings FilePath
+            -> IO (Either String (Vec.Vector NotmuchMail))
+getMessages s settings =
+  first show <$>
+  bracket (runExceptT (databaseOpenReadOnly (view nmDatabase settings))
+           >>= either (error . show) pure)
+          (void . runExceptT . databaseDestroy)
+          (\db -> runExceptT $ do
+              msgs <- query db (FreeForm $ T.unpack s) >>= messages
+              mails <- liftIO $ mapM messageToMail msgs
+              return $ Vec.fromList mails)
+
+setNotmuchMailTags
+    :: FilePath
+    -> NotmuchMail
+    -> IO (Either String NotmuchMail)
+setNotmuchMailTags dbpath m =
+  case mailTagsToNotmuchTags m of
+    Nothing -> pure $ Left "Tags are corrupt"
+    Just nmtags ->
+      bracket (runExceptT (databaseOpen dbpath) >>= either (error . show) pure)
+              (void . runExceptT . databaseDestroy)
+              (\db -> tagsToMessage nmtags m db)
+
+tagsToMessage
+  :: [Tag] -> NotmuchMail -> Database RW -> IO (Either String NotmuchMail)
+tagsToMessage xs m db =
+  runExceptT
+    (findMessage db
+                 (view mailId m)) >>=
+  \case
+    Left e -> pure $ Left (show e)
+    Right Nothing -> pure $ Left "boop"
+    Right (Just msg) -> do
+      _ <- runExceptT (messageSetTags xs msg)
+      pure $ Right m
+
+addTag :: NotmuchMail -> T.Text -> NotmuchMail
+addTag m t = over mailTags (`union` [t]) m
+
+removeTag :: NotmuchMail -> T.Text -> NotmuchMail
+removeTag m t = over mailTags (filter (/= t)) m
+
+mailTagsToNotmuchTags :: NotmuchMail -> Maybe [Tag]
+mailTagsToNotmuchTags m =
+    let xs = view mailTags m
+    in traverse id (mkTag . encodeUtf8 <$> xs)
 
 messageToMail
-    :: HasTags Message
-    => T.Text
-    -> Message
+    :: HasTags (Message n a)
+    => Message n a
     -> IO NotmuchMail
-messageToMail ignoredTag m = do
+messageToMail m = do
     tgs <- tags m
+    let tgs' = decodeUtf8 . getTag <$> tgs
     NotmuchMail <$>
       (decodeUtf8 . fromMaybe "" <$> messageHeader "Subject" m) <*>
       (decodeUtf8 . fromMaybe "" <$> messageHeader "From" m) <*>
       messageFilename m <*>
       messageDate m <*>
-      (pure $ tagsToText tgs ignoredTag) <*>
-      (pure $ isNewMail tgs ignoredTag)
-
-tagsToText :: [Tag] -> T.Text -> [T.Text]
-tagsToText t ignored = filter (/= ignored) $ decodeUtf8 <$> t
+      pure tgs' <*>
+      messageId m
 
 getDatabasePath :: IO (FilePath)
 getDatabasePath = getFromNotmuchConfig "database.path"
@@ -59,5 +102,5 @@ getFromNotmuchConfig key = do
   stdout <- readProcess cmd args []
   pure $ filter (/= '\n') stdout
 
-isNewMail :: [Tag] -> T.Text -> Bool
-isNewMail t newTag = newTag `elem` (decodeUtf8 <$> t)
+mailIsNew :: T.Text -> NotmuchMail -> Bool
+mailIsNew ignoredTag m = ignoredTag `elem` (view mailTags m)

src/Types.hs

@@ -7,7 +7,8 @@ import           Brick.Types               (EventM, Next)
 import qualified Brick.Widgets.Edit        as E
 import qualified Brick.Widgets.List        as L
 import           Control.Lens
-import qualified Data.Text                 as T
+import Data.ByteString (ByteString)
+import qualified Data.Text as T
 import qualified Graphics.Vty.Input.Events as Vty
 import Data.Time (UTCTime)
 import qualified Data.CaseInsensitive as CI
@@ -250,8 +251,8 @@ data NotmuchMail = NotmuchMail
     , _mailFilepath :: String
     , _mailDate :: UTCTime
     , _mailTags :: [T.Text]
-    , _mailIsNew :: Bool
-    } deriving (Show)
+    , _mailId :: ByteString
+    } deriving (Show, Eq)
 
 mailSubject :: Lens' NotmuchMail T.Text
 mailSubject = lens _mailSubject (\m s -> m { _mailSubject = s })
@@ -268,5 +269,5 @@ mailDate = lens _mailDate (\m d -> m { _mailDate = d })
 mailTags :: Lens' NotmuchMail [T.Text]
 mailTags = lens _mailTags (\m t -> m { _mailTags = t })
 
-mailIsNew :: Lens' NotmuchMail Bool
-mailIsNew = lens _mailIsNew (\m n -> m { _mailIsNew = n })
+mailId :: Lens' NotmuchMail ByteString
+mailId = lens _mailId (\m i -> m { _mailId = i })

src/UI/App.hs

@@ -36,7 +36,7 @@ appEvent s e =
 initialState :: InternalConfiguration -> IO AppState
 initialState conf = do
     let searchterms = view (confNotmuch . nmSearch) conf
-    vec <- getMessages searchterms (view confNotmuch conf)
+    vec <- either error pure =<< getMessages searchterms (view confNotmuch conf)
     let mi =
             MailIndex
                 (L.list ListOfMails vec 1)

src/UI/Index/Keybindings.hs

@@ -6,13 +6,15 @@ import qualified Brick.Types as T
 import qualified Brick.Widgets.Edit as E
 import qualified Brick.Widgets.List as L
 import Data.Text.Zipper (gotoEOL)
+import Data.Vector (Vector)
 import Control.Lens.Getter (view)
 import Control.Lens.Lens ((&))
 import Control.Lens.Setter ((?~), set, over)
 import Control.Monad.IO.Class (liftIO)
 import Data.Text.Zipper (currentLine)
+import Data.Text (Text)
 import qualified Graphics.Vty as V
-import Storage.Notmuch (getMessages)
+import Storage.Notmuch (getMessages, addTag, removeTag, setNotmuchMailTags)
 import Storage.ParsedMail (parseMail, getTo, getFrom, getSubject)
 import Types
 import Data.Monoid ((<>))
@@ -31,6 +33,8 @@ indexKeybindings =
     , Keybinding "Switch between editor and main" (V.EvKey (V.KChar '\t') []) toggleComposeEditorAndMain
     , Keybinding "compose new mail" (V.EvKey (V.KChar 'm') []) composeMail
     , Keybinding "reply to mail" (V.EvKey (V.KChar 'r') []) replyMail
+    , Keybinding "toggle unread" (V.EvKey (V.KChar 't') []) (
+        \s -> continue =<< (liftIO $ updateReadState addTag s))
     ]
 
 indexsearchKeybindings :: [Keybinding]
@@ -46,8 +50,23 @@ focusSearch s = continue $ s
 
 displayMail :: AppState -> T.EventM Name (T.Next AppState)
 displayMail s = do
-    s' <- liftIO $ updateStateWithParsedMail s
-    continue $ s'
+    s' <- liftIO $ updateStateWithParsedMail s >>= updateReadState removeTag
+    continue s'
+
+updateReadState :: (NotmuchMail -> Text -> NotmuchMail) -> AppState -> IO AppState
+updateReadState op s =
+    case L.listSelectedElement (view (asMailIndex . miListOfMails) s) of
+        Just (_,m) ->
+            let newTag = view (asConfig . confNotmuch . nmNewTag) s
+                dbpath = view (asConfig . confNotmuch . nmDatabase) s
+            in either (\err -> set asError (Just err) s) (updateMailInList s)
+               <$> setNotmuchMailTags dbpath (op m newTag)
+        Nothing -> pure $ s & asError ?~ "No mail selected to update tags"
+
+updateMailInList :: AppState -> NotmuchMail -> AppState
+updateMailInList s m =
+    let l = L.listModify (const m) (view (asMailIndex . miListOfMails) s)
+    in set (asMailIndex . miListOfMails) l s
 
 updateStateWithParsedMail :: AppState -> IO AppState
 updateStateWithParsedMail s =
@@ -105,11 +124,13 @@ cancelSearch s = continue $ set (asMailIndex . miMode) BrowseMail s
 
 applySearchTerms :: AppState -> T.EventM Name (T.Next AppState)
 applySearchTerms s = do
-    let searchterms =
-            currentLine $
-            view (asMailIndex . miSearchEditor . E.editContentsL) s
-    vec <- liftIO $ getMessages searchterms (view (asConfig . confNotmuch) s)
-    let listWidget = (L.list ListOfMails vec 1)
-    continue $
-        set (asMailIndex . miListOfMails) listWidget s & set asAppMode Main &
-        set (asMailIndex . miMode) BrowseMail
+     result <- liftIO $ getMessages searchterms (view (asConfig . confNotmuch) s)
+     continue $ reloadListOfMails s result
+     where searchterms = currentLine $ view (asMailIndex . miSearchEditor . E.editContentsL) s
+
+reloadListOfMails :: AppState -> Either String (Vector NotmuchMail) -> AppState
+reloadListOfMails s (Left e) =  s & asError ?~ e
+reloadListOfMails s (Right vec) =
+  let listWidget = (L.list ListOfMails vec 1)
+  in set (asMailIndex . miListOfMails) listWidget s & set asAppMode Main &
+     set (asMailIndex . miMode) BrowseMail

src/UI/Index/Main.hs

@@ -22,6 +22,7 @@ import Data.Text (Text, pack)
 import UI.Draw.Main (editorDrawContent)
 import UI.Keybindings (handleEvent)
 import UI.Status.Main (statusbar)
+import Storage.Notmuch (mailIsNew)
 import Types
 
 drawMain :: AppState -> [Widget Name]
@@ -33,16 +34,19 @@ drawMain s = [ui]
 
 renderMailList :: AppState -> Widget Name
 renderMailList s = let listFocus = view (asMailIndex . miMode) s == BrowseMail
-                   in L.renderList listDrawElement listFocus (view (asMailIndex . miListOfMails) s)
+                   in L.renderList (listDrawElement s) listFocus (view (asMailIndex . miListOfMails) s)
 
-listDrawElement :: Bool -> NotmuchMail -> Widget Name
-listDrawElement sel a =
+listDrawElement :: AppState -> Bool -> NotmuchMail -> Widget Name
+listDrawElement s sel a =
     let selected w = if sel then withAttr L.listSelectedAttr w else w
-        newMail m w = if (view mailIsNew m) then withAttr listNewMailAttr w else w
+        settings = view (asConfig . confNotmuch) s
+        newMail m w = if (mailIsNew (view nmNewTag settings) m)
+                      then withAttr listNewMailAttr w
+                      else w
         widget = padLeft (Pad 1) $ (hLimit 15 (txt $ view mailFrom a)) <+>
                  (padLeft (Pad 1) $ (txt $ formatDate (view mailDate a))) <+>
                  padLeft (Pad 2) (txt (view mailSubject a)) <+>
-                 (padLeft Max $ renderMailTagsWidget a)
+                 (padLeft Max $ renderMailTagsWidget a (view nmNewTag settings))
     in (newMail a $ selected widget)
 
 
@@ -64,9 +68,9 @@ mailAttr = "mail"
 mailTagsAttr :: AttrName
 mailTagsAttr = mailAttr <> "tags"
 
-renderMailTagsWidget :: NotmuchMail -> Widget Name
-renderMailTagsWidget m =
-    let ts = view mailTags m
+renderMailTagsWidget :: NotmuchMail -> Text -> Widget Name
+renderMailTagsWidget m ignored =
+    let ts = filter (/= ignored) $ view mailTags m
     in withAttr mailTagsAttr $ vLimit 1 $ txt $ unwords ts
 
 -- | We currently have two modes on the main view we need to distinguish

src/UI/Mail/Main.hs

@@ -18,13 +18,15 @@ import qualified Data.CaseInsensitive as CI
 import Control.Lens.Getter (view)
 import Control.Lens.Setter (set)
 import Data.CaseInsensitive (mk)
-import           Control.Monad.IO.Class    (liftIO)
-import qualified Data.Text                 as T
-import           Graphics.Vty.Input.Events (Event)
-import           UI.Index.Keybindings      (updateStateWithParsedMail)
-import           UI.Index.Main             (renderMailList)
-import           UI.Keybindings            (handleEvent)
-import           UI.Status.Main            (statusbar)
+import Control.Monad.IO.Class (liftIO)
+import qualified Data.Text as T
+import Graphics.Vty.Input.Events (Event)
+import UI.Index.Keybindings
+       (updateStateWithParsedMail, updateReadState)
+import Storage.Notmuch (removeTag)
+import UI.Index.Main (renderMailList)
+import UI.Keybindings (handleEvent)
+import UI.Status.Main (statusbar)
 import Types
 
 -- | Instead of using the entire rendering area to show the email, we still show
@@ -109,4 +111,5 @@ displayMailDefault :: AppState -> Event -> T.EventM Name (T.Next AppState)
 displayMailDefault s ev = do
             l' <- L.handleListEvent ev (view (asMailIndex . miListOfMails) s)
             s' <- liftIO $ updateStateWithParsedMail (set (asMailIndex . miListOfMails) l' s)
+                  >>= updateReadState removeTag
             M.continue s'

stack.yaml

@@ -39,7 +39,7 @@ packages:
 - '.'
 - location:
     git: https://github.com/frasertweedale/hs-notmuch.git
-    commit: 05272915f19320362d3a2eb2ffc80eacd7162b7a
+    commit: 5bc75a6344163899d09153bb9e08bc620ee343ee
   extra-dep: true
 
 # Dependency packages to be pulled from upstream that are not in the resolver