morpheus-graphql-client 0.20.1 → 0.21.0

raw patch · 22 files changed

+572/−144 lines, 22 filesdep +modern-uridep +morpheus-graphql-subscriptionsdep +reqdep ~morpheus-graphql-code-gendep ~morpheus-graphql-corePVP ok

version bump matches the API change (PVP)

Dependencies added: modern-uri, morpheus-graphql-subscriptions, req, unliftio-core, websockets, wuss

Dependency ranges changed: morpheus-graphql-code-gen, morpheus-graphql-core

API changes (from Hackage documentation)

Files

• changelog.md +1/−2
• morpheus-graphql-client.cabal +24/−7
• src/Data/Morpheus/Client.hs +21/−0
• src/Data/Morpheus/Client/Declare.hs +3/−5
• src/Data/Morpheus/Client/Declare/Aeson.hs +0/−0
• src/Data/Morpheus/Client/Declare/Fetch.hs +0/−52
• src/Data/Morpheus/Client/Declare/RequestType.hs +55/−0
• src/Data/Morpheus/Client/Declare/Type.hs +5/−5
• src/Data/Morpheus/Client/Fetch.hs +18/−33
• src/Data/Morpheus/Client/Fetch/GQLClient.hs +34/−0
• src/Data/Morpheus/Client/Fetch/Http.hs +51/−0
• src/Data/Morpheus/Client/Fetch/RequestType.hs +83/−0
• src/Data/Morpheus/Client/Fetch/ResponseStream.hs +91/−0
• src/Data/Morpheus/Client/Fetch/WebSockets.hs +136/−0
• src/Data/Morpheus/Client/Internal/TH.hs +8/−8
• src/Data/Morpheus/Client/Internal/Types.hs +8/−1
• src/Data/Morpheus/Client/QuasiQuoter.hs +1/−1
• src/Data/Morpheus/Client/Schema/JSON/Parse.hs +3/−3
• src/Data/Morpheus/Client/Schema/JSON/Types.hs +1/−1
• src/Data/Morpheus/Client/Transform/Global.hs +11/−11
• src/Data/Morpheus/Client/Transform/Local.hs +15/−13
• test/Case/ResponseTypes/Test.hs +3/−2

@@ -77,8 +77,7 @@  ### breaking changes -- from now you should provide for every custom graphql scalar definition corresponding haskell type definition and `GQLScalar` implementation fot it. for details see [`examples-client`](https://github.com/morpheusgraphql/morpheus-graphql/tree/master/examples-client)-+- from now you should provide for every custom graphql scalar definition corresponding haskell type definition and `GQLScalar` implementation fot it. - input fields and query arguments are imported without namespace  ### new features

@@ -5,9 +5,9 @@ -- see: https://github.com/sol/hpack  name:           morpheus-graphql-client-version:        0.20.1+version:        0.21.0 synopsis:       Morpheus GraphQL Client-description:    Build GraphQL APIs with your favourite functional language!+description:    Build GraphQL APIs with your favorite functional language! category:       web, graphql, client homepage:       https://morpheusgraphql.com bug-reports:    https://github.com/nalchevanidze/morpheus-graphql/issues@@ -59,9 +59,14 @@       Data.Morpheus.Client.Declare       Data.Morpheus.Client.Declare.Aeson       Data.Morpheus.Client.Declare.Client-      Data.Morpheus.Client.Declare.Fetch+      Data.Morpheus.Client.Declare.RequestType       Data.Morpheus.Client.Declare.Type       Data.Morpheus.Client.Fetch+      Data.Morpheus.Client.Fetch.GQLClient+      Data.Morpheus.Client.Fetch.Http+      Data.Morpheus.Client.Fetch.RequestType+      Data.Morpheus.Client.Fetch.ResponseStream+      Data.Morpheus.Client.Fetch.WebSockets       Data.Morpheus.Client.Internal.TH       Data.Morpheus.Client.Internal.Types       Data.Morpheus.Client.Internal.Utils@@ -85,14 +90,20 @@     , bytestring >=0.10.4 && <0.12.0     , containers >=0.4.2.1 && <0.7.0     , file-embed >=0.0.10 && <1.0.0-    , morpheus-graphql-code-gen >=0.20.0 && <0.21.0-    , morpheus-graphql-core >=0.20.0 && <0.21.0+    , modern-uri >=0.1.0.0 && <1.0.0+    , morpheus-graphql-code-gen >=0.21.0 && <0.22.0+    , morpheus-graphql-core >=0.21.0 && <0.22.0+    , morpheus-graphql-subscriptions     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0+    , req >=3.0.0 && <4.0.0     , template-haskell >=2.0.0 && <3.0.0     , text >=1.2.3 && <1.3.0     , transformers >=0.3.0 && <0.6.0+    , unliftio-core >=0.0.1 && <0.4.0     , unordered-containers >=0.2.8 && <0.3.0+    , websockets >=0.12.6.0 && <1.0.0+    , wuss >=1.0.0 && <3.0.0   default-language: Haskell2010  test-suite morpheus-graphql-client-test@@ -119,15 +130,21 @@     , containers >=0.4.2.1 && <0.7.0     , directory >=1.0.0 && <2.0.0     , file-embed >=0.0.10 && <1.0.0+    , modern-uri >=0.1.0.0 && <1.0.0     , morpheus-graphql-client-    , morpheus-graphql-code-gen >=0.20.0 && <0.21.0-    , morpheus-graphql-core >=0.20.0 && <0.21.0+    , morpheus-graphql-code-gen >=0.21.0 && <0.22.0+    , morpheus-graphql-core >=0.21.0 && <0.22.0+    , morpheus-graphql-subscriptions     , mtl >=2.0.0 && <3.0.0     , relude >=0.3.0 && <2.0.0+    , req >=3.0.0 && <4.0.0     , tasty >=0.1.0 && <1.5.0     , tasty-hunit >=0.1.0 && <1.0.0     , template-haskell >=2.0.0 && <3.0.0     , text >=1.2.3 && <1.3.0     , transformers >=0.3.0 && <0.6.0+    , unliftio-core >=0.0.1 && <0.4.0     , unordered-containers >=0.2.8 && <0.3.0+    , websockets >=0.12.6.0 && <1.0.0+    , wuss >=1.0.0 && <3.0.0   default-language: Haskell2010

@@ -1,4 +1,8 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Client@@ -14,6 +18,14 @@     declareLocalTypes,     declareLocalTypesInline,     clientTypeDeclarations,+    -- Fetch API+    GQLClient,+    GQLClientResult,+    ResponseStream,+    withHeaders,+    request,+    forEach,+    single,     -- DEPRECATED EXPORTS     gql,     defineByDocument,@@ -41,9 +53,18 @@ import Data.Morpheus.Client.Fetch   ( Fetch (..),   )+import Data.Morpheus.Client.Fetch.ResponseStream+  ( GQLClient,+    ResponseStream,+    forEach,+    request,+    single,+    withHeaders,+  ) import Data.Morpheus.Client.Internal.Types   ( ExecutableSource,     FetchError (..),+    GQLClientResult,     SchemaSource (..),   ) import Data.Morpheus.Types.GQLScalar

@@ -12,10 +12,8 @@   ) where -import Data.Morpheus.Client.Declare.Client-  ( declareTypes,-  )-import Data.Morpheus.Client.Declare.Fetch+import Data.Morpheus.Client.Declare.Client (declareTypes)+import Data.Morpheus.Client.Declare.RequestType (declareRequestType) import Data.Morpheus.Client.Internal.Types   ( ExecutableSource,     SchemaSource,@@ -52,7 +50,7 @@     )     ( \(fetch, types) ->         (<>)-          <$> declareFetch query fetch+          <$> declareRequestType query fetch           <*> declareTypes types     ) 

@@ -1,52 +0,0 @@-{-# LANGUAGE ConstrainedClassMethods #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes #-}-{-# LANGUAGE TemplateHaskellQuotes #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Client.Declare.Fetch-  ( declareFetch,-  )-where--import Data.Morpheus.Client.Fetch (Fetch (..))-import Data.Morpheus.Client.Internal.Types-  ( FetchDefinition (..),-    TypeNameTH (..),-  )-import Data.Morpheus.CodeGen.Internal.TH-  ( applyCons,-    toCon,-    typeInstanceDec,-  )-import qualified Data.Text as T-import Language.Haskell.TH-  ( Dec,-    Q,-    Type,-    clause,-    cxt,-    funD,-    instanceD,-    normalB,-  )-import Relude hiding (ByteString, Type)--declareFetch :: Text -> FetchDefinition -> Q [Dec]-declareFetch query FetchDefinition {clientArgumentsTypeName, rootTypeName} =-  pure <$> instanceD (cxt []) iHead methods-  where-    queryString = T.unpack query-    typeName = typename rootTypeName-    iHead = applyCons ''Fetch [typeName]-    methods =-      [ funD 'fetch [clause [] (normalB [|__fetch queryString typeName|]) []],-        pure $ typeInstanceDec ''Args (toCon typeName) (argumentType clientArgumentsTypeName)-      ]--argumentType :: Maybe TypeNameTH -> Type-argumentType Nothing = toCon ("()" :: String)-argumentType (Just clientTypeName) = toCon (typename clientTypeName)

@@ -0,0 +1,55 @@+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE TemplateHaskellQuotes #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Client.Declare.RequestType+  ( declareRequestType,+  )+where++import Data.Morpheus.Client.Fetch.RequestType+  ( RequestType (..),+  )+import Data.Morpheus.Client.Internal.Types+  ( FetchDefinition (..),+    TypeNameTH (..),+  )+import Data.Morpheus.CodeGen.Internal.TH+  ( applyCons,+    funDSimple,+    toCon,+    typeInstanceDec,+    _',+  )+import qualified Data.Text as T+import Language.Haskell.TH+  ( Dec,+    Q,+    Type,+    cxt,+    instanceD,+  )+import Relude hiding (ByteString, Type)++declareRequestType :: Text -> FetchDefinition -> Q [Dec]+declareRequestType query FetchDefinition {clientArgumentsTypeName, rootTypeName, fetchOperationType} =+  pure <$> instanceD (cxt []) iHead methods+  where+    queryString = T.unpack query+    typeName = typename rootTypeName+    iHead = applyCons ''RequestType [typeName]+    methods =+      [ funDSimple '__name [_'] [|typeName|],+        funDSimple '__query [_'] [|queryString|],+        funDSimple '__type [_'] [|fetchOperationType|],+        pure $ typeInstanceDec ''RequestArgs (toCon typeName) (argumentType clientArgumentsTypeName)+      ]++argumentType :: Maybe TypeNameTH -> Type+argumentType Nothing = toCon ("()" :: String)+argumentType (Just clientTypeName) = toCon (typename clientTypeName)

@@ -10,6 +10,7 @@   ) where +import Data.Morpheus.Client.Internal.TH (isTypeDeclared) import Data.Morpheus.Client.Internal.Types   ( ClientConstructorDefinition (..),     ClientTypeDefinition (..),@@ -34,15 +35,14 @@   ) import Language.Haskell.TH import Relude hiding (Type)-import Data.Morpheus.Client.Internal.TH (isTypeDeclared)  typeDeclarations :: TypeKind -> ClientTypeDefinition -> Q [Dec] typeDeclarations KindScalar _ = pure [] typeDeclarations _ c = do-    exists <- isTypeDeclared c-    if exists-        then pure []-        else pure [declareType c]+  exists <- isTypeDeclared c+  if exists+    then pure []+    else pure [declareType c]  declareType :: ClientTypeDefinition -> Dec declareType

@@ -1,10 +1,17 @@ {-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Client.Fetch   ( Fetch (..),+    decodeResponse,   ) where @@ -14,45 +21,23 @@     eitherDecode,     encode,   )-import qualified Data.Aeson as A-import qualified Data.Aeson.Types as A import Data.ByteString.Lazy (ByteString)+import Data.Morpheus.Client.Fetch.RequestType (Request (Request), RequestType (RequestArgs), processResponse, toRequest) import Data.Morpheus.Client.Internal.Types   ( FetchError (..),   )-import Data.Morpheus.Client.Schema.JSON.Types-  ( JSONResponse (..),-  )-import Data.Morpheus.Types.IO-  ( GQLRequest (..),-  )-import Data.Morpheus.Types.Internal.AST-  ( FieldName,-  )-import Data.Text-  ( pack,-  ) import Relude hiding (ByteString) -fixVars :: A.Value -> Maybe A.Value-fixVars x-  | x == A.emptyArray = Nothing-  | otherwise = Just x+decodeResponse :: FromJSON a => ByteString -> Either (FetchError a) a+decodeResponse = (first FetchErrorParseFailure . eitherDecode) >=> processResponse -class Fetch a where+class (RequestType a, ToJSON (Args a), FromJSON a) => Fetch a where   type Args a :: Type-  __fetch ::-    (Monad m, Show a, ToJSON (Args a), FromJSON a) =>-    String ->-    FieldName ->-    (ByteString -> m ByteString) ->-    Args a ->-    m (Either (FetchError a) a)-  __fetch strQuery opName trans vars = ((first FetchErrorParseFailure . eitherDecode) >=> processResponse) <$> trans (encode gqlReq)+  fetch :: Monad m => (ByteString -> m ByteString) -> Args a -> m (Either (FetchError a) a)++instance (RequestType a, ToJSON (Args a), FromJSON a) => Fetch a where+  type Args a = RequestArgs a+  fetch f args = decodeResponse <$> f (encode $ toRequest request)     where-      gqlReq = GQLRequest {operationName = Just opName, query = pack strQuery, variables = fixVars (toJSON vars)}-      --------------------------------------------------------------      processResponse JSONResponse {responseData = Just x, responseErrors = []} = Right x-      processResponse JSONResponse {responseData = Nothing, responseErrors = []} = Left FetchErrorNoResult-      processResponse JSONResponse {responseData = result, responseErrors = (x : xs)} = Left $ FetchErrorProducedErrors (x :| xs) result-  fetch :: (Monad m, FromJSON a) => (ByteString -> m ByteString) -> Args a -> m (Either (FetchError a) a)+      request :: Request a+      request = Request args

@@ -0,0 +1,34 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Client.Fetch.GQLClient+  ( GQLClient (..),+    withHeaders,+    Headers,+    Header,+  )+where++import Relude hiding (ByteString)++type Headers = Map Text Text++type Header = (Text, Text)++data GQLClient = GQLClient+  { clientHeaders :: Headers,+    clientURI :: String+  }++instance IsString GQLClient where+  fromString clientURI =+    GQLClient+      { clientURI,+        clientHeaders = fromList [("Content-Type", "application/json")]+      }++withHeaders :: GQLClient -> [Header] -> GQLClient+withHeaders GQLClient {..} headers = GQLClient {clientHeaders = clientHeaders <> fromList headers, ..}

@@ -0,0 +1,51 @@+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Client.Fetch.Http+  ( httpRequest,+  )+where++import Data.Aeson (FromJSON, ToJSON, encode)+import qualified Data.ByteString.Char8 as L+import Data.ByteString.Lazy.Char8 (ByteString)+import qualified Data.Map as M+import Data.Morpheus.Client.Fetch.GQLClient (Header, Headers)+import Data.Morpheus.Client.Fetch.RequestType+  ( Request,+    RequestType (RequestArgs),+    decodeResponse,+    toRequest,+  )+import Data.Morpheus.Client.Internal.Types (GQLClientResult)+import qualified Data.Text as T+import Network.HTTP.Req+  ( POST (..),+    ReqBodyLbs (ReqBodyLbs),+    defaultHttpConfig,+    header,+    lbsResponse,+    req,+    responseBody,+    runReq,+    useURI,+  )+import qualified Network.HTTP.Req as R (Option)+import Relude hiding (ByteString)+import Text.URI (URI)++withHeader :: Header -> R.Option scheme+withHeader (k, v) = header (L.pack $ T.unpack k) (L.pack $ T.unpack v)++setHeaders :: Headers -> R.Option scheme+setHeaders = foldMap withHeader . M.toList++post :: URI -> ByteString -> Headers -> IO ByteString+post uri body headers = case useURI uri of+  Nothing -> fail ("Invalid Endpoint: " <> show uri <> "!")+  (Just (Left (u, o))) -> responseBody <$> runReq defaultHttpConfig (req POST u (ReqBodyLbs body) lbsResponse (o <> setHeaders headers))+  (Just (Right (u, o))) -> responseBody <$> runReq defaultHttpConfig (req POST u (ReqBodyLbs body) lbsResponse (o <> setHeaders headers))++httpRequest :: (FromJSON a, RequestType a, ToJSON (RequestArgs a)) => URI -> Request a -> Headers -> IO (GQLClientResult a)+httpRequest uri r h = decodeResponse <$> post uri (encode $ toRequest r) h

@@ -0,0 +1,83 @@+{-# LANGUAGE ConstrainedClassMethods #-}+{-# LANGUAGE ConstraintKinds #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Client.Fetch.RequestType+  ( toRequest,+    decodeResponse,+    Request (..),+    RequestType (..),+    processResponse,+    ClientTypeConstraint,+    isSubscription,+  )+where++import Data.Aeson+  ( FromJSON,+    ToJSON (..),+    eitherDecode,+  )+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.Schema.JSON.Types+  ( JSONResponse (..),+  )+import Data.Morpheus.Types.IO+  ( GQLRequest (..),+  )+import Data.Morpheus.Types.Internal.AST+  ( FieldName,+    OperationType (Subscription),+  )+import Data.Text+  ( pack,+  )+import Relude hiding (ByteString)++fixVars :: A.Value -> Maybe A.Value+fixVars x+  | x == A.emptyArray = Nothing+  | otherwise = Just x++toRequest :: (RequestType a, ToJSON (RequestArgs a)) => Request a -> GQLRequest+toRequest r@Request {requestArgs} =+  ( GQLRequest+      { operationName = Just (__name r),+        query = pack (__query r),+        variables = fixVars (toJSON requestArgs)+      }+  )++decodeResponse :: FromJSON a => ByteString -> Either (FetchError a) a+decodeResponse = (first FetchErrorParseFailure . eitherDecode) >=> processResponse++processResponse :: JSONResponse a -> Either (FetchError a) a+processResponse JSONResponse {responseData = Just x, responseErrors = []} = Right x+processResponse JSONResponse {responseData = Nothing, responseErrors = []} = Left FetchErrorNoResult+processResponse JSONResponse {responseData = result, responseErrors = (x : xs)} = Left $ FetchErrorProducedErrors (x :| xs) result++type ClientTypeConstraint (a :: Type) = (RequestType a, ToJSON (RequestArgs a), FromJSON a)++class RequestType a where+  type RequestArgs a :: Type+  __name :: f a -> FieldName+  __query :: f a -> String+  __type :: f a -> OperationType++newtype Request (a :: Type) = Request {requestArgs :: RequestArgs a}++isSubscription :: RequestType a => Request a -> Bool+isSubscription x = __type x == Subscription

@@ -0,0 +1,91 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Client.Fetch.ResponseStream+  ( request,+    forEach,+    single,+    ResponseStream,+    GQLClient,+    withHeaders,+  )+where++import Control.Monad.IO.Unlift (MonadUnliftIO)+import Data.Morpheus.Client.Fetch (Args)+import Data.Morpheus.Client.Fetch.GQLClient+import Data.Morpheus.Client.Fetch.Http (httpRequest)+import Data.Morpheus.Client.Fetch.RequestType+  ( ClientTypeConstraint,+    Request (..),+    isSubscription,+  )+import Data.Morpheus.Client.Fetch.WebSockets+  ( endSession,+    receiveResponse,+    responseStream,+    sendInitialRequest,+    sendRequest,+    useWS,+  )+import Data.Morpheus.Client.Internal.Types+import qualified Data.Text as T+import Relude hiding (ByteString)+import Text.URI (URI, mkURI)++parseURI :: MonadFail m => String -> m URI+parseURI url = maybe (fail ("Invalid Endpoint: " <> show url <> "!")) pure (mkURI (T.pack url))++requestSingle :: ResponseStream a -> IO (Either (FetchError a) a)+requestSingle ResponseStream {..}+  | isSubscription _req = useWS _uri _headers wsApp+  | otherwise = httpRequest _uri _req _headers+  where+    wsApp conn = do+      let sid = "0243134"+      sendInitialRequest conn+      sendRequest conn sid _req+      x <- receiveResponse conn+      endSession conn sid+      pure x++requestMany :: (MonadIO m, MonadUnliftIO m, MonadFail m) => (GQLClientResult a -> m ()) -> ResponseStream a -> m ()+requestMany f ResponseStream {..}+  | isSubscription _req = useWS _uri _headers appWS+  | otherwise = liftIO (httpRequest _uri _req _headers) >>= f+  where+    appWS conn = do+      let sid = "0243134"+      sendInitialRequest conn+      sendRequest conn sid _req+      traverse_ (>>= f) (responseStream conn)+      endSession conn sid++-- PUBLIC API+data ResponseStream a = ClientTypeConstraint a =>+  ResponseStream+  { _req :: Request a,+    _uri :: URI,+    _headers :: Headers+    -- _wsConnection :: Connection+  }++request :: (ClientTypeConstraint a, MonadFail m) => GQLClient -> Args a -> m (ResponseStream a)+request GQLClient {clientURI, clientHeaders} requestArgs = do+  _uri <- parseURI clientURI+  let _req = Request {requestArgs}+  pure ResponseStream {_req, _uri, _headers = clientHeaders}++-- | returns first response from the server+single :: MonadIO m => ResponseStream a -> m (GQLClientResult a)+single = liftIO . requestSingle++-- | returns loop listening subscription events forever. if you want to run it in background use `forkIO`+forEach :: (MonadIO m, MonadUnliftIO m, MonadFail m) => (GQLClientResult a -> m ()) -> ResponseStream a -> m ()+forEach = requestMany

@@ -0,0 +1,136 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE NoImplicitPrelude #-}++module Data.Morpheus.Client.Fetch.WebSockets+  ( useWS,+    sendInitialRequest,+    responseStream,+    sendRequest,+    receiveResponse,+    endSession,+  )+where++import Control.Monad.IO.Unlift (MonadUnliftIO (..))+import qualified Data.Aeson as A+import qualified Data.ByteString.Char8 as BS+import Data.ByteString.Lazy.Char8 (ByteString)+import qualified Data.Map as M+import Data.Morpheus.Client.Fetch.GQLClient (Headers)+import Data.Morpheus.Client.Fetch.RequestType (Request, RequestType (..), processResponse, toRequest)+import Data.Morpheus.Client.Internal.Types (FetchError (..), GQLClientResult)+import Data.Morpheus.Client.Schema.JSON.Types (JSONResponse (..))+import Data.Morpheus.Subscriptions.Internal (ApolloSubscription (..))+import qualified Data.Text as T+import Network.WebSockets.Client (runClientWith)+import Network.WebSockets.Connection (Connection, defaultConnectionOptions, receiveData, sendTextData)+import Relude hiding (ByteString)+import Text.URI+  ( Authority (..),+    RText,+    RTextLabel (..),+    URI (..),+    unRText,+  )+import Wuss (runSecureClientWith)++handleHost :: Text -> String+handleHost "localhost" = "127.0.0.1"+handleHost x = T.unpack x++toPort :: Maybe Word -> Int+toPort Nothing = 80+toPort (Just x) = fromIntegral x++getPath :: Maybe (Bool, NonEmpty (RText 'PathPiece)) -> String+getPath (Just (_, h :| t)) = T.unpack $ T.intercalate "/" $ fmap unRText (h : t)+getPath _ = ""++data WebSocketSettings = WebSocketSettings+  { isSecure :: Bool,+    port :: Int,+    host :: String,+    path :: String,+    headers :: Headers+  }+  deriving (Show)++parseProtocol :: MonadFail m => Text -> m Bool+parseProtocol "ws" = pure False+parseProtocol "wss" = pure True+parseProtocol p = fail $ "unsupported protocol" <> show p++getWebsocketURI :: MonadFail m => URI -> Headers -> m WebSocketSettings+getWebsocketURI URI {uriScheme = Just scheme, uriAuthority = Right Authority {authHost, authPort}, uriPath} headers = do+  isSecure <- parseProtocol $ unRText scheme+  pure+    WebSocketSettings+      { isSecure,+        host = handleHost $ unRText authHost,+        port = toPort authPort,+        path = getPath uriPath,+        headers+      }+getWebsocketURI uri _ = fail ("Invalid Endpoint: " <> show uri <> "!")++toHeader :: IsString a => (Text, Text) -> (a, BS.ByteString)+toHeader (x, y) = (fromString $ T.unpack x, BS.pack $ T.unpack y)++_useWS :: WebSocketSettings -> (Connection -> IO a) -> IO a+_useWS WebSocketSettings {isSecure, ..} app+  | isSecure = runSecureClientWith host 443 path options wsHeaders app+  | otherwise = runClientWith host port path options wsHeaders app+  where+    wsHeaders = map toHeader $ M.toList headers+    options = defaultConnectionOptions++useWS :: (MonadFail m, MonadIO m, MonadUnliftIO m) => URI -> Headers -> (Connection -> m a) -> m a+useWS uri headers app = do+  wsURI <- getWebsocketURI uri headers+  withRunInIO $ \runInIO -> _useWS wsURI (runInIO . app)++processMessage :: ApolloSubscription (JSONResponse a) -> GQLClientResult a+processMessage ApolloSubscription {apolloPayload = Just payload} = processResponse payload+processMessage ApolloSubscription {} = Left (FetchErrorParseFailure "empty message")++decodeMessage :: A.FromJSON a => ByteString -> GQLClientResult a+decodeMessage = (first FetchErrorParseFailure . A.eitherDecode) >=> processMessage++initialMessage :: ApolloSubscription ()+initialMessage = ApolloSubscription {apolloType = "connection_init", apolloPayload = Nothing, apolloId = Nothing}++encodeRequestMessage :: (RequestType a, A.ToJSON (RequestArgs a)) => Text -> Request a -> ByteString+encodeRequestMessage uid r =+  A.encode+    ApolloSubscription+      { apolloPayload = Just (toRequest r),+        apolloType = "start",+        apolloId = Just uid+      }++endMessage :: Text -> ApolloSubscription ()+endMessage uid = ApolloSubscription {apolloType = "stop", apolloPayload = Nothing, apolloId = Just uid}++endSession :: MonadIO m => Connection -> Text -> m ()+endSession conn uid = liftIO $ sendTextData conn $ A.encode $ endMessage uid++receiveResponse :: MonadIO m => A.FromJSON a => Connection -> m (GQLClientResult a)+receiveResponse conn = liftIO $ do+  message <- receiveData conn+  pure $ decodeMessage message++-- returns infinite number of responses+responseStream :: (A.FromJSON a, MonadIO m) => Connection -> [m (GQLClientResult a)]+responseStream conn = getResponse : responseStream conn+  where+    getResponse = receiveResponse conn++sendRequest :: (RequestType a, A.ToJSON (RequestArgs a), MonadIO m) => Connection -> Text -> Request a -> m ()+sendRequest conn uid r = liftIO $ sendTextData conn (encodeRequestMessage uid r)++sendInitialRequest :: MonadIO m => Connection -> m ()+sendInitialRequest conn = liftIO $ sendTextData conn (A.encode initialMessage)

@@ -124,18 +124,18 @@  isTypeDeclared :: ClientTypeDefinition -> Q Bool isTypeDeclared clientDef = do-    let name = mkTypeName clientDef-    m <- lookupTypeName (show name)-    case m of-        Nothing -> pure False-        _ -> pure True+  let name = mkTypeName clientDef+  m <- lookupTypeName (show name)+  case m of+    Nothing -> pure False+    _ -> pure True  hasInstance :: Name -> ClientTypeDefinition -> Q Bool hasInstance typeClass clientDef = do-    isInstance typeClass [ConT (mkTypeName clientDef)]+  isInstance typeClass [ConT (mkTypeName clientDef)]  mkTypeName :: ClientTypeDefinition -> Name-mkTypeName ClientTypeDefinition{clientTypeName = TypeNameTH namespace typeName} =-    toType typeName+mkTypeName ClientTypeDefinition {clientTypeName = TypeNameTH namespace typeName} =+  toType typeName   where     toType = toName . camelCaseTypeName namespace

@@ -1,4 +1,6 @@+{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE KindSignatures #-} {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Client.Internal.Types@@ -9,6 +11,7 @@     FetchError (..),     SchemaSource (..),     ExecutableSource,+    GQLClientResult,   ) where @@ -18,6 +21,7 @@     FieldDefinition,     FieldName,     GQLErrors,+    OperationType,     TypeKind,     TypeName,     VALID,@@ -45,7 +49,8 @@  data FetchDefinition = FetchDefinition   { rootTypeName :: TypeNameTH,-    clientArgumentsTypeName :: Maybe TypeNameTH+    clientArgumentsTypeName :: Maybe TypeNameTH,+    fetchOperationType :: OperationType   }   deriving (Show) @@ -61,3 +66,5 @@   deriving (Show, Eq)  type ExecutableSource = Text++type GQLClientResult (a :: Type) = (Either (FetchError a) a)

@@ -21,7 +21,7 @@     things       <> " are not supported by the GraphQL QuasiQuoter" --- | QuasiQuoter to insert multiple lines of text in Haskell +-- | QuasiQuoter to insert multiple lines of text in Haskell raw :: QuasiQuoter raw =   QuasiQuoter

@@ -36,9 +36,6 @@   ( empty,     fromElems,   )-import qualified Data.Morpheus.Types.Internal.AST as AST-  ( Schema,-  ) import Data.Morpheus.Types.Internal.AST   ( ANY,     ArgumentDefinition (..),@@ -65,6 +62,9 @@     mkUnionContent,     msg,     toAny,+  )+import qualified Data.Morpheus.Types.Internal.AST as AST+  ( Schema,   ) import Relude hiding   ( ByteString,

@@ -41,7 +41,7 @@     mutationType :: Maybe TypeRef,     subscriptionType :: Maybe TypeRef     -- TODO: directives-    --directives: [__Directive]+    -- directives: [__Directive]   }   deriving (Generic, Show, FromJSON) 

@@ -45,17 +45,17 @@ toArgumentsType cName variables   | null variables = Nothing   | otherwise =-    Just-      ClientTypeDefinition-        { clientTypeName = TypeNameTH [] cName,-          clientKind = KindInputObject,-          clientCons =-            [ ClientConstructorDefinition-                { cName,-                  cFields = toFieldDefinition <$> toList variables-                }-            ]-        }+      Just+        ClientTypeDefinition+          { clientTypeName = TypeNameTH [] cName,+            clientKind = KindInputObject,+            clientCons =+              [ ClientConstructorDefinition+                  { cName,+                    cFields = toFieldDefinition <$> toList variables+                  }+              ]+          }  toFieldDefinition :: Variable RAW -> FieldDefinition ANY VALID toFieldDefinition Variable {variableName, variableType} =

@@ -76,10 +76,11 @@ toLocalDefinitions request schema = do   validOperation <- validateRequest clientConfig schema request   flip runReaderT (schema, operationArguments $ operation request) $-    runConverter $ genOperation validOperation+    runConverter $+      genOperation validOperation  genOperation :: Operation VALID -> Converter (FetchDefinition, [ClientTypeDefinition])-genOperation op@Operation {operationName, operationSelection} = do+genOperation op@Operation {operationName, operationSelection, operationType} = do   (schema, varDefs) <- asks id   datatype <- getOperationDataType op schema   let argumentsType = toArgumentsType (getOperationName operationName <> "Args") varDefs@@ -92,7 +93,8 @@   pure     ( FetchDefinition         { clientArgumentsTypeName = fmap clientTypeName argumentsType,-          rootTypeName = clientTypeName rootType+          rootTypeName = clientTypeName rootType,+          fetchOperationType = operationType         },       rootType : (localTypes <> maybeToList argumentsType)     )@@ -160,8 +162,8 @@           { clientTypeName = TypeNameTH path (typeFrom [] dType),             clientCons,             clientKind = KindUnion-          } :-        concat subTypes+          }+          : concat subTypes       )  getVariantType :: [FieldName] -> UnionTag -> Converter (ClientConstructorDefinition, [ClientTypeDefinition])@@ -185,14 +187,14 @@       toFieldDef :: TypeContent TRUE ANY VALID -> Converter (FieldDefinition OUT VALID)       toFieldDef _         | selectionName == "__typename" =-          pure-            FieldDefinition-              { fieldName = "__typename",-                fieldDescription = Nothing,-                fieldType = mkTypeRef "String",-                fieldDirectives = empty,-                fieldContent = Nothing-              }+            pure+              FieldDefinition+                { fieldName = "__typename",+                  fieldDescription = Nothing,+                  fieldType = mkTypeRef "String",+                  fieldDirectives = empty,+                  fieldContent = Nothing+                }       toFieldDef DataObject {objectFields} = selectBy selError selectionName objectFields       toFieldDef DataInterface {interfaceFields} = selectBy selError selectionName interfaceFields       toFieldDef dt = throwError (compileError $ "Type should be output Object \"" <> msg (show dt))

@@ -141,7 +141,8 @@     ( FetchErrorProducedErrors         ( ("Failure" `at` Position {line = 3, column = 7})             `withPath` ["queryTypeName"]-            `custom` "QUERY_BAD" :| []+            `custom` "QUERY_BAD"+            :| []         )         (Just ErrorsWithType {queryTypeName = Just "TestQuery"})     )@@ -163,7 +164,7 @@             `withPath` [ "queryTypeName",                          PropIndex 0                        ]-              :| []+            :| []         )         ( Just             TestErrorsQuery