Derive the migration advisory lock namespace

test/Integration.hs

@@ -1,16 +1,22 @@
 module Main (main) where
 
 import           Control.Concurrent.Async (concurrently, mapConcurrently)
-import           Control.Exception (SomeException, try)
-import           Control.Monad (unless)
+import           Control.Exception (SomeException, bracket_, try)
+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