diff --git a/.travis.yml b/.travis.yml index 66696041..bf74fb53 100644 --- a/.travis.yml +++ b/.travis.yml @@ -18,7 +18,8 @@ before_install: script: - stack --system-ghc --no-terminal --skip-ghc-check install - - stack --system-ghc --no-terminal --skip-ghc-check test + - DEBUG=1 stack --system-ghc --no-terminal --skip-ghc-check test 2> /tmp/test.log + - cat /tmp/test.log matrix: include: diff --git a/purebred.cabal b/purebred.cabal index f7127775..d0b71b6f 100644 --- a/purebred.cabal +++ b/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 diff --git a/src/Config/Main.hs b/src/Config/Main.hs index 0b76bf41..2b28e4ad 100644 --- a/src/Config/Main.hs +++ b/src/Config/Main.hs @@ -2,16 +2,14 @@ module Config.Main where import qualified Brick.AttrMap as A +import qualified Brick.Widgets.List as L +import Data.Monoid ((<>)) import Brick.Util (fg, on) import qualified Brick.Widgets.Edit as E import qualified Graphics.Vty as V import System.Environment (lookupEnv) import Data.Maybe (fromMaybe) -import UI.Mail.Main (headerKeyAttr, headerValueAttr) import UI.ComposeEditor.Keybindings (composeEditorKeybindings) -import UI.Index.Main - (listAttr, listSelectedAttr, listNewMailAttr, mailTagsAttr) -import UI.Status.Main (statusbarAttr, statusbarErrorAttr) import UI.Index.Keybindings (indexKeybindings, indexsearchKeybindings) import UI.Mail.Keybindings (displayMailKeybindings) @@ -29,6 +27,7 @@ defaultColorMap = [ (listAttr, V.brightBlue `on` V.black) , (listSelectedAttr, V.white `on` V.yellow) , (listNewMailAttr, fg V.white `V.withStyle` V.bold) + , (listNewMailSelectedAttr, V.white `on` V.yellow `V.withStyle` V.bold) , (mailTagsAttr, fg V.cyan) , (E.editFocusedAttr, V.white `on` V.black) , (E.editAttr, V.brightBlue `on` V.black) @@ -37,6 +36,39 @@ defaultColorMap = , (headerKeyAttr, fg V.cyan) , (headerValueAttr, fg V.brightCyan)] +statusbarAttr :: A.AttrName +statusbarAttr = "statusbar" + +statusbarErrorAttr :: A.AttrName +statusbarErrorAttr = statusbarAttr <> "error" + +listAttr :: A.AttrName +listAttr = L.listAttr + +listSelectedAttr :: A.AttrName +listSelectedAttr = L.listSelectedAttr + +listNewMailAttr :: A.AttrName +listNewMailAttr = L.listAttr <> "newmail" + +listNewMailSelectedAttr :: A.AttrName +listNewMailSelectedAttr = listNewMailAttr <> L.listSelectedAttr + +mailAttr :: A.AttrName +mailAttr = "mail" + +mailTagsAttr :: A.AttrName +mailTagsAttr = mailAttr <> "tags" + +headerAttr :: A.AttrName +headerAttr = "header" + +headerKeyAttr :: A.AttrName +headerKeyAttr = headerAttr <> "key" + +headerValueAttr :: A.AttrName +headerValueAttr = headerAttr <> "value" + defaultConfig :: UserConfiguration defaultConfig = Configuration diff --git a/src/Storage/Notmuch.hs b/src/Storage/Notmuch.hs index 6a94cf4d..c3720123 100644 --- a/src/Storage/Notmuch.hs +++ b/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) diff --git a/src/Types.hs b/src/Types.hs index 7ac302f0..fbae8a5f 100644 --- a/src/Types.hs +++ b/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 }) diff --git a/src/UI/App.hs b/src/UI/App.hs index 7693438d..92286246 100644 --- a/src/UI/App.hs +++ b/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) diff --git a/src/UI/Index/Keybindings.hs b/src/UI/Index/Keybindings.hs index cb17d240..e554bce6 100644 --- a/src/UI/Index/Keybindings.hs +++ b/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 diff --git a/src/UI/Index/Main.hs b/src/UI/Index/Main.hs index 187f2566..b30171f7 100644 --- a/src/UI/Index/Main.hs +++ b/src/UI/Index/Main.hs @@ -1,11 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} module UI.Index.Main where -import Brick.AttrMap (AttrName) -import Data.Monoid ((<>)) import qualified Brick.Main as M import Brick.Types (Padding(..), Widget) import qualified Brick.Types as T +import Brick.AttrMap (AttrName) import Brick.Widgets.Core (hLimit, padLeft, txt, vBox, vLimit, withAttr, (<+>)) import Data.Text (unwords) @@ -22,7 +21,11 @@ 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 +import Config.Main + (listNewMailAttr, listNewMailSelectedAttr, mailTagsAttr, + listSelectedAttr, listAttr) drawMain :: AppState -> [Widget Name] drawMain s = [ui] @@ -33,40 +36,32 @@ 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 = - 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 +listDrawElement :: AppState -> Bool -> NotmuchMail -> Widget Name +listDrawElement s sel a = + let settings = view (asConfig . confNotmuch) s + isNewMail = mailIsNew (view nmNewTag settings) a 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) - in (newMail a $ selected widget) + (padLeft Max $ renderMailTagsWidget a (view nmNewTag settings)) + in (withAttr (getListAttr isNewMail sel) widget) +getListAttr :: Bool -- ^ new? + -> Bool -- ^ selected? + -> AttrName +getListAttr True True = listNewMailSelectedAttr -- new and selected +getListAttr True False = listNewMailAttr -- new and not selected +getListAttr False True = listSelectedAttr -- not new but selected +getListAttr False False = listAttr -- not selected and not new formatDate :: UTCTime -> Text formatDate t = pack $ formatTime defaultTimeLocale "%d/%b" (utctDay t) -listAttr :: AttrName -listAttr = L.listAttr - -listSelectedAttr :: AttrName -listSelectedAttr = L.listSelectedAttr - -listNewMailAttr :: AttrName -listNewMailAttr = L.listAttr <> "newmail" - -mailAttr :: AttrName -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 diff --git a/src/UI/Mail/Main.hs b/src/UI/Mail/Main.hs index a57496d3..440d247f 100644 --- a/src/UI/Mail/Main.hs +++ b/src/UI/Mail/Main.hs @@ -2,7 +2,6 @@ module UI.Mail.Main where import qualified Brick.Main as M -import Brick.AttrMap (AttrName) import Brick.Types (Padding(..), ViewportType(..), Widget) import qualified Brick.Types as T import Brick.Widgets.Core @@ -10,7 +9,6 @@ import Brick.Widgets.Core withAttr) import qualified Brick.Widgets.List as L -import Data.Monoid ((<>)) import Codec.MIME.Type (MIMEContent(..), MIMEParam(..), MIMEValue(..), Type(..), showMIMEType) @@ -18,14 +16,17 @@ 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 +import Config.Main (headerKeyAttr, headerValueAttr) -- | Instead of using the entire rendering area to show the email, we still show -- the index in context above the mail. @@ -84,15 +85,6 @@ headerFilter s = Filtered -> view (asConfig . confMailView . mvHeadersToShow) s ShowAll -> const True -headerAttr :: AttrName -headerAttr = "header" - -headerKeyAttr :: AttrName -headerKeyAttr = headerAttr <> "key" - -headerValueAttr :: AttrName -headerValueAttr = headerAttr <> "value" - -- | event handling for viewing a single mail -- | The mail view shows a shortened list of mails. Forward all key strokes to @@ -109,4 +101,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' diff --git a/src/UI/Status/Main.hs b/src/UI/Status/Main.hs index de5fe29a..c9853820 100644 --- a/src/UI/Status/Main.hs +++ b/src/UI/Status/Main.hs @@ -2,10 +2,8 @@ module UI.Status.Main where import Types (NotmuchMail) -import Brick.AttrMap (AttrName) import Brick.Types (Widget) import Brick.Widgets.Core (str, withAttr, (<+>)) -import Data.Monoid ((<>)) import qualified Brick.Widgets.List as L import Control.Lens.Getter (view) import Data.Maybe (fromMaybe) @@ -14,6 +12,7 @@ import Prelude hiding (length) import UI.Draw.Main (fillLine) import Types (AppState, Name, asError, asMailIndex, miListOfMails) +import Config.Main (statusbarAttr, statusbarErrorAttr) statusbar :: AppState -> Widget Name statusbar s = @@ -25,12 +24,6 @@ statusbar s = in withAttr statusbarAttr $ str "Purebred: " <+> str "Item " <+> currentIndexW l <+> str " of " <+> total <+> fillLine -statusbarAttr :: AttrName -statusbarAttr = "statusbar" - -statusbarErrorAttr :: AttrName -statusbarErrorAttr = statusbarAttr <> "error" - currentIndexW :: L.List Name NotmuchMail -> Widget Name currentIndexW l = str $ show $ currentIndex l diff --git a/stack.yaml b/stack.yaml index 75a7207a..ee25d71b 100644 --- a/stack.yaml +++ b/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 diff --git a/test/TestMail.hs b/test/TestMail.hs index 09ae9f57..ff11320d 100644 --- a/test/TestMail.hs +++ b/test/TestMail.hs @@ -1,16 +1,25 @@ {-# LANGUAGE OverloadedStrings #-} module TestMail where +import Data.Text (Text, pack) import Types (NotmuchMail(..)) import Storage.ParsedMail (parseMail) +import Storage.Notmuch (addTag, removeTag) import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck + (testProperty, Arbitrary, arbitrary, listOf, choose, Gen) import Test.Tasty.HUnit (testCase, (@?=)) -import Data.Time.Calendar (fromGregorian) -import Data.Time.Clock (secondsToDiffTime, UTCTime(..)) +import Test.QuickCheck.Utf8 (utf8BS, genValidUtf8) +import Data.Text.Arbitrary () +import Data.Time.Calendar (fromGregorian, Day(..)) +import Data.Time.Clock (secondsToDiffTime, UTCTime(..), DiffTime) mailTests :: TestTree -mailTests = testGroup "mail parsing tests" [testMailHasBeenMoved] +mailTests = + testGroup + "mail parsing tests" + [testMailHasBeenMoved, testAddingTags, testRemovingTags] testMailHasBeenMoved :: TestTree @@ -18,5 +27,38 @@ testMailHasBeenMoved = testCase "does not crash" $ do msg <- parseMail m Left "/path/does/not/exist: openFile: does not exist (No such file or directory)" @?= msg where - m = NotmuchMail "" "" "/path/does/not/exist" t ["unread"] True + m = NotmuchMail "" "" "/path/does/not/exist" t ["unread"] "0815" t = UTCTime (fromGregorian 2017 7 7) (secondsToDiffTime 39292) + + +testAddingTags :: TestTree +testAddingTags = testProperty "no duplicates when adding tags" propNoDuplicatesAdded + where + propNoDuplicatesAdded :: NotmuchMail -> Text -> Bool + propNoDuplicatesAdded m a = addTag (addTag m a) a == addTag m a + +testRemovingTags = testProperty "remove tags" propRemoveTags + where + propRemoveTags :: NotmuchMail -> Text -> Bool + propRemoveTags m a = removeTag (removeTag m a) a == removeTag m a + +instance Arbitrary NotmuchMail where + arbitrary = + NotmuchMail <$> + (pack <$> arbitrary) <*> + (pack <$> arbitrary) <*> + arbitrary <*> + arbitrary <*> + listOf genValidUtf8 <*> + utf8BS + +instance Arbitrary UTCTime where + arbitrary = UTCTime <$> arbitrary <*> genDiffTime + +instance Arbitrary Day where + arbitrary = ModifiedJulianDay <$> arbitrary + +genDiffTime :: Gen DiffTime +genDiffTime = do + i <- choose (0, 200000) + pure $ secondsToDiffTime i diff --git a/test/TestUserAcceptance.hs b/test/TestUserAcceptance.hs index 9e802687..20f1fd7f 100644 --- a/test/TestUserAcceptance.hs +++ b/test/TestUserAcceptance.hs @@ -10,7 +10,9 @@ import Control.Concurrent (newEmptyMVar, putMVar, takeMVar, MVar, threadDelay) import Control.Exception (catch, IOException) import System.IO (hPutStr, stderr) -import Control.Monad (void) +import System.Environment (lookupEnv) +import Control.Monad (void, when) +import Data.Maybe (isJust) import Data.List (isInfixOf) import System.Process (callProcess, readProcess) @@ -29,7 +31,8 @@ systemTests = [ testUserViewsMailSuccessfully , testUserCanManipulateNMQuery , testUserCanSwitchBackToIndex - , testCanToggleHeaders] + , testCanToggleHeaders + , testSetsMailToRead] -- | maximum amount of time we allow a step to run until we fail it -- 6 seconds should be plenty @@ -37,6 +40,40 @@ testTimeout :: Integer testTimeout = 10 ^ 6 * 8 +testSetsMailToRead :: + TestTree +testSetsMailToRead = + withResource setUp tearDown $ + \mdir -> + tmuxSession mdir "user can toggle read tag" steps + where steps = + [ApplicationStep + "" + "is unread (bold)" + False + "is Purebred" + (\o _ -> + assertBool "regex doesn't match out" $ + o =~ ("\ESC\\[1;.*Testmail" :: String)) + ,ApplicationStep "Enter" "views mail" False "This is a test mail" assertSubstrInOutput + ,ApplicationStep + "Escape" + "is set to read" + False + "is Purebred" + (\o _ -> + assertBool "regex doesn't match out" $ + o =~ ("\ESC\\[37.*Testmail" :: String)) + ,ApplicationStep + "t" + "toggled back to unread" + False + "1;37;43m" -- wait for the screen turns bold + (\o _ -> + assertBool "regex doesn't match out" $ + o =~ ("\ESC\\[1;.*Testmail" :: String))] + + testCanToggleHeaders :: TestTree testCanToggleHeaders = @@ -61,7 +98,7 @@ testCanToggleHeaders = "h" "filtered headers" False - "from" + "This is a test mail" (\o _ -> assertBool "regex matches out" $ o =~ ("Purebred.*\n.*from" :: String))] @@ -285,6 +322,8 @@ runSteps stepfx steps = (\a -> do stepfx (asDescription a) out <- performStep "purebredtest" a + d <- lookupEnv "DEBUG" + when (isJust d) $ hPutStr stderr ("\n\n" ++ asDescription a ++ "\n\n" ++ out) ((asAssertInOutput a) out (asExpected a))) steps