Generate the browser contract from ProductApi

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 (:) []

test/Spec.hs

@@ -1,6 +1,7 @@
 module Main (main) where
 
 import qualified Nuthatch.Test.Http as Http
+import qualified Nuthatch.Test.HttpContract as HttpContract
 import qualified Nuthatch.Test.Identity as Identity
 import qualified Nuthatch.Test.Oidc as Oidc
 import qualified Nuthatch.Test.Path as Path
@@ -23,4 +24,5 @@ main = defaultMain $
     , Runtime.tests
     , Oidc.tests
     , Http.tests
+    , HttpContract.tests
     ]

test/WebContractIntegration.hs

@@ -0,0 +1,156 @@
+module Main (main) where
+
+import qualified Data.ByteString as BS
+import qualified Data.Text as T
+import           Network.Wai (Request)
+import           Network.Wai.Handler.Warp (testWithApplication)
+import           Nuthatch.Api
+import           Nuthatch.Types
+import           Servant
+import           Servant.Server.Experimental.Auth
+  ( AuthHandler
+  , mkAuthHandler
+  )
+import           Servant.Types.SourceT (source)
+import           System.Process (callProcess)
+
+main :: IO ()
+main =
+  testWithApplication (pure application) $ \port ->
+    callProcess
+      "node"
+      [ "web/test/contract-integration.mjs"
+      , "http://127.0.0.1:" <> show port
+      ]
+
+application :: Application
+application =
+  serveWithContext
+    (Proxy :: Proxy ProductApi)
+    (authentication :. EmptyContext)
+    productServer
+
+authentication :: AuthHandler Request SessionContext
+authentication = mkAuthHandler $ \_ ->
+  pure SessionContext
+    { sessionUser = SessionUser
+        { suIssuer = "issuer"
+        , suSubject = "subject"
+        , suUserId = UserId "user-1"
+        , suDisplay = Just "User"
+        }
+    , sessionCsrf =
+        Just (CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa")
+    }
+
+productServer :: Server ProductApi
+productServer =
+       sessionHandler
+  :<|> browseHandler
+  :<|> downloadHandler
+  :<|> uploadHandler
+  :<|> deleteHandler
+  :<|> deletePlanHandler
+  :<|> deleteBatchHandler
+
+sessionHandler :: SessionContext -> Handler SessionResponse
+sessionHandler session =
+  pure SessionResponse
+    { sessionResponseUserId = suUserId (sessionUser session)
+    , sessionResponseDisplay = suDisplay (sessionUser session)
+    , sessionResponseCsrf =
+        CsrfToken "aaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaaa"
+    }
+
+browseHandler
+  :: SessionContext
+  -> Maybe Root
+  -> Maybe BrowsePrefix
+  -> Maybe SearchQuery
+  -> Maybe PaginationToken
+  -> Handler BrowseResponse
+browseHandler _ _ prefix query continuation =
+  pure BrowseResponse
+    { browseEntries =
+        [ EntryResponse
+            { entryResponseName = maybe "root" browsePrefixName prefix
+            , entryResponseIsPrefix = False
+            , entryResponseSize = Just 3
+            , entryResponsePath = maybe "root" browsePrefixName prefix
+            }
+        ]
+    , browseContinuation = continuation
+    , browsePartial = maybe False (const True) query
+    }
+  where
+    browsePrefixName (BrowsePrefix selected) =
+      maybe "" unRelativePath selected
+
+downloadHandler
+  :: SessionContext
+  -> Root
+  -> RelativePath
+  -> Maybe T.Text
+  -> Handler DownloadSuccess
+downloadHandler _ _ _ _ =
+  pure $
+    addHeader
+      "attachment; filename=\"file.txt\"" $
+      addHeader "nosniff" $
+        addHeader "default-src 'none'" $
+          addHeader 3 (source ["abc"])
+
+uploadHandler
+  :: SessionContext
+  -> Root
+  -> RelativePath
+  -> OperationId
+  -> DeclaredSize
+  -> ContentSha256
+  -> CsrfToken
+  -> SourceIO BS.ByteString
+  -> Handler UploadResponse
+uploadHandler _ _ _ operation _ _ _ _ =
+  pure UploadResponse
+    { uploadResponseOperationId = operation
+    , uploadResponseResult = MutationSucceeded
+    , uploadResponseIdempotencyWindowSeconds = 3600
+    }
+
+deleteHandler
+  :: SessionContext
+  -> DeleteRequest
+  -> Handler DeleteResponse
+deleteHandler _ request =
+  pure DeleteResponse
+    { deleteResponseOperationId = deleteOperationId request
+    , deleteResponseResult = MutationSucceeded
+    , deleteResponseIdempotencyWindowSeconds = 3600
+    }
+
+deletePlanHandler
+  :: SessionContext
+  -> Root
+  -> RelativePath
+  -> Maybe PaginationToken
+  -> Handler DeletePlanResponse
+deletePlanHandler _ _ path continuation =
+  pure DeletePlanResponse
+    { deletePlanPaths = [path]
+    , deletePlanContinuation = continuation
+    }
+
+deleteBatchHandler
+  :: SessionContext
+  -> DeleteBatchRequest
+  -> Handler DeleteBatchResponse
+deleteBatchHandler _ request =
+  pure $ DeleteBatchResponse
+    [ DeleteItemResponse
+        { deleteItemPath = deleteBatchPath item
+        , deleteItemOperationId = deleteBatchOperationId item
+        , deleteItemResult = Just MutationSucceeded
+        , deleteItemError = Nothing
+        }
+    | item <- deleteBatchItems request
+    ]