{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TupleSections #-}
module Storage.Notmuch (
getThreads
, getThreadMessages
, countThreads
, messageTagModify
, mailFilepath
, indexFilePath
, unindexFilePath
, ManageTags(..)
, hasTag
, tagItem
, addTags
, removeTags
, getDatabasePath
, withDatabase
) where
import Control.Monad ((<=<), (>=>), when)
import Data.Function (on)
import System.IO.Unsafe (unsafeInterleaveIO)
import Data.Foldable (toList)
import Data.Functor.Compose (Compose(..))
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Except (MonadError, throwError, ExceptT, runExceptT)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as LB
import Data.Traversable (traverse)
import Data.List (union, notElem, nub, sort)
import Data.Maybe (fromMaybe)
import Data.Functor (($>))
import qualified Data.Vector as Vec
import System.Exit (ExitCode(..))
import qualified System.Directory as Directory (removeFile)
import qualified Data.Text as T
import Control.Lens (view, over, set, firstOf, folded, Lens')
import qualified Notmuch
import Error
import Types
import Purebred.LazyVector
import Purebred.System.Process (readProcess, proc)
import Purebred.System (tryIO)
import Purebred.Types.IFC (sanitiseText, untaint)
messageTagModify
:: (Traversable t, MonadError Error m, MonadIO m)
=> FilePath
-> [TagOp]
-> t NotmuchMail
-> m (t NotmuchMail)
messageTagModify dbpath ops xs =
withDatabase dbpath (\db -> applyTags ops db xs)
applyTags
:: (MonadError Error m, MonadIO m, Traversable t)
=> [TagOp]
-> Notmuch.Database Notmuch.RW
-> t NotmuchMail
-> m (t NotmuchMail)
applyTags ops db = traverse $ \m -> do
let m' = tagItem ops m
when (haveTagsChanged m m')
(tagsToMessage (view mailTags m') (view mailId m') db)
pure m'
tagItem :: ManageTags a => [TagOp] -> a -> a
tagItem ops mail = foldl (flip applyTagOp) mail ops
haveTagsChanged :: NotmuchMail -> NotmuchMail -> Bool
haveTagsChanged = (/=) `on` (sort . nub . view mailTags)
applyTagOp :: (ManageTags a) => TagOp -> a -> a
applyTagOp (AddTag t) = addTags [t]
applyTagOp (RemoveTag t) = removeTags [t]
applyTagOp ResetTags = setTags []
class ManageTags a where
tags :: Lens' a [Tag]
setTags :: (ManageTags a) => [Tag] -> a -> a
setTags = set tags
addTags :: (ManageTags a) => [Tag] -> a -> a
addTags tgs = over tags (`union` tgs)
removeTags :: (ManageTags a) => [Tag] -> a -> a
removeTags tgs = over tags (filter (`notElem` tgs))
hasTag :: (ManageTags a) => Tag -> a -> Bool
hasTag t x = t `elem` view tags x
instance ManageTags NotmuchMail where
tags = mailTags
instance ManageTags NotmuchThread where
tags = thTags
withDatabase
:: (Notmuch.AsNotmuchError e, Notmuch.Mode a, MonadError e m, MonadIO m)
=> FilePath
-> (Notmuch.Database a -> ExceptT e IO c)
-> m c
withDatabase dbpath f =
Notmuch.databaseOpen dbpath >>= liftIO . runExceptT . f
>>= either throwError pure
withDatabaseReadOnly
:: (Notmuch.AsNotmuchError e, MonadError e m, MonadIO m)
=> FilePath
-> (Notmuch.Database Notmuch.RO -> ExceptT e IO c)
-> m c
withDatabaseReadOnly = withDatabase
mailFilepath
:: (MonadError Error m, MonadIO m)
=> NotmuchMail -> FilePath -> m FilePath
mailFilepath m dbpath =
withDatabaseReadOnly dbpath go
where
go db = getMessage db (view mailId m) >>= Notmuch.messageFilename
tagsToMessage
:: (MonadError Error m, MonadIO m)
=> [Notmuch.Tag] -> B.ByteString -> Notmuch.Database Notmuch.RW -> m ()
tagsToMessage xs id' db = getMessage db id' >>= Notmuch.messageSetTags xs
getMessage
:: (MonadError Error m, MonadIO m)
=> Notmuch.Database mode -> B.ByteString -> m (Notmuch.Message 0 mode)
getMessage db msgId =
Notmuch.findMessage db msgId
>>= maybe (throwError (MessageNotFound msgId)) pure
messageToMail
:: Notmuch.Message n a
-> IO NotmuchMail
messageToMail m = do
tgs <- Notmuch.tags m
NotmuchMail
<$> (fixupWhitespace . decodeLenient . fromMaybe "" <$> Notmuch.messageHeader "Subject" m)
<*> (decodeLenient . fromMaybe "" <$> Notmuch.messageHeader "From" m)
<*> Notmuch.messageDate m
<*> pure tgs
<*> Notmuch.messageId m
getDatabasePath :: IO FilePath
getDatabasePath = do
let cmd = "notmuch"
let args = ["config", "get", "database.path"]
(exitc, stdout, err) <- readProcess $ proc cmd args
case exitc of
ExitFailure _ -> error (untaint decode err)
ExitSuccess -> pure (filter (/= '\n') (untaint decode stdout))
where
decode = T.unpack . sanitiseText . decodeLenient . LB.toStrict
countThreads ::
(MonadError Error m, MonadIO m) => T.Text -> FilePath -> m Int
countThreads query fp =
withDatabaseReadOnly fp $
flip Notmuch.query (Notmuch.Bare $ T.unpack query)
>=> Notmuch.queryCountMessages
getThreads
:: (MonadError Error m, MonadIO m)
=> T.Text
-> NotmuchSettings FilePath
-> m (V (Toggleable NotmuchThread))
getThreads s settings =
withDatabaseReadOnly (view nmDatabase settings) $
flip Notmuch.query (Notmuch.Bare $ T.unpack s)
>=> Notmuch.threads
>=> liftIO . fmap (fromList 128) . lazyTraverse (fmap (False,) . threadToThread)
lazyTraverse :: (a -> IO b) -> [a] -> IO [b]
lazyTraverse f =
foldr (\x ys -> (:) <$> f x <*> unsafeInterleaveIO ys) (pure [])
getThreadMessages
:: (MonadError Error m, MonadIO m, Traversable t)
=> FilePath
-> t NotmuchThread
-> m (Vec.Vector (Toggleable NotmuchMail))
getThreadMessages fp ts = withDatabaseReadOnly fp go
where
go db = do
msgs <-
Data.Functor.Compose.Compose
<$> traverse (Notmuch.messages <=< getThread db . view thId) ts
mails <- traverse (liftIO . messageToMail) msgs
pure . Vec.fromList . toList $ fmap (False,) mails
getThread
:: (MonadError Error m, MonadIO m)
=> Notmuch.Database mode -> B.ByteString -> m (Notmuch.Thread mode)
getThread db tid = do
t <- Notmuch.query db (Notmuch.Thread tid) >>= Notmuch.threads
maybe (throwError (ThreadNotFound tid)) pure (firstOf folded t)
threadToThread
:: Notmuch.Thread a
-> IO NotmuchThread
threadToThread m = do
tgs <- Notmuch.tags m
auth <- Notmuch.threadAuthors m
NotmuchThread
<$> (fixupWhitespace . decodeLenient <$> Notmuch.threadSubject m)
<*> pure (view Notmuch.matchedAuthors auth)
<*> Notmuch.threadNewestDate m
<*> pure tgs
<*> Notmuch.threadTotalMessages m
<*> Notmuch.threadId m
fixupWhitespace :: T.Text -> T.Text
fixupWhitespace = T.map f . T.filter (/= '\n')
where f '\t' = ' '
f c = c
indexFilePath ::
(MonadError Error m, MonadIO m)
=> FilePath
-> FilePath
-> [Tag]
-> m ()
indexFilePath dbpath fp tgs =
withDatabase
dbpath
(\db -> Notmuch.indexFile db fp >>= Notmuch.messageSetTags tgs)
unindexFilePath ::
(MonadError Error m, MonadIO m)
=> FilePath
-> FilePath
-> m ()
unindexFilePath dbpath fp =
withDatabase
dbpath
(\db -> Notmuch.removeFile db fp *> tryIO (Directory.removeFile fp $> ()))