Generate the browser contract from ProductApi

2026-07-20 03:20:08 +09:00 · 2026-07-20 03:20:08 +09:00 · c9642f4067
commit c9642f4067
parent 67cc0cb802
1 changed files with 2572 additions and 130 deletions
--- a/test/Nuthatch/Test/HttpContract.hs
+++ b/test/Nuthatch/Test/HttpContract.hs
@ -0,0 +1,104 @@
+module Nuthatch.Test.HttpContract
+  ( tests
+  ) where
+
+import qualified Data.Aeson as A
+import qualified Data.Aeson.Key as Key
+import qualified Data.Aeson.KeyMap as KeyMap
+import qualified Data.ByteString.Lazy as BL
+import           Data.Proxy (Proxy (..))
+import qualified Data.Text as T
+import qualified Data.Text.IO as TIO
+import           Nuthatch.Api
+import           Nuthatch.Http.Contract
+  ( renderContractFixtures
+  , renderTypeScriptContract
+  , contractShapeErrors
+  )
+import           Test.Tasty (TestTree, testGroup)
+import           Test.Tasty.HUnit ((@?=), Assertion, assertBool, testCase)
+
+tests :: TestTree
+tests = testGroup "Haskell to TypeScript contract"
+  [ testCase "checked artifacts are byte-identical to production generation" $ do
+      contract <- TIO.readFile "web/src/generated/contract.ts"
+      fixtures <- BL.readFile "web/test/fixtures/contract.json"
+      contract @?= renderTypeScriptContract
+      fixtures @?= renderContractFixtures
+  , testCase "shared fixtures round-trip every wire DTO" $ do
+      fixture <- decodeFixture
+      assertFixture fixture "session_response" (Proxy :: Proxy SessionResponse)
+      assertFixture fixture "entry_response" (Proxy :: Proxy EntryResponse)
+      assertFixture fixture "browse_response" (Proxy :: Proxy BrowseResponse)
+      assertFixture fixture "delete_request" (Proxy :: Proxy DeleteRequest)
+      assertFixture fixture "upload_response" (Proxy :: Proxy UploadResponse)
+      assertFixture fixture "delete_response" (Proxy :: Proxy DeleteResponse)
+      assertFixture fixture "delete_plan_response"
+        (Proxy :: Proxy DeletePlanResponse)
+      assertFixture fixture "delete_batch_item" (Proxy :: Proxy DeleteBatchItem)
+      assertFixture fixture "delete_batch_request"
+        (Proxy :: Proxy DeleteBatchRequest)
+      assertFixture fixture "delete_item_response"
+        (Proxy :: Proxy DeleteItemResponse)
+      assertFixture fixture "delete_batch_response"
+        (Proxy :: Proxy DeleteBatchResponse)
+  , testCase "explicit TypeScript mappings accept the Aeson wire shapes" $
+      contractShapeErrors @?= []
+  , testCase "generated error unions cover every fixture error code" $ do
+      fixture <- decodeFixture
+      errors <- fixtureValue fixture "errors"
+      case errors of
+        A.Array values ->
+          mapM_ assertGeneratedErrorCode (toList values)
+        _ -> fail "errors fixture must be an array"
+  , testCase "non-TypeScript invariants remain explicit" $ do
+      let contract = renderTypeScriptContract
+      assertBool "relative path invariant is named"
+        ("relativePath:" `T.isInfixOf` contract)
+      assertBool "operation id invariant is named"
+        ("operationId:" `T.isInfixOf` contract)
+      assertBool "content identity invariant is named"
+        ("contentSha256:" `T.isInfixOf` contract)
+  ]
+
+decodeFixture :: IO A.Object
+decodeFixture = do
+  bytes <- BL.readFile "web/test/fixtures/contract.json"
+  value <- either fail pure (A.eitherDecode bytes)
+  case value of
+    A.Object fixture -> pure fixture
+    _ -> fail "contract fixture must be an object"
+
+assertFixture
+  :: (A.FromJSON value, A.ToJSON value)
+  => A.Object
+  -> Key.Key
+  -> Proxy value
+  -> Assertion
+assertFixture fixture key proxy = do
+  raw <- fixtureValue fixture key
+  decoded <- case A.fromJSON raw of
+    A.Error message -> fail message
+    A.Success value -> pure value
+  A.toJSON (asProxyType proxy decoded) @?= raw
+
+fixtureValue :: A.Object -> Key.Key -> IO A.Value
+fixtureValue fixture key =
+  maybe (fail ("missing fixture " <> show key)) pure (KeyMap.lookup key fixture)
+
+assertGeneratedErrorCode :: A.Value -> Assertion
+assertGeneratedErrorCode value =
+  case value of
+    A.Object objectValue ->
+      case KeyMap.lookup "error" objectValue of
+        Just (A.String code) ->
+          assertBool ("missing generated error code " <> T.unpack code)
+            (("'" <> code <> "'") `T.isInfixOf` renderTypeScriptContract)
+        _ -> fail "error fixture must contain an error string"
+    _ -> fail "error fixture must be an object"
+
+asProxyType :: Proxy value -> value -> value
+asProxyType _ = id
+
+toList :: Foldable collection => collection value -> [value]
+toList = foldr (:) []