Add databaseRevision API

.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 <<EOF
+          flags: +demos
           EOF
           if $HEADHACKAGE; then
           echo "allow-newer: $($HCPKG list --simple-output | sed -E 's/([a-zA-Z-]+)-[0-9.]+/*:\1,/g')" >> cabal.project

cabal.haskell-ci

@@ -0,0 +1,2 @@
+raw-project
+  flags: +demos

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,18 +136,15 @@ 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
   import: common
   if !flag(demos)
     buildable: False
   hs-source-dirs: tools
-  ghc-options: -Wall
   main-is: IndexFile.hs
   build-depends:
     , notmuch

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'.

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.

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 <http://www.gnu.org/licenses/>.
+
+{-
+
+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

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)