Add bounded protocol and target conformance gate

src/Nuthatch/App.hs

@@ -6,6 +6,9 @@ module Nuthatch.App
   , authenticationHandler
   , loginResponse
   , dispatchAndFinalize
+  , PutFailure (..)
+  , runPut
+  , runDelete
   , runRecovery
   ) where
 
@@ -68,6 +71,7 @@ import           Nuthatch.S3
   , getObjectSource
   , headObject
   , listObjects
+  , objectStoreAvailable
   , observeObjectFully
   , putObjectStream
   , renderS3Error
@@ -550,32 +554,42 @@ runPut env user root rel op size sha body = do
       pool = case root of
         Personal -> personalPool uid
         Shared   -> sharedPool
-  outcome <- withTransaction (envDb env) $ \conn ->
-    admitMutation conn uid Put op pool key rel size (Just sha)
-      (cfgMaxObjectBytes (envConfig env))
-      (cfgIdempotencyWindowSec (envConfig env))
-  case outcome of
-    AdmitConflict -> pure (Right MutationConflict)
-    AdmitRejected reason _ -> pure (Left (PutRejected reason))
-    AdmitReplay MutationPending _ -> pure (Right MutationPending)
-    AdmitReplay result _ -> pure (Right result)
-    AdmitPrepared rec ->
-      dispatchAndFinalize
-        env
-        user
-        root
-        rec
-        PutSettlementFailed
-        (PutDispatchFailed (PutObjectStoreError S3TransportError))
-        (putObjectStream
-          (envS3 env)
-          key
-          size
-          (Just sha)
-          (transferPieceSize env)
-          (inspectBandwidth env user)
-          body
-          >>= pure . either (Left . PutDispatchFailed) Right)
+  admitted <- withTransaction (envDb env) $ \conn -> do
+    existing <- mutationEpochExists
+      conn uid Put op (cfgIdempotencyWindowSec (envConfig env))
+    available <-
+      if existing then pure True else objectStoreAvailable (envS3 env)
+    if available
+      then Just <$> admitMutation conn uid Put op pool key rel size (Just sha)
+        (cfgMaxObjectBytes (envConfig env))
+        (cfgIdempotencyWindowSec (envConfig env))
+      else pure Nothing
+  case admitted of
+    Nothing ->
+      pure (Left (PutDispatchFailed (PutObjectStoreError S3TransportError)))
+    Just outcome ->
+      case outcome of
+        AdmitConflict -> pure (Right MutationConflict)
+        AdmitRejected reason _ -> pure (Left (PutRejected reason))
+        AdmitReplay MutationPending _ -> pure (Right MutationPending)
+        AdmitReplay result _ -> pure (Right result)
+        AdmitPrepared rec ->
+          dispatchAndFinalize
+            env
+            user
+            root
+            rec
+            PutSettlementFailed
+            (PutDispatchFailed (PutObjectStoreError S3TransportError))
+            (putObjectStream
+              (envS3 env)
+              key
+              size
+              (Just sha)
+              (transferPieceSize env)
+              (inspectBandwidth env user)
+              body
+              >>= pure . either (Left . PutDispatchFailed) Right)
 
 data PutFailure
   = PutRejected Text
@@ -623,25 +637,34 @@ runDelete env user root rel op = do
       pool = case root of
         Personal -> personalPool uid
         Shared   -> sharedPool
-  outcome <- withTransaction (envDb env) $ \conn ->
-    admitMutation conn uid Delete op pool key rel 0 Nothing
-      (cfgMaxObjectBytes (envConfig env))
-      (cfgIdempotencyWindowSec (envConfig env))
-  case outcome of
-    AdmitConflict -> pure (Right MutationConflict)
-    AdmitRejected reason _ -> pure (Left reason)
-    AdmitReplay MutationPending _ -> pure (Right MutationPending)
-    AdmitReplay result _ -> pure (Right result)
-    AdmitPrepared rec ->
-      dispatchAndFinalize
-        env
-        user
-        root
-        rec
-        "mutation failed after store settlement"
-        "object request timed out"
-        (deleteObject (envS3 env) key
-          >>= pure . either (Left . renderS3Error) Right)
+  admitted <- withTransaction (envDb env) $ \conn -> do
+    existing <- mutationEpochExists
+      conn uid Delete op (cfgIdempotencyWindowSec (envConfig env))
+    available <-
+      if existing then pure True else objectStoreAvailable (envS3 env)
+    if available
+      then Just <$> admitMutation conn uid Delete op pool key rel 0 Nothing
+        (cfgMaxObjectBytes (envConfig env))
+        (cfgIdempotencyWindowSec (envConfig env))
+      else pure Nothing
+  case admitted of
+    Nothing -> pure (Left "object store unavailable")
+    Just outcome ->
+      case outcome of
+        AdmitConflict -> pure (Right MutationConflict)
+        AdmitRejected reason _ -> pure (Left reason)
+        AdmitReplay MutationPending _ -> pure (Right MutationPending)
+        AdmitReplay result _ -> pure (Right result)
+        AdmitPrepared rec ->
+          dispatchAndFinalize
+            env
+            user
+            root
+            rec
+            "mutation failed after store settlement"
+            "object request timed out"
+            (deleteObject (envS3 env) key
+              >>= pure . either (Left . renderS3Error) Right)
 
 deletePrefix :: Env -> SessionUser -> Root -> Text -> IO (Either Text Int)
 deletePrefix env user root prefix = do