{-# LANGUAGE ConstrainedClassMethods #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskellQuotes #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE NoImplicitPrelude #-}

module Data.Morpheus.Client.Fetch
  ( Fetch (..),
    deriveFetch,
  )
where

import Data.Aeson
  ( FromJSON,
    ToJSON (..),
    eitherDecode,
    encode,
  )
import qualified Data.Aeson as A
import qualified Data.Aeson.Types as A
import Data.ByteString.Lazy (ByteString)
import Data.Morpheus.Client.Internal.Types
  ( FetchError (..),
  )
import Data.Morpheus.Client.JSONSchema.Types
  ( JSONResponse (..),
  )
import Data.Morpheus.CodeGen.Internal.TH
  ( applyCons,
    toCon,
    typeInstanceDec,
  )
import Data.Morpheus.Types.IO
  ( GQLRequest (..),
  )
import Data.Morpheus.Types.Internal.AST
  ( FieldName,
    TypeName,
  )
import Data.Text
  ( pack,
  )
import Language.Haskell.TH
import Relude hiding (ByteString, Type)

fixVars :: A.Value -> Maybe A.Value
fixVars :: Value -> Maybe Value
fixVars Value
x
  | Value
x Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
== Value
A.emptyArray = Maybe Value
forall a. Maybe a
Nothing
  | Bool
otherwise = Value -> Maybe Value
forall a. a -> Maybe a
Just Value
x

class Fetch a where
  type Args a :: *
  __fetch ::
    (Monad m, Show a, ToJSON (Args a), FromJSON a) =>
    String ->
    FieldName ->
    (ByteString -> m ByteString) ->
    Args a ->
    m (Either (FetchError a) a)
  __fetch String
strQuery FieldName
opName ByteString -> m ByteString
trans Args a
vars = (((String -> FetchError a)
-> Either String (JSONResponse a)
-> Either (FetchError a) (JSONResponse a)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> FetchError a
forall a. String -> FetchError a
FetchErrorParseFailure (Either String (JSONResponse a)
 -> Either (FetchError a) (JSONResponse a))
-> (ByteString -> Either String (JSONResponse a))
-> ByteString
-> Either (FetchError a) (JSONResponse a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String (JSONResponse a)
forall a. FromJSON a => ByteString -> Either String a
eitherDecode) (ByteString -> Either (FetchError a) (JSONResponse a))
-> (JSONResponse a -> Either (FetchError a) a)
-> ByteString
-> Either (FetchError a) a
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> JSONResponse a -> Either (FetchError a) a
forall a. JSONResponse a -> Either (FetchError a) a
processResponse) (ByteString -> Either (FetchError a) a)
-> m ByteString -> m (Either (FetchError a) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> m ByteString
trans (GQLRequest -> ByteString
forall a. ToJSON a => a -> ByteString
encode GQLRequest
gqlReq)
    where
      gqlReq :: GQLRequest
gqlReq = GQLRequest :: Maybe FieldName -> Text -> Maybe Value -> GQLRequest
GQLRequest {operationName :: Maybe FieldName
operationName = FieldName -> Maybe FieldName
forall a. a -> Maybe a
Just FieldName
opName, query :: Text
query = String -> Text
pack String
strQuery, variables :: Maybe Value
variables = Value -> Maybe Value
fixVars (Args a -> Value
forall a. ToJSON a => a -> Value
toJSON Args a
vars)}
      -------------------------------------------------------------
      processResponse :: JSONResponse a -> Either (FetchError a) a
processResponse JSONResponse {$sel:responseData:JSONResponse :: forall a. JSONResponse a -> Maybe a
responseData = Just a
x, $sel:responseErrors:JSONResponse :: forall a. JSONResponse a -> [GQLError]
responseErrors = []} = a -> Either (FetchError a) a
forall a b. b -> Either a b
Right a
x
      processResponse JSONResponse {$sel:responseData:JSONResponse :: forall a. JSONResponse a -> Maybe a
responseData = Maybe a
Nothing, $sel:responseErrors:JSONResponse :: forall a. JSONResponse a -> [GQLError]
responseErrors = []} = FetchError a -> Either (FetchError a) a
forall a b. a -> Either a b
Left FetchError a
forall a. FetchError a
FetchErrorNoResult
      processResponse JSONResponse {$sel:responseData:JSONResponse :: forall a. JSONResponse a -> Maybe a
responseData = Maybe a
result, $sel:responseErrors:JSONResponse :: forall a. JSONResponse a -> [GQLError]
responseErrors = (GQLError
x : [GQLError]
xs)} = FetchError a -> Either (FetchError a) a
forall a b. a -> Either a b
Left (FetchError a -> Either (FetchError a) a)
-> FetchError a -> Either (FetchError a) a
forall a b. (a -> b) -> a -> b
$ GQLErrors -> Maybe a -> FetchError a
forall a. GQLErrors -> Maybe a -> FetchError a
FetchErrorProducedErrors (GQLError
x GQLError -> [GQLError] -> GQLErrors
forall a. a -> [a] -> NonEmpty a
:| [GQLError]
xs) Maybe a
result
  fetch :: (Monad m, FromJSON a) => (ByteString -> m ByteString) -> Args a -> m (Either (FetchError a) a)

deriveFetch :: Type -> TypeName -> String -> Q [Dec]
deriveFetch :: Type -> TypeName -> String -> Q [Dec]
deriveFetch Type
resultType TypeName
typeName String
queryString =
  Dec -> [Dec]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> [Dec]) -> Q Dec -> Q [Dec]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CxtQ -> TypeQ -> [Q Dec] -> Q Dec
instanceD ([TypeQ] -> CxtQ
cxt []) TypeQ
iHead [Q Dec]
methods
  where
    iHead :: TypeQ
iHead = Name -> [TypeName] -> TypeQ
forall con cons.
(ToName con, ToName cons) =>
con -> [cons] -> TypeQ
applyCons ''Fetch [TypeName
typeName]
    methods :: [Q Dec]
methods =
      [ Name -> [ClauseQ] -> Q Dec
funD 'fetch [[PatQ] -> BodyQ -> [Q Dec] -> ClauseQ
clause [] (ExpQ -> BodyQ
normalB [|__fetch queryString typeName|]) []],
        Dec -> Q Dec
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dec -> Q Dec) -> Dec -> Q Dec
forall a b. (a -> b) -> a -> b
$ Name -> Type -> Type -> Dec
typeInstanceDec ''Args (TypeName -> Type
forall a b. ToCon a b => a -> b
toCon TypeName
typeName) Type
resultType
      ]