content: -- This file is part of purebred
  -- Copyright (C) 2022 Fraser Tweedale and Róman Joost
  --
  -- purebred is free software: you can redistribute it and/or modify
  -- it under the terms of the GNU Affero General Public License as published by
  -- the Free Software Foundation, either version 3 of the License, or
  -- (at your option) any later version.
  --
  -- This program is distributed in the hope that it will be useful,
  -- but WITHOUT ANY WARRANTY; without even the implied warranty of
  -- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  -- GNU Affero General Public License for more details.
  --
  -- You should have received a copy of the GNU Affero General Public License
  -- along with this program.  If not, see <http://www.gnu.org/licenses/>.
  
  {-# LANGUAGE DataKinds #-}
  {-# LANGUAGE OverloadedStrings #-}
  
  module Purebred.Storage.Client
    (
      -- * API
      -- ** Threads
      getThreads
    , getThreadMessages
    , countMessages
  
      -- ** Messages
    , messageTagModify
    , mailFilepath
    , indexFilePath
    , unindexFilePath
  
    -- * Re-exports
    , Server
    ) where
  
  import Control.Concurrent (ThreadId, forkIO)
  import Control.Concurrent.STM (atomically , newEmptyTMVarIO, readTMVar)
  import Control.Lens (firstOf, folded, view)
  import Control.Monad ((<=<), void, when)
  import Control.Monad.Except (ExceptT, MonadError, liftEither, throwError)
  import Control.Monad.IO.Class (MonadIO, liftIO)
  import Data.Foldable (toList)
  import Data.Function (on)
  import Data.Functor.Compose (Compose(..))
  import Data.Maybe (fromMaybe)
  import Data.List (nub, sort)
  import qualified Data.Text as T
  import Data.Traversable (for)
  import qualified System.Directory
  import System.IO.Unsafe (unsafeInterleaveIO)
  
  import qualified Data.Vector as V
  import qualified Notmuch
  
  import Purebred.Storage.Server
  import Purebred.Storage.Tags (TagOp, tagItem, tags)
  import Purebred.System (tryIO)
  import Purebred.Types (NotmuchThread(..), NotmuchMail(..), decodeLenient, mailId, thId)
  import Purebred.Types.Error (Error(MessageNotFound, ThreadNotFound))
  import Purebred.Types.Items (Items, fromList)
  
  ---
  --- Interacting with server
  ---
  
  type Call params result =
    forall m. (MonadIO m, MonadError Error m)
    => params -> Server -> m result
  
  type Call2 param1 param2 result =
    forall m. (MonadIO m, MonadError Error m)
    => param1 -> param2 -> Server -> m result
  
  -- | Send command and await result
  runCommand
    :: (MonadError Error m, MonadIO m)
    => (Notmuch.Database Notmuch.RW -> ExceptT Error IO a) -> Server -> m a
  runCommand core server = do
    result <- liftIO $ do
      box <- newEmptyTMVarIO
      enqueue server $ Command core (Just box)
      atomically $ readTMVar box
    liftEither result
  
  -- | Enqueue command and return immediately, discarding result
  _sendCommand
    :: (MonadIO m)
    => (Notmuch.Database Notmuch.RW -> ExceptT Error IO a) -> Server -> m ()
  _sendCommand core server = void . liftIO . enqueue server $ Command core Nothing
  
  -- | Enqueue command and fork an unbound thread to handle the result.
  -- Returns 'ThreadId' of the result handler thread.
  _runCommandWithHandler
    :: (MonadIO m)
    => (Notmuch.Database Notmuch.RW -> ExceptT Error IO a)
    -> (Either Error a -> IO ())
    -> Server -> m ThreadId
  _runCommandWithHandler core handler server =
    liftIO $ do
      box <- newEmptyTMVarIO
      enqueue server $ Command core (Just box)
      forkIO $ do
        r <- atomically $ readTMVar box
        handler r
  
  ---
  --- Database actions
  ---
  
  -- | Apply tag operations on all given mails and write the resulting
  -- tags to the database
  messageTagModify
    :: (Traversable t)
    => Call2 [TagOp] (t NotmuchMail) (t NotmuchMail)
  messageTagModify ops msgs = runCommand $ \db ->
    for msgs $ \m -> do
      let m' = tagItem ops m
      -- only act if tags actually changed
      when (((/=) `on` (sort . nub . view tags)) m m') $
        getMessage db (view mailId m')
        >>= Notmuch.messageSetTags (view tags m')
      pure m'
  
  -- | Returns the absolute path to the email. Typically used by the
  -- email parser.
  --
  mailFilepath :: Call NotmuchMail FilePath
  mailFilepath m = runCommand $ \db ->
    getMessage db (view mailId m) >>= Notmuch.messageFilename
  
  -- | Return the number of messages for the given free-form search term
  countMessages :: Call T.Text Int
  countMessages expr = runCommand $ \db ->
    Notmuch.query db (Notmuch.Bare $ T.unpack expr)
    >>= Notmuch.queryCountMessages
  
  -- | Creates a vector of threads from a free-form search term
  --
  getThreads :: Call T.Text (Items NotmuchThread)
  getThreads expr = runCommand $ \db ->
    Notmuch.query db (Notmuch.Bare $ T.unpack expr)
      >>= Notmuch.threads
      -- note: we use lazyTraverse and "chunked" construction, but
      -- whether it will actually be lazy depends on the variant of
      -- 'Items' in use.  For a Vector, it is strict and non-chunked.
      >>= liftIO . fmap (fromList 128) . lazyTraverse threadToThread
    where
    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
  
  -- | Returns a vector of *all* messages belonging to a collection of threads
  --
  getThreadMessages :: (Traversable t) => Call (t NotmuchThread) (V.Vector NotmuchMail)
  getThreadMessages threads = runCommand $ \db -> do
    msgs <- Compose  -- 'collapse' nested 't ([] a)'
            <$> traverse (Notmuch.messages <=< getThread db . view thId) threads
    mails <- traverse (liftIO . messageToMail) msgs
    pure . V.fromList . toList $ mails
  
    where
    -- Retrieve thread by ID.  libnotmuch does not provide a direct
    -- way to query a thread.  Perform a general query and pop the
    -- first result, or fail if the result is empty.
    --
    getThread db tid = do
      t <- Notmuch.query db (Notmuch.Thread tid) >>= Notmuch.threads
      maybe (throwError (ThreadNotFound tid)) pure (firstOf folded t)
  
    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
  
  indexFilePath :: Call2 FilePath [Notmuch.Tag] ()
  indexFilePath path tags_ = runCommand $ \db ->
    Notmuch.indexFile db path >>= Notmuch.messageSetTags tags_
  
  unindexFilePath :: Call FilePath ()
  unindexFilePath path = runCommand $ \db ->
    void $ Notmuch.removeFile db path *> tryIO (System.Directory.removeFile path)
  
  ---
  --- Helper functions
  ---
  
  lazyTraverse :: (a -> IO b) -> [a] -> IO [b]
  lazyTraverse f =
    foldr (\x ys -> (:) <$> f x <*> unsafeInterleaveIO ys) (pure [])
  
  fixupWhitespace :: T.Text -> T.Text
  fixupWhitespace = T.map f . T.filter (/= '\n')
    where f '\t' = ' '
          f c = c
  
  -- | Get message by message ID, throwing MessageNotFound if not found
  --
  getMessage
    :: (MonadError Error m, MonadIO m)
    => Notmuch.Database mode -> Notmuch.MessageId -> m (Notmuch.Message 0 mode)
  getMessage db msgId =
    Notmuch.findMessage db msgId
    >>= maybe (throwError (MessageNotFound msgId)) pure
  