Harden mutation admission and storage observation

src/Nuthatch/Protocol.hs

@@ -20,6 +20,7 @@ module Nuthatch.Protocol
   , recoveryEligible
   , desiredMatches
   , priorMatches
+  , finalizeFromObservation
   ) where
 
 import           Data.Maybe (listToMaybe, mapMaybe)
@@ -138,6 +139,11 @@ admitMutation
   -> Integer
   -> IO AdmitOutcome
 admitMutation conn uid kind op pool key rel size msha maxObject = do
+  let identity =
+        unUserId uid <> "\NUL" <> kindLabel kind <> "\NUL" <> unOperationId op
+  _ <- query conn
+    "SELECT pg_advisory_xact_lock(hashtextextended(?, 0))"
+    (Only identity) :: IO [Only ()]
   existing <- lookupMutation conn uid kind op
   case existing of
     Just rec
@@ -169,11 +175,13 @@ admitMutation conn uid kind op pool key rel size msha maxObject = do
               , mrExternal = ExtIdle
               }
 
-      _ <- query conn
+      poolRows <- query conn
         "SELECT 1 FROM pools WHERE pool_id = ? FOR UPDATE"
         (Only (unPoolId pool)) :: IO [Only Int]
 
-      if kind == Put && (size <= 0 || size > maxObject)
+      if null poolRows
+        then pure AdmitConflict
+        else if kind == Put && (size <= 0 || size > maxObject)
         then do
           rec <- insertTerminalRejected conn uid kind op pool key rel size msha priorSize priorSha
           pure (AdmitRejected "invalid object size" rec)
@@ -458,3 +466,26 @@ priorMatches rec obs =
                   (Just _, Nothing)     -> False
                   (Nothing, Just _)     -> mrPriorSize rec == sz
               )
+
+finalizeFromObservation
+  :: Connection
+  -> MutationRecord
+  -> ObjectObservation
+  -> IO (Maybe MutationResult)
+finalizeFromObservation conn rec observed =
+  case observed of
+    ObjectUnavailable _ -> pure Nothing
+    _ | desiredMatches rec observed -> do
+      let (finalSize, finalSha) =
+            case mrKind rec of
+              Put ->
+                ( mrDeclaredSize rec
+                , mrContentSha256 rec
+                )
+              Delete -> (0, Nothing)
+      ok <- finalizeSuccess conn rec finalSize finalSha
+      pure $ if ok then Just MutationSucceeded else Nothing
+    _ | priorMatches rec observed -> do
+      ok <- finalizeFailure conn rec
+      pure $ if ok then Just MutationFailed else Nothing
+    _ -> pure Nothing