Harden mutation admission and storage observation

src/Nuthatch/App.hs

@@ -27,7 +27,7 @@ import qualified Data.Text as T
 import qualified Data.Text.Encoding as TE
 import           Data.UUID (toText)
 import           Data.UUID.V4 (nextRandom)
-import           Database.PostgreSQL.Simple (Connection, Only (..))
+import           Database.PostgreSQL.Simple (Only (..))
 import           Network.HTTP.Types
   ( hContentType
   , hLocation
@@ -53,6 +53,7 @@ import           Nuthatch.S3
   , headObject
   , listObjects
   , putObject
+  , renderS3Error
   )
 import           Nuthatch.Session
 import           Nuthatch.Types
@@ -252,7 +253,7 @@ handleDownloadRequest env session root path = do
   metadata <- liftIO (headObject (envS3 env) key)
   info <- case metadata of
     Left message -> throwOperationError status502Error
-      (DownloadObjectStoreFailed message)
+      (DownloadObjectStoreFailed (renderS3Error message))
     Right Nothing -> throwOperationError err404 DownloadNotFound
     Right (Just value) -> pure value
   throttle <- liftIO $
@@ -263,7 +264,7 @@ handleDownloadRequest env session root path = do
     Right True -> pure ()
   result <- liftIO (getObjectBytes (envS3 env) key)
   body <- either
-    (throwOperationError status502Error . DownloadObjectStoreFailed)
+    (throwOperationError status502Error . DownloadObjectStoreFailed . renderS3Error)
     pure
     result
   liftIO $ audit "download" "ok" (Just (unUserId (suUserId user)))
@@ -445,7 +446,7 @@ runPut env user root rel op size sha body = do
     AdmitReplay MutationPending _ -> pure (Right MutationPending)
     AdmitReplay result _ -> pure (Right result)
     AdmitPrepared rec -> dispatchAndFinalize env user root rec $ do
-      _ <- putObject (envS3 env) key size sha body
+      _ <- putObject (envS3 env) key size (Just sha) body
       pure ()
 
 runDelete
@@ -516,7 +517,7 @@ collectKeys s3 prefix = go Nothing []
     go continuation accumulated = do
       page <- listObjects s3 prefix Nothing continuation 1000
       case page of
-        Left message -> pure (Left message)
+        Left message -> pure (Left (renderS3Error message))
         Right result -> do
           let accumulated' = accumulated <> map fst (lpObjects result)
           if lpIsTruncated result
@@ -559,35 +560,17 @@ dispatchAndFinalize env user root rec dispatch = do
 observeObject :: S3 -> ObjectKey -> IO ObjectObservation
 observeObject s3 key = do
   result <- headObject s3 key
-  pure $ case result of
-    Right (Just info) -> ObjectPresent (oiSize info) (oiSha256 info)
-    Right Nothing     -> ObjectAbsent
-    Left err          -> ObjectUnavailable err
-
-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
-    _ -> do
-      ok <- finalizeFailure conn rec
-      pure $ if ok then Just MutationFailed else Nothing
+  case result of
+    Right (Just info@ObjectInfo { oiSha256 = Just _ }) ->
+      pure (ObjectPresent (oiSize info) (oiSha256 info))
+    Right (Just _) -> do
+      body <- getObjectBytes s3 key
+      pure $ case body of
+        Right bytes ->
+          ObjectPresent (toInteger (BL.length bytes)) (Just (contentSha256 bytes))
+        Left err -> ObjectUnavailable (renderS3Error err)
+    Right Nothing -> pure ObjectAbsent
+    Left err -> pure (ObjectUnavailable (renderS3Error err))
 
 listEntries :: Env -> SessionUser -> Root -> Text -> IO (Either Text [ListEntry])
 listEntries env user root prefix = do
@@ -613,7 +596,7 @@ listEntries env user root prefix = do
     Nothing -> do
       page <- listObjects (envS3 env) s3Prefix (Just "/") Nothing 1000
       case page of
-        Left err -> pure (Left err)
+        Left err -> pure (Left (renderS3Error err))
         Right lp -> do
           let rootPrefix =
                 case root of
@@ -680,7 +663,7 @@ collectKeysBounded s3 prefix maxKeys = go Nothing [] 0
       | otherwise = do
           page <- listObjects s3 prefix Nothing mTok (min 1000 (maxKeys - n))
           case page of
-            Left err -> pure (Left err)
+            Left err -> pure (Left (renderS3Error err))
             Right lp -> do
               let acc' = acc <> lpObjects lp
                   n' = length acc'