nuthatch/test/Nuthatch/Test/HttpContract.hs

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           Nuthatch.Types (MutationResult (..))
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 "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"
      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 (:) []

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"