morpheus-graphql-app-0.28.2: test/Batching.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Batching
  ( runBatchingTest,
  )
where

import Control.Monad.Except (MonadError (throwError))
import Data.Aeson (eitherDecode)
import qualified Data.ByteString.Lazy.Char8 as LBS
import Data.HashSet (fromList)
import Data.Map (lookup)
import Data.Morpheus.App
  ( App (..),
    mkApp,
    runApp,
  )
import Data.Morpheus.App.Internal.Resolving (ResolverValue, resultOr)
import Data.Morpheus.App.NamedResolvers
  ( NamedResolverFunction,
    RootResolverValue,
    enum,
    getArgument,
    list,
    nullRes,
    object,
    queryResolvers,
    ref,
    refs,
  )
import Data.Morpheus.Core
  ( parseSchema,
  )
import Data.Morpheus.Types.IO
  ( GQLRequest (..),
    GQLResponse,
  )
import Data.Morpheus.Types.Internal.AST
  ( QUERY,
    Schema,
    TypeName,
    VALID,
    ValidValue,
    Value (..),
    msg,
    unpackName,
  )
import Relude hiding (ByteString, fromList)
import Test.Morpheus
  ( FileUrl,
    file,
    testApi,
  )
import Test.Tasty
  ( TestTree,
  )

type BatchedValues = (HashSet ValidValue)

type BatchingConstraints = Map Text BatchedValues

typeConstraint :: (Monad m) => BatchingConstraints -> (TypeName, NamedResolverFunction QUERY e m) -> (TypeName, NamedResolverFunction QUERY e m)
typeConstraint cons (name, f) = (name,) $ maybe f (require f) (lookup (unpackName name) cons)

require :: (Monad m) => NamedResolverFunction QUERY e m -> BatchedValues -> NamedResolverFunction QUERY e m
require f req args
  | fromList args == req = f args
  | otherwise = throwError ("was not batched! expected: " <> msg (List $ toList req) <> "got: " <> msg (List args))

gods :: [ValidValue]
gods = ["poseidon", "morpheus", "zeus"]

getName :: ValidValue -> ResolverValue m
getName "zeus" = "Zeus"
getName "morpheus" = "Morpheus"
getName "poseidon" = "Zeus"
getName "cronos" = "Cronos"
getName _ = ""

getPowers :: ValidValue -> [ResolverValue m]
getPowers "zeus" = [enum "Thunderbolt"]
getPowers "morpheus" = [enum "Shapeshifting"]
getPowers _ = []

deityResolver :: (Monad m) => NamedResolverFunction QUERY e m
deityResolver = traverse getDeity
  where
    getDeity name
      | name `elem` gods =
          object
            [ ("name", pure $ getName name),
              ("power", pure $ list $ getPowers name)
            ]
      | otherwise = nullRes

resolveQuery :: (Monad m) => NamedResolverFunction QUERY e m
resolveQuery = traverse getQuery
  where
    getQuery _ =
      object
        [ ("deity", ref "Deity" <$> getArgument "id"),
          ("deities", pure $ refs "Deity" ["zeus", "morpheus"])
        ]

resolvers :: (Monad m) => BatchingConstraints -> RootResolverValue e m
resolvers cons =
  queryResolvers
    $ typeConstraint cons
    <$> [ ("Query", resolveQuery),
          ("Deity", deityResolver)
        ]

getSchema :: FileUrl -> IO (Schema VALID)
getSchema url = LBS.readFile (toString url) >>= resultOr (fail . show) pure . parseSchema

getBatchingConstraint :: FileUrl -> IO BatchingConstraints
getBatchingConstraint url = LBS.readFile (toString (file url "batching.json")) >>= either (fail . show) pure . eitherDecode

getApps :: BatchingConstraints -> FileUrl -> IO (App e IO)
getApps con x = do
  schemaDeities <- getSchema (file x "schema.gql")
  pure $ mkApp schemaDeities (resolvers con)

runBatchingTest :: FileUrl -> FileUrl -> TestTree
runBatchingTest url fileUrl = testApi api fileUrl
  where
    api :: GQLRequest -> IO GQLResponse
    api req = do
      constraints <- getBatchingConstraint fileUrl
      getApps constraints url >>= (`runApp` req)