Derive the migration advisory lock namespace

src/Nuthatch/Db.hs

@@ -1,5 +1,6 @@
 module Nuthatch.Db
   ( Db
+  , migrationAdvisoryLockKey
   , withDb
   , migrate
   , ensurePersonalPool
@@ -23,9 +24,10 @@ import           Data.Pool
   , setNumStripes
   , withResource
   )
+import           Data.Int (Int64)
 import           Database.PostgreSQL.Simple
   ( Connection
-  , Only
+  , Only (..)
   , close
   , connectPostgreSQL
   )
@@ -46,6 +48,10 @@ import           Nuthatch.Types
 
 type Db = Pool Connection
 
+migrationAdvisoryLockKey :: Int64
+-- Low 63 bits of the leading SHA-256("nuthatch") word keep the bigint key positive.
+migrationAdvisoryLockKey = 271439036354387575
+
 withDb :: PostgresConfig -> (Db -> IO a) -> IO a
 withDb cfg action = do
   let mk = connectPostgreSQL (BS8.pack (revealSecret (cfgPgConn cfg)))
@@ -57,8 +63,9 @@ withDb cfg action = do
 migrate :: Db -> FilePath -> ProductConfig -> IO ()
 migrate db migrationDirectory cfg = withResource db $ \conn -> do
   void
-    (PG.query_ conn
+    (PG.query conn
-      "SELECT pg_advisory_lock(564741953576419031) IS NULL"
+      "SELECT pg_advisory_lock(?) IS NULL"
+      (Only migrationAdvisoryLockKey)
       :: IO [Only Bool])
   result <-
     runMigration conn defaultOptions
@@ -67,8 +74,9 @@ migrate db migrationDirectory cfg = withResource db $ \conn -> do
           <> MigrationValidation (MigrationDirectory migrationDirectory)
       )
       `finally` void
-        (PG.query_ conn
+        (PG.query conn
-          "SELECT pg_advisory_unlock(564741953576419031)"
+          "SELECT pg_advisory_unlock(?)"
+          (Only migrationAdvisoryLockKey)
           :: IO [Only Bool])
   case result of
     MigrationSuccess ->

test/Integration.hs

@@ -1,16 +1,22 @@
 module Main (main) where
 
 import           Control.Concurrent.Async (concurrently, mapConcurrently)
-import           Control.Exception (SomeException, try)
+import           Control.Exception (SomeException, bracket_, try)
-import           Control.Monad (unless)
+import           Control.Monad (unless, void)
 import           Crypto.Hash (Digest, SHA256, hashlazy)
+import           Data.Bits ((.&.))
 import qualified Data.ByteArray as BA
+import qualified Data.ByteString as BS
 import qualified Data.ByteString.Base16 as B16
 import qualified Data.ByteString.Lazy as BL
+import           Data.Int (Int64)
 import           Data.List (sort)
+import qualified Data.Pool as Pool
 import           Data.Text (Text)
 import qualified Data.Text.Encoding as TE
-import           Database.PostgreSQL.Simple (Only (..))
+import           Data.Word (Word64)
+import           Database.PostgreSQL.Simple (Connection, Only (..))
+import qualified Database.PostgreSQL.Simple as PG
 import           Nuthatch.Config
   ( Config (..)
   , ProductConfig (..)
@@ -24,6 +30,7 @@ import           Nuthatch.Db
   , configurePoolLimit
   , ensurePersonalPool
   , migrate
+  , migrationAdvisoryLockKey
   , withDb
   , withTransaction
   )
@@ -38,6 +45,7 @@ main = do
   withDb (cfgPostgres config) $ \database -> do
     migrate database "sql" (cfgProduct config)
     migrate database "sql" (cfgProduct config)
+    verifyMigrationLock database
     verifySchema database
     verifyAdmission database config
     verifyRowDecoder database
@@ -45,6 +53,57 @@ main = do
   verifyStorage config store
   putStrLn "Storage foundation integration gate passed"
 
+verifyMigrationLock :: Db -> IO ()
+verifyMigrationLock database = do
+  assertEqual
+    "migration lock key follows SHA-256 namespace derivation"
+    migrationLockKeyFromHash
+    migrationAdvisoryLockKey
+  Pool.withResource database $ \holder ->
+    Pool.withResource database $ \contender -> do
+      bracket_
+        (acquireAdvisoryLock holder)
+        (void (releaseAdvisoryLock holder))
+        (do
+          admitted <- tryAdvisoryLock contender
+          assert "migration lock excludes another session" (not admitted))
+      admitted <- tryAdvisoryLock contender
+      assert "migration lock admits another session after release" admitted
+      released <- releaseAdvisoryLock contender
+      assert "contending session releases migration lock" released
+
+migrationLockKeyFromHash :: Int64
+migrationLockKeyFromHash =
+  fromIntegral
+    (BS.foldl' appendByte 0 (BS.take 8 digestBytes) .&. maxSignedKey)
+  where
+    digestBytes = BA.convert (hashlazy "nuthatch" :: Digest SHA256)
+    appendByte accumulator byte =
+      accumulator * 256 + fromIntegral byte
+    maxSignedKey = 0x7fffffffffffffff :: Word64
+
+acquireAdvisoryLock :: Connection -> IO ()
+acquireAdvisoryLock connection =
+  void
+    (PG.query connection
+      "SELECT pg_advisory_lock(?) IS NULL"
+      (Only migrationAdvisoryLockKey)
+      :: IO [Only Bool])
+
+tryAdvisoryLock :: Connection -> IO Bool
+tryAdvisoryLock connection = do
+  [Only admitted] <- PG.query connection
+    "SELECT pg_try_advisory_lock(?)"
+    (Only migrationAdvisoryLockKey)
+  pure admitted
+
+releaseAdvisoryLock :: Connection -> IO Bool
+releaseAdvisoryLock connection = do
+  [Only released] <- PG.query connection
+    "SELECT pg_advisory_unlock(?)"
+    (Only migrationAdvisoryLockKey)
+  pure released
+
 verifySchema :: Db -> IO ()
 verifySchema database = do
   tables <- Db.query_ database