Close endpoint failure types across service and web boundaries

test/Nuthatch/Test/HttpContract.hs

@@ -15,6 +15,7 @@ import           Nuthatch.Http.Contract
   , renderTypeScriptContract
   , contractShapeErrors
   )
+import           Nuthatch.Types (MutationResult (..))
 import           Test.Tasty (TestTree, testGroup)
 import           Test.Tasty.HUnit ((@?=), Assertion, assertBool, testCase)
 
@@ -44,6 +45,34 @@ tests = testGroup "Haskell to TypeScript contract"
         (Proxy :: Proxy DeleteBatchResponse)
   , testCase "explicit TypeScript mappings accept the Aeson wire shapes" $
       contractShapeErrors @?= []
+  , testCase "delete item responses contain exactly one typed outcome" $ do
+      let path = "folder/file.txt" :: T.Text
+          operation = "operation-1" :: T.Text
+          decode result failure =
+            A.fromJSON
+              (A.object
+                [ "path" A..= path
+                , "operation_id" A..= operation
+                , "result" A..= result
+                , "error" A..= failure
+                ])
+              :: A.Result DeleteItemResponse
+      assertSuccess
+        (decode
+          (Just MutationSucceeded)
+          (Nothing :: Maybe DeleteItemFailure))
+      assertSuccess
+        (decode
+          (Nothing :: Maybe MutationResult)
+          (Just DeleteItemDatabaseUnavailable))
+      assertFailure
+        (decode
+          (Just MutationSucceeded)
+          (Just DeleteItemDatabaseUnavailable))
+      assertFailure
+        (decode
+          (Nothing :: Maybe MutationResult)
+          (Nothing :: Maybe DeleteItemFailure))
   , testCase "generated error unions cover every fixture error code" $ do
       fixture <- decodeFixture
       errors <- fixtureValue fixture "errors"
@@ -102,3 +131,11 @@ asProxyType _ = id
 
 toList :: Foldable collection => collection value -> [value]
 toList = foldr (:) []
+
+assertSuccess :: A.Result value -> Assertion
+assertSuccess (A.Success _) = pure ()
+assertSuccess (A.Error message) = fail message
+
+assertFailure :: A.Result value -> Assertion
+assertFailure (A.Error _) = pure ()
+assertFailure (A.Success _) = fail "unexpected successful decode"

test/Nuthatch/Test/Product.hs

@@ -17,7 +17,7 @@ tests = testGroup "product behavior"
         getMonotonicTimeNSec
         (\_ _ -> do
           threadDelay 100000
-          pure (Right (ListPage [] [] Nothing False)))
+          pure (Right (ListPage [] [] Nothing False) :: Either () ListPage))
         100
         (started + 5000000)
       finished <- getMonotonicTimeNSec

test/ProtocolConformance.hs

@@ -305,7 +305,9 @@ verifyStoreFence cfg database redis store = do
     (OperationId "expired-delete-store-down")
   afterExpiredDelete <-
     mutationSnapshot database "expired-delete-store-down"
-  assert "store-down expired delete epoch rejected" (isLeft expiredDeleteResult)
+  assertEqual "store-down expired delete epoch rejected"
+    (Left (Mutation.DeleteDispatchFailed S3TransportError))
+    expiredDeleteResult
   assertEqual "store-down does not start an expired delete epoch"
     beforeExpiredDelete
     afterExpiredDelete
@@ -313,7 +315,9 @@ verifyStoreFence cfg database redis store = do
   freshDeleteResult <- runDelete
     env user Shared (RelativePath "delete-store-down.bin")
     (OperationId "delete-store-down")
-  assert "store-down delete rejected" (isLeft freshDeleteResult)
+  assertEqual "store-down delete rejected"
+    (Left (Mutation.DeleteDispatchFailed S3TransportError))
+    freshDeleteResult
   freshDeleteRows <- Db.query database
     "SELECT count(*) FROM mutations WHERE operation_id = 'delete-store-down'"
     ()

test/WebContractIntegration.hs

@@ -149,8 +149,7 @@ deleteBatchHandler _ request =
     [ DeleteItemResponse
         { deleteItemPath = deleteBatchPath item
         , deleteItemOperationId = deleteBatchOperationId item
-        , deleteItemResult = Just MutationSucceeded
-        , deleteItemError = Nothing
+        , deleteItemOutcome = DeleteItemCompleted MutationSucceeded
         }
     | item <- deleteBatchItems request
     ]