diff --git a/.github/workflows/haskell-ci.yml b/.github/workflows/haskell-ci.yml index efaf764..d517941 100644 --- a/.github/workflows/haskell-ci.yml +++ b/.github/workflows/haskell-ci.yml @@ -720,6 +720,7 @@ jobs: echo "package notmuch" >> cabal.project echo " ghc-options: -Werror=missing-methods" >> cabal.project cat >> cabal.project <> cabal.project diff --git a/cabal.haskell-ci b/cabal.haskell-ci new file mode 100644 index 0000000..1c145c7 --- /dev/null +++ b/cabal.haskell-ci @@ -0,0 +1,2 @@ +raw-project + flags: +demos diff --git a/notmuch.cabal b/notmuch.cabal index 5e67d6d..765eb69 100644 --- a/notmuch.cabal +++ b/notmuch.cabal @@ -84,8 +84,8 @@ library , time , text - build-tools: - c2hs >= 0.19.1 + build-tool-depends: + c2hs:c2hs >= 0.19.1 extra-libraries: notmuch @@ -98,17 +98,24 @@ executable hs-notmuch-files if !flag(demos) buildable: False hs-source-dirs: tools - ghc-options: -Wall main-is: Files.hs build-depends: , notmuch +executable hs-notmuch-dbinfo + import: common + if !flag(demos) + buildable: False + hs-source-dirs: tools + main-is: DbInfo.hs + build-depends: + , notmuch + executable hs-notmuch-tag-message import: common if !flag(demos) buildable: False hs-source-dirs: tools - ghc-options: -Wall main-is: TagMessage.hs build-depends: , bytestring @@ -119,10 +126,8 @@ executable hs-notmuch-tag-count if !flag(demos) buildable: False hs-source-dirs: tools - ghc-options: -Wall main-is: TagCount.hs build-depends: - , bytestring , containers , notmuch @@ -131,10 +136,8 @@ executable hs-notmuch-tag-set if !flag(demos) buildable: False hs-source-dirs: tools - ghc-options: -Wall main-is: TagSet.hs build-depends: - , bytestring , notmuch executable hs-notmuch-index-file @@ -142,7 +145,6 @@ executable hs-notmuch-index-file if !flag(demos) buildable: False hs-source-dirs: tools - ghc-options: -Wall main-is: IndexFile.hs build-depends: , notmuch diff --git a/src/Notmuch.hs b/src/Notmuch.hs index 9aeee2f..638858f 100644 --- a/src/Notmuch.hs +++ b/src/Notmuch.hs @@ -72,6 +72,7 @@ module Notmuch , databaseOpenReadOnly , databasePath , databaseVersion + , databaseRevision , Database -- ** Database modes , Mode @@ -146,6 +147,7 @@ import Control.Exception (bracket) import Control.Monad.Except (MonadError(..)) import Control.Monad.IO.Class (MonadIO(..)) import Data.Foldable (traverse_) +import Foreign.C.Types (CULong) import GHC.Generics (Generic) import Control.DeepSeq (NFData) @@ -240,6 +242,17 @@ databaseOpenReadOnly = database_open databaseVersion :: MonadIO m => Database a -> m Int databaseVersion = liftIO . database_get_version +-- | Get the revision and UUID of the database. +-- +-- The revision number increases monotonically with each commit to +-- the database (although rollover is possible). The "UUID" is an +-- __opaque__ string that persists until e.g. database compaction. +-- Revision numbers are only comparable where the UUID strings are +-- equal. +-- +databaseRevision :: MonadIO m => Database a -> m (CULong, String) +databaseRevision = liftIO . database_get_revision + -- | Look for a particular message in the database. findMessage :: (AsNotmuchError e, MonadError e m, MonadIO m) @@ -322,9 +335,7 @@ messageRemoveTag :: (MonadIO m) => Tag -> Message n RW -> m () messageRemoveTag tag msg = liftIO $ message_remove_tag msg tag -- | Returns only messages in a thread which are not replies to other messages in the thread. -threadToplevelMessages - :: (AsNotmuchError e, MonadError e m, MonadIO m) - => Thread a -> m [Message 0 a] +threadToplevelMessages :: (MonadIO m) => Thread a -> m [Message 0 a] threadToplevelMessages = thread_get_toplevel_messages -- | /O(1)/ Date of the newest message in a 'Thread'. diff --git a/src/Notmuch/Binding.chs b/src/Notmuch/Binding.chs index 38ba759..87f1abd 100644 --- a/src/Notmuch/Binding.chs +++ b/src/Notmuch/Binding.chs @@ -251,6 +251,14 @@ database_get_version :: Database a -> IO Int database_get_version db = fromIntegral <$> withDatabase db {#call unsafe database_get_version #} +database_get_revision :: Database a -> IO (CULong, String) +database_get_revision db = + withDatabase db $ \db' -> + alloca $ \uuidPtr -> do + rev <- {#call unsafe database_get_revision #} db' uuidPtr + uuid <- peekCString =<< peek uuidPtr + pure (rev, uuid) + -- | Index a file with the default indexing options. -- (This binding does not yet provide a way to change -- the indexing options.) Returns the indexed message. diff --git a/tools/DbInfo.hs b/tools/DbInfo.hs new file mode 100644 index 0000000..a14bea6 --- /dev/null +++ b/tools/DbInfo.hs @@ -0,0 +1,47 @@ +-- This file is part of hs-notmuch - Haskell Notmuch binding +-- Copyright (C) 2022 Yikai Zhao +-- +-- hs-notmuch is free software: you can redistribute it and/or modify +-- it under the terms of the GNU 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 General Public License for more details. +-- +-- You should have received a copy of the GNU General Public License +-- along with this program. If not, see . + +{- + +Print version and revision info for a database. + +-} + +{-# LANGUAGE LambdaCase #-} + +import Control.Monad.Except (runExceptT) +import System.Environment (getArgs) +import System.Exit (die) + +import Notmuch + + +main :: IO () +main = getArgs >>= \case + [dbDir] -> go dbDir + _ -> putStrLn "usage: hs-notmuch-dbinfo DB-DIR" + +go :: String -> IO () +go dbDir = do + (version, (revision, uuid)) <- runExceptT ( + do + db <- databaseOpenReadOnly dbDir + (,) <$> databaseVersion db <*> databaseRevision db + ) >>= either (die . (show :: Status -> String)) pure + putStr "Path: " *> putStrLn dbDir + putStr "Version: " *> print version + putStr "Revision: " *> print revision + putStr "UUID: " *> putStrLn uuid diff --git a/tools/IndexFile.hs b/tools/IndexFile.hs index a818804..a215d38 100644 --- a/tools/IndexFile.hs +++ b/tools/IndexFile.hs @@ -22,7 +22,8 @@ Index or remove the given file. {-# LANGUAGE LambdaCase #-} -import Control.Monad.Except ((>=>), runExceptT) +import Control.Monad ((>=>)) +import Control.Monad.Except (runExceptT) import System.Environment (getArgs) import System.Exit (die)