morpheus-graphql 0.15.1 → 0.16.0

raw patch · 39 files changed

+424/−1218 lines, 39 filesdep +morpheus-graphql-subscriptionsdep +reludedep −megaparsecdep −scientificdep −unliftio-coredep ~morpheus-graphql-corePVP ok

version bump matches the API change (PVP)

Dependencies added: morpheus-graphql-subscriptions, relude

Dependencies removed: megaparsec, scientific, unliftio-core, uuid, websockets

Dependency ranges changed: morpheus-graphql-core

API changes (from Hackage documentation)

Files

• README.md +2/−2
• changelog.md +24/−0
• morpheus-graphql.cabal +7/−18
• src/Data/Morpheus.hs +2/−0
• src/Data/Morpheus/Document.hs +3/−5
• src/Data/Morpheus/Kind.hs +3/−0
• src/Data/Morpheus/Server.hs +2/−111
• src/Data/Morpheus/Server/Deriving/Channels.hs +46/−33
• src/Data/Morpheus/Server/Deriving/Decode.hs +35/−19
• src/Data/Morpheus/Server/Deriving/Encode.hs +14/−2
• src/Data/Morpheus/Server/Deriving/Schema.hs +13/−8
• src/Data/Morpheus/Server/Deriving/Schema/Internal.hs +62/−106
• src/Data/Morpheus/Server/Internal/TH/Decode.hs +15/−0
• src/Data/Morpheus/Server/TH/Compile.hs +9/−6
• src/Data/Morpheus/Server/TH/Declare/Type.hs +2/−2
• src/Data/Morpheus/Server/TH/Transform.hs +1/−2
• src/Data/Morpheus/Server/Types/GQLType.hs +8/−8
• src/Data/Morpheus/Server/Types/SchemaT.hs +62/−48
• src/Data/Morpheus/Types.hs +6/−14
• src/Data/Morpheus/Types/Internal/Subscription.hs +0/−147
• src/Data/Morpheus/Types/Internal/Subscription/Apollo.hs +0/−167
• src/Data/Morpheus/Types/Internal/Subscription/ClientConnectionStore.hs +0/−187
• src/Data/Morpheus/Types/Internal/Subscription/Stream.hs +0/−227
• test/Feature/Holistic/API.hs +2/−2
• test/Feature/Holistic/fragment/loopingFragment/response.json +10/−10
• test/Feature/Holistic/parsing/complex/response.json +4/−4
• test/Feature/Holistic/parsing/directive/notOnVariable/response.json +1/−1
• test/Feature/Holistic/parsing/invalidNotNullOperator/response.json +1/−1
• test/Feature/Input/DefaultValue/intorspection/arguments/response.json +1/−1
• test/Feature/Input/DefaultValue/intorspection/input-compound/response.json +2/−2
• test/Feature/InputType/variables/invalidValue/invalidDefaultValue/response.json +1/−1
• test/Feature/Schema/nameCollision/response.json +6/−3
• test/Feature/WrappedTypeName/API.hs +4/−4
• test/Lib.hs +3/−3
• test/Subscription/API.hs +13/−4
• test/Subscription/Case/ApolloRequest.hs +14/−7
• test/Subscription/Case/Publishing.hs +7/−5
• test/Subscription/Utils.hs +36/−57
• test/Types.hs +3/−1

@@ -26,10 +26,10 @@ _stack.yml_  ```yaml-resolver: lts-15.13+resolver: lts-16.2  extra-deps:-  - morpheus-graphql-0.14.1+  - morpheus-graphql-0.16.0 ```  As Morpheus is quite new, make sure stack can find morpheus-graphql by running `stack upgrade` and `stack update`

@@ -1,5 +1,29 @@ # Changelog +## 0.16.0 - 05.11.2020++## Breaking changes++- subscriptions are extracted in `morpheus-graphql-subscriptions`.+- `Event`, `httpPubApp` and `webSocketsApp` moved `Data.Morpheus.Subscriptions`++## New Features++- `Data.Morpheus.Subscriptions` provides:++  - runPubApp: generalized version of `httpPubApp`+  - runSubApp: generalized version of `webSocketsApp`++- New encode and decode instances for `Set`, `NonEmpty`, `Seq` and `Vector`+  `Set` and `NonEmpty` throw a graphql error when a duplicate is found (Set)+  or when an empty list is sent (NonEmpty).+  **Beware**: Right now, all these types are advertised as lists in the introspection query.+  This is something we are trying to change by submitting a proposal to the graphql spec.++### Minor Changes++- parser performance optimization+ ## 0.15.1 - 12.09.2020  ## 0.15.0 - 12.09.2020

@@ -4,10 +4,10 @@ -- -- see: https://github.com/sol/hpack ----- hash: 5ddd838022cbad8d2916bd481dda961537851981070c4556c00e3b9e61d2307c+-- hash: 4f4683e0c6a040813b49314a575621595a6cc515377d78372f2e6ac0c718be74  name:           morpheus-graphql-version:        0.15.1+version:        0.16.0 synopsis:       Morpheus GraphQL description:    Build GraphQL APIs with your favourite functional language! category:       web, graphql@@ -397,7 +397,6 @@       Data.Morpheus.Types       Data.Morpheus.Server       Data.Morpheus.Document-      Data.Morpheus.Types.Internal.Subscription   other-modules:       Data.Morpheus.Server.Deriving.App       Data.Morpheus.Server.Deriving.Channels@@ -418,9 +417,6 @@       Data.Morpheus.Server.Types.GQLType       Data.Morpheus.Server.Types.SchemaT       Data.Morpheus.Server.Types.Types-      Data.Morpheus.Types.Internal.Subscription.Apollo-      Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore-      Data.Morpheus.Types.Internal.Subscription.Stream       Paths_morpheus_graphql   hs-source-dirs:       src@@ -430,18 +426,14 @@     , base >=4.7 && <5     , bytestring >=0.10.4 && <0.11     , containers >=0.4.2.1 && <0.7-    , megaparsec >=7.0.0 && <9.0.0-    , morpheus-graphql-core >=0.15.0 && <0.16.0+    , morpheus-graphql-core >=0.16.0 && <0.17.0     , mtl >=2.0 && <=3.0-    , scientific >=0.3.6.2 && <0.4+    , relude >=0.3.0     , template-haskell >=2.0 && <=3.0     , text >=1.2.3.0 && <1.3     , transformers >=0.3.0.0 && <0.6-    , unliftio-core >=0.0.1 && <=0.4     , unordered-containers >=0.2.8.0 && <0.3-    , uuid >=1.0 && <=1.4     , vector >=0.12.0.1 && <0.13-    , websockets >=0.11.0 && <=1.0   default-language: Haskell2010  test-suite morpheus-test@@ -478,19 +470,16 @@     , base >=4.7 && <5     , bytestring >=0.10.4 && <0.11     , containers >=0.4.2.1 && <0.7-    , megaparsec >=7.0.0 && <9.0.0     , morpheus-graphql-    , morpheus-graphql-core >=0.15.0 && <0.16.0+    , morpheus-graphql-core >=0.16.0 && <0.17.0+    , morpheus-graphql-subscriptions >=0.16.0 && <0.17.0     , mtl >=2.0 && <=3.0-    , scientific >=0.3.6.2 && <0.4+    , relude >=0.3.0     , tasty     , tasty-hunit     , template-haskell >=2.0 && <=3.0     , text >=1.2.3.0 && <1.3     , transformers >=0.3.0.0 && <0.6-    , unliftio-core >=0.0.1 && <=0.4     , unordered-containers >=0.2.8.0 && <0.3-    , uuid >=1.0 && <=1.4     , vector >=0.12.0.1 && <0.13-    , websockets >=0.11.0 && <=1.0   default-language: Haskell2010

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}  -- | Build GraphQL APIs with your favorite functional language! module Data.Morpheus@@ -25,6 +26,7 @@   ( RootResolver (..),   ) import Data.Morpheus.Types.IO (MapAPI)+import Relude  -- | main query processor and resolver interpreter ::

@@ -1,4 +1,5 @@ {-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Document   ( toGraphQLDocument,@@ -31,11 +32,8 @@ import Data.Morpheus.Types.Internal.Resolving   ( resultOr,   )-import qualified Data.Text.Lazy as LT-  ( fromStrict,-  )-import Data.Text.Lazy.Encoding (encodeUtf8) import Language.Haskell.TH+import Relude hiding (ByteString)  importGQLDocument :: FilePath -> Q [Dec] importGQLDocument src =@@ -59,5 +57,5 @@   proxy (RootResolver m event query mut sub) ->   ByteString toGraphQLDocument =-  resultOr (pack . show) (encodeUtf8 . LT.fromStrict . render)+  resultOr (pack . show) render     . deriveSchema

@@ -1,6 +1,7 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}  -- | associating types to GraphQL Kinds module Data.Morpheus.Kind@@ -18,6 +19,8 @@     isObject,   ) where++import Relude  data GQL_KIND   = SCALAR

@@ -5,129 +5,20 @@ {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE NoImplicitPrelude #-}  -- |  GraphQL Wai Server Applications module Data.Morpheus.Server-  ( webSocketsApp,-    httpPubApp,-    ServerConstraint,-    httpPlayground,+  ( httpPlayground,     compileTimeSchemaValidation,   ) where -import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.IO.Unlift-  ( MonadUnliftIO,-    withRunInIO,-  )--- MORPHEUS--import Data.Foldable (traverse_)-import Data.Function ((&))-import Data.Morpheus.Core-  ( App,-    runApp,-  ) import Data.Morpheus.Server.Deriving.Schema   ( compileTimeSchemaValidation,   ) import Data.Morpheus.Server.Playground   ( httpPlayground,   )-import Data.Morpheus.Types.IO (MapAPI (..))-import Data.Morpheus.Types.Internal.Resolving-  ( Event,-  )-import Data.Morpheus.Types.Internal.Subscription-  ( Input (..),-    Scope (..),-    Store (..),-    WS,-    acceptApolloRequest,-    connectionThread,-    initDefaultStore,-    publishEventWith,-    runStreamHTTP,-    streamApp,-  )-import Network.WebSockets-  ( Connection,-    ServerApp,-    receiveData,-    sendTextData,-  )-import qualified Network.WebSockets as WS--type ServerConstraint e m =-  ( MonadIO m,-    MonadUnliftIO m-  )---- support old version of Websockets-pingThread :: Connection -> IO () -> IO ()--#if MIN_VERSION_websockets(0,12,6)-pingThread connection = WS.withPingThread connection 30 (return ())-#else-pingThread connection = (WS.forkPingThread connection 30 >>)-#endif--defaultWSScope :: MonadIO m => Store e m -> Connection -> Scope WS e m-defaultWSScope Store {writeStore} connection =-  ScopeWS-    { listener = liftIO (receiveData connection),-      callback = liftIO . sendTextData connection,-      update = writeStore-    }--httpPubApp ::-  ( MonadIO m,-    MapAPI a b-  ) =>-  [e -> m ()] ->-  App e m ->-  a ->-  m b-httpPubApp [] app = runApp app-httpPubApp callbacks app =-  mapAPI $-    runStreamHTTP ScopeHTTP {httpCallback}-      . streamApp app-      . Request-  where-    httpCallback e = traverse_ (e &) callbacks---- | Wai WebSocket Server App for GraphQL subscriptions-webSocketsApp ::-  ( MonadUnliftIO m,-    Eq channel-  ) =>-  App (Event channel cont) m ->-  m (ServerApp, Event channel cont -> m ())-webSocketsApp app =-  do-    store <- initDefaultStore-    wsApp <- webSocketsWrapper store (connectionThread app)-    pure-      ( wsApp,-        publishEventWith store-      )--webSocketsWrapper ::-  (MonadUnliftIO m, MonadIO m) =>-  Store e m ->-  (Scope WS e m -> m ()) ->-  m ServerApp-webSocketsWrapper store handler =-  withRunInIO $-    \runIO ->-      pure $-        \pending -> do-          conn <- acceptApolloRequest pending-          pingThread-            conn-            $ runIO (handler (defaultWSScope store conn))

@@ -10,18 +10,15 @@ {-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Server.Deriving.Channels-  ( getChannels,+  ( channelResolver,     ChannelsConstraint,   ) where -import Control.Applicative (pure)-import Control.Monad ((>>=))-import Data.Functor.Identity (Identity (..))-import Data.Maybe (Maybe (..)) import Data.Morpheus.Internal.Utils   ( Failure (..),     elems,+    selectBy,   ) import Data.Morpheus.Server.Deriving.Decode   ( DecodeConstraint,@@ -51,68 +48,84 @@     SubscriptionField (..),   ) import GHC.Generics-import Prelude-  ( (.),-    const,-    lookup,-    map,-  )+import Relude +newtype DerivedChannel e = DerivedChannel+  { _unpackChannel :: Channel e+  }++type ChannelRes (e :: *) = Selection VALID -> ResolverState (DerivedChannel e)+ type ChannelsConstraint e m (subs :: (* -> *) -> *) =   ExploreConstraint e (subs (Resolver SUBSCRIPTION e m)) -getChannels ::+channelResolver ::+  forall e m subs.   ChannelsConstraint e m subs =>   subs (Resolver SUBSCRIPTION e m) ->   Selection VALID ->   ResolverState (Channel e)-getChannels value sel = selectBy sel (exploreChannels value)+channelResolver value = fmap _unpackChannel . channelSelector+  where+    channelSelector ::+      Selection VALID ->+      ResolverState (DerivedChannel e)+    channelSelector = selectBySelection (exploreChannels value) -selectBy ::-  Failure InternalError m =>+selectBySelection ::+  [(FieldName, ChannelRes e)] ->   Selection VALID ->-  [ ( FieldName,-      Selection VALID -> m (Channel e)-    )-  ] ->-  m (Channel e)-selectBy Selection {selectionContent = SelectionSet selSet} ch =+  ResolverState (DerivedChannel e)+selectBySelection channels = withSubscriptionSelection >=> selectSubscription channels++selectSubscription ::+  [(FieldName, ChannelRes e)] ->+  Selection VALID ->+  ResolverState (DerivedChannel e)+selectSubscription channels sel@Selection {selectionName} =+  selectBy+    onFail+    selectionName+    channels+    >>= onSucc+  where+    onFail = "invalid subscription: no channel is selected." :: InternalError+    onSucc (_, f) = f sel++withSubscriptionSelection :: Selection VALID -> ResolverState (Selection VALID)+withSubscriptionSelection Selection {selectionContent = SelectionSet selSet} =   case elems selSet of-    [sel@Selection {selectionName}] -> case lookup selectionName ch of-      Nothing -> failure ("invalid subscription: no channel is selected." :: InternalError)-      Just f -> f sel+    [sel] -> pure sel     _ -> failure ("invalid subscription: there can be only one top level selection" :: InternalError)-selectBy _ _ = failure ("invalid subscription: expected selectionSet" :: InternalError)+withSubscriptionSelection _ = failure ("invalid subscription: expected selectionSet" :: InternalError)  class GetChannel e a | a -> e where-  getChannel :: a -> Selection VALID -> ResolverState (Channel e)+  getChannel :: a -> ChannelRes e  instance GetChannel e (SubscriptionField (Resolver SUBSCRIPTION e m a)) where-  getChannel SubscriptionField {channel} = const (pure channel)+  getChannel = const . pure . DerivedChannel . channel  instance   DecodeConstraint arg =>   GetChannel e (arg -> SubscriptionField (Resolver SUBSCRIPTION e m a))   where   getChannel f sel@Selection {selectionArguments} =-    decodeArguments selectionArguments >>= (`getChannel` sel) . f+    decodeArguments selectionArguments >>= (`getChannel` sel)+      . f  ------------------------------------------------------ -type ChannelRes e = Selection VALID -> ResolverState (Channel e)- type ExploreConstraint e a =   ( GQLType a,     Generic a,-    TypeRep (GetChannel e) (Selection VALID -> ResolverState (Channel e)) (Rep a)+    TypeRep (GetChannel e) (ChannelRes e) (Rep a)   )  exploreChannels :: forall e a. ExploreConstraint e a => a -> [(FieldName, ChannelRes e)] exploreChannels =   convertNode     . toValue-      ( TypeConstraint (getChannel . runIdentity) ::-          TypeConstraint (GetChannel e) (Selection VALID -> ResolverState (Channel e)) Identity+      ( TypeConstraint (getChannel . runIdentity) :: TypeConstraint (GetChannel e) (ChannelRes e) Identity       )  convertNode :: DataType (ChannelRes e) -> [(FieldName, ChannelRes e)]

@@ -21,10 +21,12 @@   ) where -import Control.Applicative ((<*>), pure)+import Control.Applicative (pure, (<*>)) import Control.Monad ((>>=))-import Data.Functor ((<$>), Functor (..))+import Data.Functor (Functor (..), (<$>)) import Data.List (elem)+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty import Data.Maybe (Maybe (..)) import Data.Morpheus.Internal.Utils   ( elems,@@ -41,19 +43,12 @@     datatypeNameProxy,     selNameProxy,   )-import Data.Morpheus.Server.Internal.TH.Decode-  ( decodeFieldWith,-    withInputObject,-    withInputUnion,-    withList,-    withMaybe,-    withScalar,-  )+import Data.Morpheus.Server.Internal.TH.Decode (decodeFieldWith, withInputObject, withInputUnion, withList, withMaybe, withRefinedList, withScalar) import Data.Morpheus.Server.Types.GQLType   ( GQLType       ( KIND,-        __type,-        typeOptions+        typeOptions,+        __type       ),     GQLTypeOptions (..),     TypeData (..),@@ -79,14 +74,15 @@   ) import Data.Proxy (Proxy (..)) import Data.Semigroup (Semigroup (..))+import Data.Sequence (Seq)+import qualified Data.Sequence as Seq+import Data.Set (Set)+import qualified Data.Set as Set+import Data.String (IsString (fromString))+import Data.Vector (Vector)+import qualified Data.Vector as Vector import GHC.Generics-import Prelude-  ( ($),-    (.),-    Eq (..),-    Ord,-    otherwise,-  )+import Prelude (Either (Left, Right), Eq (..), Foldable (length), Ord, maybe, otherwise, show, ($), (-), (.))  type DecodeConstraint a =   ( Generic a,@@ -112,6 +108,26 @@  instance Decode a => Decode [a] where   decode = withList decode++instance Decode a => Decode (NonEmpty a) where+  decode = withRefinedList (maybe (Left "Expected a NonEmpty list") Right . NonEmpty.nonEmpty) decode++-- | Should this instance dedupe silently or fail on dupes ?+instance (Ord a, Decode a) => Decode (Set a) where+  decode val = do+    listVal <- withList (decode @a) val+    let setVal = Set.fromList listVal+    let setLength = length setVal+    let listLength = length setVal+    if listLength == setLength+      then pure setVal+      else failure (fromString ("Expected a List without duplicates, found " <> show (setLength - listLength) <> " duplicates") :: InternalError)++instance (Decode a) => Decode (Seq a) where+  decode = fmap Seq.fromList . withList decode++instance (Decode a) => Decode (Vector a) where+  decode = fmap Vector.fromList . withList decode  -- | Decode GraphQL type with Specific Kind class DecodeKind (kind :: GQL_KIND) a where

@@ -23,6 +23,8 @@ import Control.Monad (Monad ((>>=))) import Data.Functor (fmap) import Data.Functor.Identity (Identity (..))+import Data.List.NonEmpty (NonEmpty)+import qualified Data.List.NonEmpty as NonEmpty import Data.Map (Map) import qualified Data.Map as M   ( toList,@@ -40,7 +42,7 @@   ) import Data.Morpheus.Server.Deriving.Channels   ( ChannelsConstraint,-    getChannels,+    channelResolver,   ) import Data.Morpheus.Server.Deriving.Decode   ( DecodeConstraint,@@ -92,6 +94,8 @@   ( toList,   ) import Data.Traversable (traverse)+import Data.Vector (Vector)+import qualified Data.Vector as Vector import GHC.Generics   ( Generic (..),   )@@ -123,6 +127,14 @@ instance Encode o e m (Pair k v) => Encode o e m (k, v) where   encode (key, value) = encode (Pair key value) +--  NonEmpty+instance Encode o e m [a] => Encode o e m (NonEmpty a) where+  encode = encode . NonEmpty.toList++--  Vector+instance Encode o e m [a] => Encode o e m (Vector a) where+  encode = encode . Vector.toList+ --  Set instance Encode o e m [a] => Encode o e m (Set a) where   encode = encode . S.toList@@ -269,4 +281,4 @@     where       channelMap         | isEmptyType (Proxy :: Proxy (sub (Resolver SUBSCRIPTION e m))) = Nothing-        | otherwise = Just (getChannels subscriptionResolver)+        | otherwise = Just (channelResolver subscriptionResolver)

@@ -67,9 +67,7 @@   ) import Data.Morpheus.Server.Types.SchemaT   ( SchemaT,-    closeWith,-    setMutation,-    setSubscription,+    toSchema,   ) import Data.Morpheus.Server.Types.Types   ( MapKind,@@ -97,7 +95,6 @@     TypeDefinition (..),     TypeName,     fieldsToArguments,-    initTypeLib,   ) import Data.Morpheus.Types.Internal.Resolving   ( Resolver,@@ -147,10 +144,18 @@   f (Schema CONST) deriveSchema _ = resultOr failure pure schema   where-    schema = closeWith (initTypeLib <$> queryDef <* mutationDef <* subscriptionDef)-    queryDef = deriveObjectType (Proxy @(query (Resolver QUERY e m)))-    mutationDef = deriveObjectType (Proxy @(mut (Resolver MUTATION e m))) >>= setMutation-    subscriptionDef = deriveObjectType (Proxy @(subs (Resolver SUBSCRIPTION e m))) >>= setSubscription+    schema = toSchema schemaT+    schemaT ::+      SchemaT+        ( TypeDefinition OBJECT CONST,+          TypeDefinition OBJECT CONST,+          TypeDefinition OBJECT CONST+        )+    schemaT =+      (,,)+        <$> deriveObjectType (Proxy @(query (Resolver QUERY e m)))+        <*> deriveObjectType (Proxy @(mut (Resolver MUTATION e m)))+        <*> deriveObjectType (Proxy @(subs (Resolver SUBSCRIPTION e m)))  instance {-# OVERLAPPABLE #-} (GQLType a, DeriveKindedType (KIND a) a) => DeriveType cat a where   deriveType _ = deriveKindedType (KindedProxy :: KindedProxy (KIND a) a)

@@ -10,7 +10,6 @@ {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}-{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeApplications #-}@@ -48,7 +47,6 @@ import Data.Morpheus.Error (globalErrorMessage) import Data.Morpheus.Internal.Utils   ( Failure (..),-    empty,     singleton,   ) import Data.Morpheus.Server.Deriving.Utils@@ -71,11 +69,8 @@ import Data.Morpheus.Types.Internal.AST   ( CONST,     DataEnumValue (..),-    DataFingerprint (..),-    DataUnion,     Description,     Directives,-    ELEM,     FieldContent (..),     FieldDefinition (..),     FieldName,@@ -106,7 +101,6 @@   ( Eventless,     Result (..),   )-import Data.Proxy (Proxy (..)) import Data.Semigroup ((<>)) import Data.Traversable (traverse) import Language.Haskell.TH (Exp, Q)@@ -166,10 +160,10 @@ mkObjectType fields typeName = mkType typeName (DataObject [] fields)  failureOnlyObject :: forall c a b. (GQLType a) => KindedType c a -> SchemaT b-failureOnlyObject _ =+failureOnlyObject proxy =   failure     $ globalErrorMessage-    $ msg (gqlTypeName $ __type (Proxy @a)) <> " should have only one nonempty constructor"+    $ msg (gqlTypeName $ __type proxy) <> " should have only one nonempty constructor"  type TyContentM kind = (SchemaT (Maybe (FieldContent TRUE kind CONST))) @@ -187,20 +181,19 @@ unpackMs = traverse unpackCons  builder ::-  forall kind (a :: *).   GQLType a =>   KindedType kind a ->   [ConsRep (TyContent kind)] ->   SchemaT (TypeContent TRUE kind CONST)-builder scope [ConsRep {consFields}] = buildObj <$> sequence (implements (Proxy @a))+builder scope [ConsRep {consFields}] = buildObj <$> sequence (implements scope)   where     buildObj interfaces = wrapFields interfaces scope (mkFieldsDefinition consFields)-builder scope cons = genericUnion scope cons+builder scope cons = genericUnion cons   where-    proxy = Proxy @a-    typeData = __type proxy-    genericUnion InputType = buildInputUnion typeData-    genericUnion OutputType = buildUnionType typeData DataUnion (DataObject [])+    typeData = __type scope+    genericUnion =+      mkUnionType scope typeData+        . analyseRep (gqlTypeName typeData)  class UpdateDef value where   updateDef :: GQLType a => f a -> value -> value@@ -261,12 +254,18 @@   SchemaT () updateByContent f proxy =   updateSchema-    (gqlTypeName $ __type proxy)     (gqlFingerprint $ __type proxy)     deriveD     proxy   where-    deriveD _ = buildType proxy <$> f proxy+    deriveD =+      fmap+        ( TypeDefinition+            (description proxy)+            (gqlTypeName (__type proxy))+            []+        )+        . f  analyseRep :: TypeName -> [ConsRep (Maybe (FieldContent TRUE kind CONST))] -> ResRep (Maybe (FieldContent TRUE kind CONST)) analyseRep baseName cons =@@ -279,47 +278,24 @@     (enumRep, left1) = partition isEmptyConstraint cons     (unionRefRep, unionRecordRep) = partition (isUnionRef baseName) left1 -buildInputUnion ::-  TypeData ->-  [ConsRep (Maybe (FieldContent TRUE IN CONST))] ->-  SchemaT (TypeContent TRUE IN CONST)-buildInputUnion TypeData {gqlTypeName, gqlFingerprint} =-  mkInputUnionType gqlFingerprint . analyseRep gqlTypeName--buildUnionType ::-  (ELEM LEAF kind ~ TRUE) =>+mkUnionType ::+  KindedType kind a ->   TypeData ->-  (DataUnion CONST -> TypeContent TRUE kind CONST) ->-  (FieldsDefinition kind CONST -> TypeContent TRUE kind CONST) ->-  [ConsRep (Maybe (FieldContent TRUE kind CONST))] ->+  ResRep (Maybe (FieldContent TRUE kind CONST)) ->   SchemaT (TypeContent TRUE kind CONST)-buildUnionType typeData wrapUnion wrapObject =-  mkUnionType typeData wrapUnion wrapObject . analyseRep (gqlTypeName typeData)--mkInputUnionType :: DataFingerprint -> ResRep (Maybe (FieldContent TRUE IN CONST)) -> SchemaT (TypeContent TRUE IN CONST)-mkInputUnionType _ ResRep {unionRef = [], unionRecordRep = [], enumCons} = pure $ mkEnumContent enumCons-mkInputUnionType baseFingerprint ResRep {unionRef, unionRecordRep, enumCons} = DataInputUnion <$> typeMembers+mkUnionType InputType _ ResRep {unionRef = [], unionRecordRep = [], enumCons} = pure $ mkEnumContent enumCons+mkUnionType OutputType _ ResRep {unionRef = [], unionRecordRep = [], enumCons} = pure $ mkEnumContent enumCons+mkUnionType InputType _ ResRep {unionRef, unionRecordRep, enumCons} = DataInputUnion <$> typeMembers   where     typeMembers :: SchemaT [UnionMember IN CONST]-    typeMembers = withMembers <$> buildUnions wrapInputObject baseFingerprint unionRecordRep+    typeMembers = withMembers <$> buildUnions unionRecordRep       where         withMembers unionMembers = fmap mkUnionMember (unionRef <> unionMembers) <> fmap (`UnionMember` False) enumCons-    wrapInputObject :: (FieldsDefinition IN CONST -> TypeContent TRUE IN CONST)-    wrapInputObject = DataInputObject--mkUnionType ::-  (ELEM LEAF kind ~ TRUE) =>-  TypeData ->-  (DataUnion CONST -> TypeContent TRUE kind CONST) ->-  (FieldsDefinition kind CONST -> TypeContent TRUE kind CONST) ->-  ResRep (Maybe (FieldContent TRUE kind CONST)) ->-  SchemaT (TypeContent TRUE kind CONST)-mkUnionType _ _ _ ResRep {unionRef = [], unionRecordRep = [], enumCons} = pure $ mkEnumContent enumCons-mkUnionType typeData@TypeData {gqlFingerprint} wrapUnion wrapObject ResRep {unionRef, unionRecordRep, enumCons} = wrapUnion . map mkUnionMember <$> typeMembers+mkUnionType OutputType typeData ResRep {unionRef, unionRecordRep, enumCons} = DataUnion . map mkUnionMember <$> typeMembers   where     typeMembers = do-      enums <- buildUnionEnum wrapObject typeData enumCons-      unions <- buildUnions wrapObject gqlFingerprint unionRecordRep+      enums <- buildUnionEnum typeData enumCons+      unions <- buildUnions unionRecordRep       pure (unionRef <> enums <> unions)  wrapFields :: [TypeName] -> KindedType kind a -> FieldsDefinition kind CONST -> TypeContent TRUE kind CONST@@ -334,21 +310,35 @@   mkField fieldValue fieldSelector fieldTypeRef  buildUnions ::-  (FieldsDefinition kind CONST -> TypeContent TRUE kind CONST) ->-  DataFingerprint ->+  PackObject kind =>   [ConsRep (Maybe (FieldContent TRUE kind CONST))] ->   SchemaT [TypeName]-buildUnions wrapObject baseFingerprint cons =+buildUnions cons =   traverse_ buildURecType cons $> fmap consName cons   where-    buildURecType = insertType . buildUnionRecord wrapObject baseFingerprint+    buildURecType = insertType . buildUnionRecord +buildUnionRecord ::+  PackObject kind =>+  ConsRep (Maybe (FieldContent TRUE kind CONST)) ->+  TypeDefinition kind CONST+buildUnionRecord ConsRep {consName, consFields} =+  mkType consName (packObject $ mkFieldsDefinition consFields)++class PackObject kind where+  packObject :: FieldsDefinition kind CONST -> TypeContent TRUE kind CONST++instance PackObject OUT where+  packObject = DataObject []++instance PackObject IN where+  packObject = DataInputObject+ buildUnionEnum ::-  (FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) ->   TypeData ->   [TypeName] ->   SchemaT [TypeName]-buildUnionEnum wrapObject TypeData {gqlTypeName, gqlFingerprint} enums = updates $> members+buildUnionEnum TypeData {gqlTypeName} enums = updates $> members   where     members       | null enums = []@@ -360,58 +350,24 @@     updates       | null enums = pure ()       | otherwise =-        buildEnumObject wrapObject enumTypeWrapperName gqlFingerprint enumTypeName-          *> buildEnum enumTypeName gqlFingerprint enums--buildType :: GQLType a => f a -> TypeContent TRUE cat CONST -> TypeDefinition cat CONST-buildType proxy typeContent =-  TypeDefinition-    { typeName = gqlTypeName typeData,-      typeFingerprint = gqlFingerprint typeData,-      typeDescription = description proxy,-      typeDirectives = [],-      typeContent-    }-  where-    typeData = __type proxy--buildUnionRecord ::-  (FieldsDefinition kind CONST -> TypeContent TRUE kind CONST) ->-  DataFingerprint ->-  ConsRep (Maybe (FieldContent TRUE kind CONST)) ->-  TypeDefinition kind CONST-buildUnionRecord wrapObject typeFingerprint ConsRep {consName, consFields} =-  mkSubType consName typeFingerprint (wrapObject $ mkFieldsDefinition consFields)+        buildEnumObject enumTypeWrapperName enumTypeName+          *> buildEnum enumTypeName enums -buildEnum :: TypeName -> DataFingerprint -> [TypeName] -> SchemaT ()-buildEnum typeName typeFingerprint tags =+buildEnum :: TypeName -> [TypeName] -> SchemaT ()+buildEnum typeName tags =   insertType-    ( mkSubType typeName typeFingerprint (mkEnumContent tags) ::+    ( mkType typeName (mkEnumContent tags) ::         TypeDefinition LEAF CONST     ) -buildEnumObject ::-  (FieldsDefinition cat CONST -> TypeContent TRUE cat CONST) ->-  TypeName ->-  DataFingerprint ->-  TypeName ->-  SchemaT ()-buildEnumObject wrapObject typeName typeFingerprint enumTypeName =-  insertType $-    mkSubType-      typeName-      typeFingerprint-      ( wrapObject-          $ singleton-          $ mkInputValue "enum" [] enumTypeName-      )--mkSubType :: TypeName -> DataFingerprint -> TypeContent TRUE k CONST -> TypeDefinition k CONST-mkSubType typeName typeFingerprint typeContent =-  TypeDefinition-    { typeName,-      typeFingerprint,-      typeDescription = Nothing,-      typeDirectives = empty,-      typeContent-    }+buildEnumObject :: TypeName -> TypeName -> SchemaT ()+buildEnumObject typeName enumTypeName =+  insertType+    ( mkType+        typeName+        ( DataObject []+            $ singleton+            $ mkInputValue "enum" [] enumTypeName+        ) ::+        TypeDefinition OBJECT CONST+    )

@@ -8,6 +8,7 @@   ( withInputObject,     withMaybe,     withList,+    withRefinedList,     withEnum,     withInputUnion,     decodeFieldWith,@@ -72,6 +73,20 @@   m [a] withList decode (List li) = traverse decode li withList _ isType = failure (typeMismatch "List" isType)++-- | Useful for more restrictive instances of lists (non empty, size indexed etc)+withRefinedList ::+  (Failure InternalError m, Monad m) =>+  ([a] -> Either Message (rList a)) ->+  (ValidValue -> m a) ->+  ValidValue ->+  m (rList a)+withRefinedList refiner decode (List li) = do+  listRes <- traverse decode li+  case refiner listRes of+    Left err -> failure (typeMismatch err (List li))+    Right value -> pure value+withRefinedList _ _ isType = failure (typeMismatch "List" isType)  withEnum :: Failure InternalError m => (TypeName -> m a) -> Value VALID -> m a withEnum decode (Enum value) = decode value

@@ -1,4 +1,6 @@ {-# LANGUAGE NamedFieldPuns #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Server.TH.Compile   ( compileDocument,@@ -10,6 +12,9 @@ -- --  Morpheus +import qualified Data.ByteString.Lazy.Char8 as LB+  ( pack,+  ) import Data.Morpheus.Core   ( parseTypeDefinitions,   )@@ -29,11 +34,9 @@ import Data.Morpheus.Types.Internal.Resolving   ( Result (..),   )-import qualified Data.Text as T-  ( pack,-  ) import Language.Haskell.TH (Dec, Q) import Language.Haskell.TH.Quote (QuasiQuoter (..))+import Relude  gqlDocumentNamespace :: QuasiQuoter gqlDocumentNamespace =@@ -45,7 +48,7 @@     }   where     notHandled things =-      error $ things ++ " are not supported by the GraphQL QuasiQuoter"+      error $ things <> " are not supported by the GraphQL QuasiQuoter"  gqlDocument :: QuasiQuoter gqlDocument =@@ -57,11 +60,11 @@     }   where     notHandled things =-      error $ things ++ " are not supported by the GraphQL QuasiQuoter"+      error $ things <> " are not supported by the GraphQL QuasiQuoter"  compileDocument :: ServerDecContext -> String -> Q [Dec] compileDocument ctx documentTXT =-  case parseTypeDefinitions (T.pack documentTXT) of+  case parseTypeDefinitions (LB.pack documentTXT) of     Failure errors -> fail (renderGQLErrors errors)     Success {result = schema, warnings} ->       gqlWarnings warnings >> toTHDefinitions (namespace ctx) schema >>= declare ctx

@@ -2,13 +2,13 @@ {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Data.Morpheus.Server.TH.Declare.Type   ( declareType,   ) where -import Control.Monad.Reader (asks) import Data.Morpheus.Internal.TH   ( declareTypeRef,     m',@@ -38,8 +38,8 @@ import Data.Morpheus.Types.Internal.Resolving   ( SubscriptionField,   )-import GHC.Generics (Generic) import Language.Haskell.TH+import Relude hiding (Type)  declareType :: ServerTypeDefinition cat s -> ServerDec [Dec] declareType ServerTypeDefinition {tKind = KindScalar} = pure []

@@ -36,7 +36,6 @@     FieldContent (..),     FieldDefinition (..),     FieldName,-    Fields (..),     FieldsDefinition,     IN,     OUT,@@ -226,7 +225,7 @@     pure       [ ServerTypeDefinition           { tName,-            tCons = [mkCons tName (Fields arguments)],+            tCons = [mkCons tName arguments],             tKind = KindInputObject,             typeArgD = [],             typeOriginal = Nothing

@@ -21,7 +21,10 @@ -- MORPHEUS import Data.Map (Map) import Data.Morpheus.Kind-import Data.Morpheus.Server.Types.SchemaT (SchemaT)+import Data.Morpheus.Server.Types.SchemaT+  ( SchemaT,+    TypeFingerprint (..),+  ) import Data.Morpheus.Server.Types.Types   ( MapKind,     Pair,@@ -31,7 +34,6 @@ import Data.Morpheus.Types.Internal.AST   ( ArgumentsDefinition,     CONST,-    DataFingerprint (..),     Description,     Directives,     FieldName,@@ -39,7 +41,6 @@     TypeName (..),     TypeWrapper (..),     Value,-    internalFingerprint,     toNullable,   ) import Data.Morpheus.Types.Internal.Resolving@@ -76,13 +77,12 @@     fmap,     id,     mempty,-    show,   )  data TypeData = TypeData   { gqlTypeName :: TypeName,     gqlWrappers :: [TypeWrapper],-    gqlFingerprint :: DataFingerprint+    gqlFingerprint :: TypeFingerprint   }  data GQLTypeOptions = GQLTypeOptions@@ -102,8 +102,8 @@   where     getName = fmap (fmap (pack . tyConName)) (fmap replacePairCon . ignoreResolver . splitTyConApp . typeRep) -getFingerprint :: Typeable a => f a -> DataFingerprint-getFingerprint = DataFingerprint "Typeable" . fmap show . conFingerprints+getFingerprint :: Typeable a => f a -> TypeFingerprint+getFingerprint = TypeableFingerprint . conFingerprints   where     conFingerprints = fmap (fmap tyConFingerprint) (ignoreResolver . splitTyConApp . typeRep) @@ -119,7 +119,7 @@ mkTypeData name =   TypeData     { gqlTypeName = name,-      gqlFingerprint = internalFingerprint name [],+      gqlFingerprint = InternalFingerprint name,       gqlWrappers = []     } 

@@ -1,4 +1,5 @@ {-# LANGUAGE DeriveFunctor #-}+{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-}@@ -10,55 +11,76 @@  module Data.Morpheus.Server.Types.SchemaT   ( SchemaT,-    closeWith,     updateSchema,     insertType,-    setMutation,-    setSubscription,+    TypeFingerprint (..),+    toSchema,   ) where  import Control.Applicative (Applicative (..)) import Control.Monad (Monad (..), foldM) import Data.Function ((&))-import Data.Functor (Functor (..))-import Data.Morpheus.Error (nameCollisionError)+import Data.Functor ((<$>), Functor (..))+import Data.Map+  ( Map,+    elems,+    empty,+    insert,+    member,+  ) import Data.Morpheus.Internal.Utils   ( Failure (..),   ) import Data.Morpheus.Types.Internal.AST-  ( CONST,-    DataFingerprint,+  ( ANY,+    CONST,+    CONST,     OBJECT,     Schema (..),     TypeContent (..),     TypeDefinition (..),-    TypeName (..),-    isNotSystemTypeName,-    isTypeDefined,-    safeDefineType,+    TypeName,+    defineSchemaWith,+    toAny,   ) import Data.Morpheus.Types.Internal.Resolving   ( Eventless,   ) import Data.Semigroup (Semigroup (..))+import GHC.Fingerprint.Type (Fingerprint)+import GHC.Generics (Generic) import Prelude   ( ($),     (.),     Eq (..),     Maybe (..),+    Ord,+    Show,     const,     null,     otherwise,-    uncurry,   ) +data TypeFingerprint+  = TypeableFingerprint [Fingerprint]+  | InternalFingerprint TypeName+  | CustomFingerprint TypeName+  deriving+    ( Generic,+      Show,+      Eq,+      Ord+    )++type MyMap = Map TypeFingerprint (TypeDefinition ANY CONST)+ -- Helper Functions newtype SchemaT a = SchemaT   { runSchemaT ::       Eventless         ( a,-          [Schema CONST -> Eventless (Schema CONST)]+          [MyMap -> Eventless MyMap]         )   }   deriving (Functor)@@ -71,11 +93,10 @@  instance Applicative SchemaT where   pure = SchemaT . pure . (,[])-  (SchemaT v1) <*> (SchemaT v2) =-    SchemaT $ do-      (f, u1) <- v1-      (a, u2) <- v2-      pure (f a, u1 <> u2)+  (SchemaT v1) <*> (SchemaT v2) = SchemaT $ do+    (f, u1) <- v1+    (a, u2) <- v2+    pure (f a, u1 <> u2)  instance Monad SchemaT where   return = pure@@ -85,17 +106,17 @@       (y, up2) <- runSchemaT (f x)       pure (y, up1 <> up2) -closeWith :: SchemaT (Schema CONST) -> Eventless (Schema CONST)-closeWith (SchemaT v) = v >>= uncurry execUpdates--init :: (Schema CONST -> Eventless (Schema CONST)) -> SchemaT ()-init f = SchemaT $ pure ((), [f])--setMutation :: TypeDefinition OBJECT CONST -> SchemaT ()-setMutation mut = init (\schema -> pure $ schema {mutation = optionalType mut})--setSubscription :: TypeDefinition OBJECT CONST -> SchemaT ()-setSubscription x = init (\schema -> pure $ schema {subscription = optionalType x})+toSchema ::+  SchemaT+    ( TypeDefinition OBJECT CONST,+      TypeDefinition OBJECT CONST,+      TypeDefinition OBJECT CONST+    ) ->+  Eventless (Schema CONST)+toSchema (SchemaT v) = do+  ((q, m, s), typeDefs) <- v+  types <- elems <$> execUpdates empty typeDefs+  defineSchemaWith types (optionalType q, optionalType m, optionalType s)  optionalType :: TypeDefinition OBJECT CONST -> Maybe (TypeDefinition OBJECT CONST) optionalType td@TypeDefinition {typeContent = DataObject {objectFields}}@@ -105,28 +126,21 @@ execUpdates :: Monad m => a -> [a -> m a] -> m a execUpdates = foldM (&) -insertType ::-  TypeDefinition cat CONST ->-  SchemaT ()-insertType dt@TypeDefinition {typeName, typeFingerprint} =-  updateSchema typeName typeFingerprint (const $ pure dt) ()+insertType :: TypeDefinition cat CONST -> SchemaT ()+insertType dt = updateSchema (CustomFingerprint (typeName dt)) (const $ pure dt) ()  updateSchema ::-  TypeName ->-  DataFingerprint ->+  TypeFingerprint ->   (a -> SchemaT (TypeDefinition cat CONST)) ->   a ->   SchemaT ()-updateSchema typeName typeFingerprint f x-  | isNotSystemTypeName typeName = SchemaT (pure ((), [upLib]))-  | otherwise = SchemaT (pure ((), []))+updateSchema InternalFingerprint {} _ _ = SchemaT $ pure ((), [])+updateSchema fingerprint f x =+  SchemaT $ pure ((), [upLib])   where-    upLib :: Schema CONST -> Eventless (Schema CONST)-    upLib lib = case isTypeDefined typeName lib of-      Nothing -> do-        (tyDef, updater) <- runSchemaT (f x)-        execUpdates lib (safeDefineType tyDef : updater)-      Just fingerprint'-        | fingerprint' == typeFingerprint -> pure lib-        -- throw error if 2 different types has same name-        | otherwise -> failure [nameCollisionError typeName]+    upLib :: MyMap -> Eventless MyMap+    upLib lib+      | member fingerprint lib = pure lib+      | otherwise = do+        (type', updates) <- runSchemaT (f x)+        execUpdates lib ((pure . insert fingerprint (toAny type')) : updates)

@@ -10,8 +10,7 @@  -- | GQL Types module Data.Morpheus.Types-  ( Event (..),-    GQLType (KIND, description, implements),+  ( GQLType (KIND, description, implements, getDescriptions, typeOptions, getDirectives),     GQLScalar (parseValue, serialize),     GQLRequest (..),     GQLResponse (..),@@ -33,9 +32,6 @@     subscribe,     unsafeInternalContext,     ResolverContext (..),-    Input,-    WS,-    HTTP,     -- Resolvers     ResolverO,     ComposedResolver,@@ -55,7 +51,8 @@     interface,     SubscriptionField,     App,-    RenderGQL (..),+    RenderGQL,+    render,     GQLTypeOptions (..),   ) where@@ -70,7 +67,8 @@   ) import Data.Morpheus.Core   ( App,-    RenderGQL (..),+    RenderGQL,+    render,   ) import Data.Morpheus.Server.Deriving.Schema   ( DeriveType,@@ -104,8 +102,7 @@     msg,   ) import Data.Morpheus.Types.Internal.Resolving-  ( Event (..),-    Failure,+  ( Failure,     PushEvents (..),     Resolver,     ResolverContext (..),@@ -115,11 +112,6 @@     pushEvents,     subscribe,     unsafeInternalContext,-  )-import Data.Morpheus.Types.Internal.Subscription-  ( HTTP,-    Input,-    WS,   ) import Data.Proxy   ( Proxy (..),

@@ -1,147 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Data.Morpheus.Types.Internal.Subscription-  ( connect,-    disconnect,-    connectionThread,-    runStreamWS,-    runStreamHTTP,-    Scope (..),-    Input (..),-    WS,-    HTTP,-    acceptApolloRequest,-    publish,-    Store (..),-    initDefaultStore,-    publishEventWith,-    ClientConnectionStore,-    empty,-    toList,-    connectionSessionIds,-    SessionID,-    streamApp,-  )-where--import Control.Concurrent-  ( modifyMVar_,-    newMVar,-    readMVar,-  )-import Control.Exception (finally)-import Control.Monad (forever)-import Control.Monad.IO.Class (MonadIO (..))-import Control.Monad.IO.Unlift-  ( MonadUnliftIO,-    withRunInIO,-  )--- MORPHEUS--import Data.Morpheus.Core-  ( App,-    runAppStream,-  )-import Data.Morpheus.Internal.Utils-  ( empty,-  )-import Data.Morpheus.Types.Internal.Resolving-  ( Event,-  )-import Data.Morpheus.Types.Internal.Subscription.Apollo-  ( acceptApolloRequest,-  )-import Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore-  ( ClientConnectionStore,-    SessionID,-    connectionSessionIds,-    delete,-    publish,-    toList,-  )-import Data.Morpheus.Types.Internal.Subscription.Stream-  ( HTTP,-    Input (..),-    Scope (..),-    Stream,-    WS,-    runStreamHTTP,-    runStreamWS,-    toOutStream,-  )-import Data.UUID.V4 (nextRandom)--streamApp :: Monad m => App e m -> Input api -> Stream api e m-streamApp app = toOutStream (runAppStream app)--connect :: MonadIO m => m (Input WS)-connect = Init <$> liftIO nextRandom--disconnect :: Scope WS e m -> Input WS -> m ()-disconnect ScopeWS {update} (Init clientID) = update (delete clientID)---- | PubSubStore interface--- shared GraphQL state between __websocket__ and __http__ server,--- you can define your own store if you provide write and read methods--- to work properly Morpheus needs all entries of ClientConnectionStore (+ client Callbacks)--- that why it is recomended that you use many local ClientStores on evenry server node--- rathen then single centralized Store.-data Store e m = Store-  { readStore :: m (ClientConnectionStore e m),-    writeStore :: (ClientConnectionStore e m -> ClientConnectionStore e m) -> m ()-  }--publishEventWith ::-  (MonadIO m, Eq channel) =>-  Store (Event channel cont) m ->-  Event channel cont ->-  m ()-publishEventWith store event = readStore store >>= publish event---- | initializes empty GraphQL state-initDefaultStore ::-  ( MonadIO m,-    MonadIO m2-  ) =>-  m2 (Store event m)-initDefaultStore = do-  store <- liftIO $ newMVar empty-  pure-    Store-      { readStore = liftIO $ readMVar store,-        writeStore = \changes -> liftIO $ modifyMVar_ store (return . changes)-      }--finallyM :: MonadUnliftIO m => m () -> m () -> m ()-finallyM loop end = withRunInIO $ \runIO -> finally (runIO loop) (runIO end)--connectionThread ::-  ( MonadUnliftIO m-  ) =>-  App e m ->-  Scope WS e m ->-  m ()-connectionThread api scope = do-  input <- connect-  finallyM-    (connectionLoop api scope input)-    (disconnect scope input)--connectionLoop ::-  Monad m =>-  App e m ->-  Scope WS e m ->-  Input WS ->-  m ()-connectionLoop app scope input =-  forever-    $ runStreamWS scope-    $ streamApp app input

@@ -1,167 +0,0 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Types.Internal.Subscription.Apollo-  ( ApolloAction (..),-    apolloFormat,-    acceptApolloRequest,-    toApolloResponse,-    Validation,-  )-where--import Control.Applicative (Applicative (..))-import Control.Monad.IO.Class (MonadIO (..))-import Data.Aeson-  ( (.:),-    (.:?),-    (.=),-    FromJSON (..),-    ToJSON (..),-    Value (..),-    eitherDecode,-    encode,-    pairs,-    withObject,-  )-import Data.ByteString.Lazy.Char8-  ( ByteString,-    pack,-  )-import Data.Either-  ( Either (..),-    either,-  )-import Data.Functor ((<$>))-import Data.Maybe-  ( Maybe (..),-    maybe,-  )-import Data.Morpheus.Types.IO-  ( GQLRequest (..),-    GQLResponse,-  )-import Data.Morpheus.Types.Internal.AST-  ( FieldName,-    Token,-  )-import Data.Semigroup ((<>))-import Data.Text-  ( Text,-    unpack,-  )-import GHC.Generics (Generic)-import Network.WebSockets-  ( AcceptRequest (..),-    Connection,-    PendingConnection,-    RequestHead,-    acceptRequestWith,-    getRequestSubprotocols,-    pendingRequest,-  )-import Prelude-  ( ($),-    (.),-    Show,-    String,-  )--type ID = Text--data ApolloSubscription payload = ApolloSubscription-  { apolloId :: Maybe ID,-    apolloType :: Text,-    apolloPayload :: Maybe payload-  }-  deriving (Show, Generic)--instance FromJSON a => FromJSON (ApolloSubscription a) where-  parseJSON = withObject "ApolloSubscription" objectParser-    where-      objectParser o =-        ApolloSubscription <$> o .:? "id" <*> o .: "type" <*> o .:? "payload"--data RequestPayload = RequestPayload-  { payloadOperationName :: Maybe FieldName,-    payloadQuery :: Maybe Token,-    payloadVariables :: Maybe Value-  }-  deriving (Show, Generic)--instance FromJSON RequestPayload where-  parseJSON = withObject "ApolloPayload" objectParser-    where-      objectParser o =-        RequestPayload <$> o .:? "operationName" <*> o .:? "query"-          <*> o .:? "variables"--instance ToJSON a => ToJSON (ApolloSubscription a) where-  toEncoding (ApolloSubscription id' type' payload') =-    pairs $ "id" .= id' <> "type" .= type' <> "payload" .= payload'--acceptApolloRequest ::-  MonadIO m =>-  PendingConnection ->-  m Connection-acceptApolloRequest pending =-  liftIO $-    acceptRequestWith-      pending-      (acceptApolloSubProtocol (pendingRequest pending))--acceptApolloSubProtocol :: RequestHead -> AcceptRequest-acceptApolloSubProtocol reqHead =-  apolloProtocol (getRequestSubprotocols reqHead)-  where-    apolloProtocol ["graphql-subscriptions"] =-      AcceptRequest (Just "graphql-subscriptions") []-    apolloProtocol ["graphql-ws"] = AcceptRequest (Just "graphql-ws") []-    apolloProtocol _ = AcceptRequest Nothing []--toApolloResponse :: ID -> GQLResponse -> ByteString-toApolloResponse sid val =-  encode $ ApolloSubscription (Just sid) "data" (Just val)--data ApolloAction-  = SessionStop ID-  | SessionStart ID GQLRequest-  | ConnectionInit--type Validation = Either ByteString--apolloFormat :: ByteString -> Validation ApolloAction-apolloFormat = validateReq . eitherDecode-  where-    validateReq :: Either String (ApolloSubscription RequestPayload) -> Validation ApolloAction-    validateReq = either (Left . pack) validateSub-    --------------------------------------    validateSub :: ApolloSubscription RequestPayload -> Validation ApolloAction-    validateSub ApolloSubscription {apolloType = "connection_init"} =-      pure ConnectionInit-    validateSub ApolloSubscription {apolloType = "start", apolloId, apolloPayload} =-      do-        sessionId <- validateSession apolloId-        payload <- validatePayload apolloPayload-        pure $ SessionStart sessionId payload-    validateSub ApolloSubscription {apolloType = "stop", apolloId} =-      SessionStop <$> validateSession apolloId-    validateSub ApolloSubscription {apolloType} =-      Left $ "Unknown Request type \"" <> pack (unpack apolloType) <> "\"."-    ---------------------------------------------    validateSession :: Maybe ID -> Validation ID-    validateSession = maybe (Left "\"id\" was not provided") Right-    --------------------------------------    validatePayload = maybe (Left "\"payload\" was not provided") validatePayloadContent-    --------------------------------------    validatePayloadContent-      RequestPayload-        { payloadQuery,-          payloadOperationName = operationName,-          payloadVariables = variables-        } = do-        query <- maybe (Left "\"payload.query\" was not provided") Right payloadQuery-        pure $ GQLRequest {query, operationName, variables}

@@ -1,187 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE NoImplicitPrelude #-}--module Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore-  ( ID,-    Session,-    SessionID,-    ClientConnectionStore,-    ClientConnection,-    Updates (..),-    startSession,-    endSession,-    empty,-    insert,-    delete,-    publish,-    toList,-    connectionSessionIds,-  )-where--import Control.Applicative (pure)-import Control.Monad (Monad ((>>=)))-import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Foldable (traverse_)-import Data.HashMap.Lazy (HashMap, keys)-import qualified Data.HashMap.Lazy as HM-  ( adjust,-    delete,-    elems,-    empty,-    insert,-    insertWith,-    keys,-    toList,-  )-import Data.List (filter, intersect)-import Data.Morpheus.Internal.Utils-  ( Collection (..),-    KeyOf (..),-  )-import Data.Morpheus.Types.Internal.Resolving-  ( Event (..),-    SubEvent,-    eventChannels,-  )-import Data.Morpheus.Types.Internal.Subscription.Apollo-  ( toApolloResponse,-  )-import Data.Semigroup ((<>))-import Data.Text (Text)-import Data.UUID (UUID)-import Prelude-  ( (.),-    Eq (..),-    Show (..),-    curry,-    not,-    null,-    otherwise,-    snd,-  )--type ID = UUID--type SessionID = Text--type Session = (ID, SessionID)--data ClientConnection e (m :: * -> *) = ClientConnection-  { connectionId :: ID,-    connectionCallback :: ByteString -> m (),-    -- one connection can have multiple subscription session-    connectionSessions :: HashMap SessionID (SubEvent e m)-  }--connectionSessionIds :: ClientConnection e m -> [SessionID]-connectionSessionIds = HM.keys . connectionSessions--instance Show (ClientConnection e m) where-  show ClientConnection {connectionId, connectionSessions} =-    "Connection { id: "-      <> show connectionId-      <> ", sessions: "-      <> show (keys connectionSessions)-      <> " }"--publish ::-  ( Monad m,-    Eq channel-  ) =>-  Event channel content ->-  ClientConnectionStore (Event channel content) m ->-  m ()-publish event = traverse_ sendMessage . elems-  where-    sendMessage ClientConnection {connectionSessions, connectionCallback}-      | null connectionSessions = pure ()-      | otherwise = traverse_ send (filterByChannels connectionSessions)-      where-        send (sid, Event {content = subscriptionRes}) =-          subscriptionRes event >>= connectionCallback . toApolloResponse sid-        ----------------------------        filterByChannels =-          filter-            ( not-                . null-                . intersect (eventChannels event)-                . channels-                . snd-            )-            . HM.toList--newtype Updates e (m :: * -> *) = Updates-  { _runUpdate :: ClientConnectionStore e m -> ClientConnectionStore e m-  }--updateClient ::-  (ClientConnection e m -> ClientConnection e m) ->-  ID ->-  Updates e m-updateClient f cid = Updates (adjust f cid)--endSession :: Session -> Updates e m-endSession (clientId, sessionId) = updateClient endSub clientId-  where-    endSub client = client {connectionSessions = HM.delete sessionId (connectionSessions client)}--startSession :: SubEvent e m -> Session -> Updates e m-startSession subscriptions (clientId, sessionId) = updateClient startSub clientId-  where-    startSub client = client {connectionSessions = HM.insert sessionId subscriptions (connectionSessions client)}---- stores active client connections--- every registered client has ID--- when client connection is closed client(including all its subscriptions) can By removed By its ID-newtype ClientConnectionStore e (m :: * -> *) = ClientConnectionStore-  { unpackStore :: HashMap ID (ClientConnection e m)-  }-  deriving (Show)--type StoreMap e m =-  ClientConnectionStore e m ->-  ClientConnectionStore e m--mapStore ::-  ( HashMap ID (ClientConnection e m) ->-    HashMap ID (ClientConnection e m)-  ) ->-  StoreMap e m-mapStore f = ClientConnectionStore . f . unpackStore--elems :: ClientConnectionStore e m -> [ClientConnection e m]-elems = HM.elems . unpackStore--toList :: ClientConnectionStore e m -> [(UUID, ClientConnection e m)]-toList = HM.toList . unpackStore--instance KeyOf UUID (ClientConnection e m) where-  keyOf = connectionId--instance Collection (ClientConnection e m) (ClientConnectionStore e m) where-  empty = ClientConnectionStore empty-  singleton = ClientConnectionStore . singleton---- returns original store, if connection with same id already exist-insert ::-  ID ->-  (ByteString -> m ()) ->-  StoreMap e m-insert connectionId connectionCallback = mapStore (HM.insertWith (curry snd) connectionId c)-  where-    c = ClientConnection {connectionId, connectionCallback, connectionSessions = HM.empty}--adjust ::-  (ClientConnection e m -> ClientConnection e m) ->-  ID ->-  StoreMap e m-adjust f key = mapStore (HM.adjust f key)--delete ::-  ID ->-  StoreMap e m-delete key = mapStore (HM.delete key)

@@ -1,227 +0,0 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE FlexibleInstances #-}-{-# LANGUAGE GADTs #-}-{-# LANGUAGE MultiParamTypeClasses #-}-{-# LANGUAGE NamedFieldPuns #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeFamilies #-}-{-# LANGUAGE UndecidableInstances #-}--module Data.Morpheus.Types.Internal.Subscription.Stream-  ( toOutStream,-    runStreamWS,-    runStreamHTTP,-    Stream,-    Scope (..),-    Input (..),-    API (..),-    HTTP,-    WS,-  )-where--import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Foldable (traverse_)--- MORPHEUS-import Data.Morpheus.Error-  ( globalErrorMessage,-  )-import Data.Morpheus.Internal.Utils-  ( failure,-  )-import Data.Morpheus.Types.IO-  ( GQLRequest (..),-    GQLResponse (..),-  )-import Data.Morpheus.Types.Internal.AST-  ( GQLErrors,-    VALID,-    Value (..),-  )-import Data.Morpheus.Types.Internal.Resolving-  ( ResponseEvent (..),-    ResponseStream,-    Result (..),-    ResultT (..),-    runResultT,-  )-import Data.Morpheus.Types.Internal.Subscription.Apollo-  ( ApolloAction (..),-    apolloFormat,-    toApolloResponse,-  )-import Data.Morpheus.Types.Internal.Subscription.ClientConnectionStore-  ( ClientConnectionStore,-    ID,-    Session,-    Updates (..),-    endSession,-    insert,-    startSession,-  )--data API = HTTP | WS--type WS = 'WS--type HTTP = 'HTTP--data-  Input-    (api :: API)-  where-  Init :: ID -> Input WS-  Request :: GQLRequest -> Input HTTP--run :: Scope WS e m -> Updates e m -> m ()-run ScopeWS {update} (Updates changes) = update changes--data Scope (api :: API) event (m :: * -> *) where-  ScopeHTTP ::-    { httpCallback :: event -> m ()-    } ->-    Scope HTTP event m-  ScopeWS ::-    { listener :: m ByteString,-      callback :: ByteString -> m (),-      update :: (ClientConnectionStore event m -> ClientConnectionStore event m) -> m ()-    } ->-    Scope WS event m--data-  Stream-    (api :: API)-    e-    (m :: * -> *)-  where-  StreamWS ::-    { streamWS :: Scope WS e m -> m (Either ByteString [Updates e m])-    } ->-    Stream WS e m-  StreamHTTP ::-    { streamHTTP :: Scope HTTP e m -> m GQLResponse-    } ->-    Stream HTTP e m--handleResponseStream ::-  ( Monad m-  ) =>-  Session ->-  ResponseStream e m (Value VALID) ->-  Stream WS e m-handleResponseStream session (ResultT res) =-  StreamWS $ const $ unfoldR <$> res-  where-    execute Publish {} = apolloError $ globalErrorMessage "websocket can only handle subscriptions, not mutations"-    execute (Subscribe sub) = Right $ startSession sub session-    ---------------------------    unfoldR Success {events} = traverse execute events-    unfoldR Failure {errors} = apolloError errors-    ---------------------------    apolloError :: GQLErrors -> Either ByteString a-    apolloError = Left . toApolloResponse (snd session) . Errors--handleWSRequest ::-  ( Monad m,-    Functor m-  ) =>-  ( GQLRequest ->-    ResponseStream e m (Value VALID)-  ) ->-  ID ->-  ByteString ->-  Stream WS e m-handleWSRequest gqlApp clientId = handle . apolloFormat-  where-    --handle :: Applicative m => Validation ApolloAction -> Stream WS e m-    handle = either (liftWS . Left) handleAction-    ---------------------------------------------------    -- handleAction :: ApolloAction -> Stream WS e m-    handleAction ConnectionInit = liftWS $ Right []-    handleAction (SessionStart sessionId request) =-      handleResponseStream (clientId, sessionId) (gqlApp request)-    handleAction (SessionStop sessionId) =-      liftWS $-        Right [endSession (clientId, sessionId)]--liftWS ::-  Applicative m =>-  Either ByteString [Updates e m] ->-  Stream WS e m-liftWS = StreamWS . const . pure--runStreamWS ::-  (Monad m) =>-  Scope WS e m ->-  Stream WS e m ->-  m ()-runStreamWS scope@ScopeWS {callback} StreamWS {streamWS} =-  streamWS scope-    >>= either callback (traverse_ (run scope))--runStreamHTTP ::-  (Monad m) =>-  Scope HTTP e m ->-  Stream HTTP e m ->-  m GQLResponse-runStreamHTTP scope StreamHTTP {streamHTTP} =-  streamHTTP scope--toOutStream ::-  (Monad m) =>-  ( GQLRequest ->-    ResponseStream e m (Value VALID)-  ) ->-  Input api ->-  Stream api e m-toOutStream app (Init clientId) =-  StreamWS handle-  where-    handle ws@ScopeWS {listener, callback} = do-      let runS (StreamWS x) = x ws-      bla <- listener >>= runS . handleWSRequest app clientId-      pure $ (Updates (insert clientId callback) :) <$> bla-toOutStream app (Request req) = StreamHTTP $ handleResponseHTTP (app req)--handleResponseHTTP ::-  ( Monad m-  ) =>-  ResponseStream e m (Value VALID) ->-  Scope HTTP e m ->-  m GQLResponse-handleResponseHTTP-  res-  ScopeHTTP {httpCallback} = do-    x <- runResultT (handleRes res execute)-    case x of-      Success r _ events -> do-        traverse_ httpCallback events-        pure $ Data r-      Failure err -> pure (Errors err)-    where-      execute (Publish event) = pure event-      execute Subscribe {} = failure (globalErrorMessage "http server can't handle subscription")--handleRes ::-  (Monad m) =>-  ResponseStream e m a ->-  (ResponseEvent e m -> ResultT e' m e') ->-  ResultT e' m a-handleRes res execute = ResultT $ runResultT res >>= runResultT . unfoldRes execute--unfoldRes ::-  (Monad m) =>-  (e -> ResultT e' m e') ->-  Result e a ->-  ResultT e' m a-unfoldRes execute Success {events, result, warnings} = do-  events' <- traverse execute events-  ResultT $ pure $-    Success-      { result,-        warnings,-        events = events'-      }-unfoldRes _ Failure {errors} = ResultT $ pure $ Failure {errors}

@@ -23,9 +23,9 @@     importGQLDocumentWithNamespace,   ) import Data.Morpheus.Kind (SCALAR)+import Data.Morpheus.Subscriptions (Event) import Data.Morpheus.Types-  ( Event,-    GQLRequest,+  ( GQLRequest,     GQLResponse,     GQLScalar (..),     GQLType (..),

@@ -1,12 +1,8 @@ {   "errors": [     {-      "message": "Cannot spread fragment \"A\" within itself via \"A\", \"A\", \"C\".",-      "locations": [-        { "line": 17, "column": 3 },-        { "line": 7, "column": 10 },-        { "line": 9, "column": 3 }-      ]+      "message": "Fragment \"A\" is never used.",+      "locations": [{ "line": 7, "column": 10 }]     },     {       "message": "Cannot spread fragment \"C\" within itself via \"C\", \"B\", \"C\", \"A\".",@@ -26,16 +22,20 @@       ]     },     {-      "message": "Fragment \"A\" is never used.",-      "locations": [{ "line": 7, "column": 10 }]-    },-    {       "message": "Fragment \"B\" is never used.",       "locations": [{ "line": 12, "column": 10 }]     },     {       "message": "Fragment \"C\" is never used.",       "locations": [{ "line": 16, "column": 10 }]+    },+    {+      "message": "Cannot spread fragment \"A\" within itself via \"A\", \"A\", \"C\".",+      "locations": [+        { "line": 17, "column": 3 },+        { "line": 7, "column": 10 },+        { "line": 9, "column": 3 }+      ]     },     {       "message": "Fragment \"D\" is never used.",

@@ -1,12 +1,12 @@ {   "errors": [     {-      "message": "Field \"street\" argument \"argInputObject\" is required but not provided.",-      "locations": [{ "line": 54, "column": 3 }]-    },-    {       "message": "Cannot query field \"myUnion\" on type \"User\".",       "locations": [{ "line": 43, "column": 3 }]+    },+    {+      "message": "Field \"street\" argument \"argInputObject\" is required but not provided.",+      "locations": [{ "line": 54, "column": 3 }]     }   ] }

@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "offset=22:\nunexpected '@'\nexpecting '!', ')', '=', Ignored, IgnoredTokens, VariableDefinition, or white space\n",+      "message": "offset=22:\nunexpected '@'\nexpecting !, ')', =, Ignored, IgnoredTokens, VariableDefinition, or white space\n",       "locations": [{ "line": 1, "column": 23 }]     }   ]

@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "offset=20:\nunexpected '@'\nexpecting '!', ']', '_', Ignored, IgnoredTokens, digit, letter, or white space\n",+      "message": "offset=20:\nunexpected '@'\nexpecting !, ']', '_', Ignored, IgnoredTokens, digit, letter, or white space\n",       "locations": [{ "line": 1, "column": 21 }]     }   ]

@@ -18,7 +18,7 @@                   "ofType": null                 }               },-              "defaultValue": "{inputField2: \"value from argument inputCompound\", inputField3: [{fieldWithDefault: \"value2 from inputField3\", simpleField: EnumA}, {fieldWithDefault: \"value from fieldWithDefault\", simpleField: EnumA}], inputField4: [{fieldWithDefault: \"value from fieldWithDefault\", simpleField: EnumB}]}"+              "defaultValue": "{ inputField2: \"value from argument inputCompound\", inputField3: [{ fieldWithDefault: \"value2 from inputField3\", simpleField: EnumA }, { fieldWithDefault: \"value from fieldWithDefault\", simpleField: EnumA }], inputField4: [{ fieldWithDefault: \"value from fieldWithDefault\", simpleField: EnumB }] }"             },             {               "name": "input",

@@ -33,7 +33,7 @@               }             }           },-          "defaultValue": "[{fieldWithDefault: \"value2 from inputField3\", simpleField: EnumA}, {fieldWithDefault: \"value from fieldWithDefault\", simpleField: EnumA}]"+          "defaultValue": "[{ fieldWithDefault: \"value2 from inputField3\", simpleField: EnumA }, { fieldWithDefault: \"value from fieldWithDefault\", simpleField: EnumA }]"         },         {           "name": "inputField4",@@ -50,7 +50,7 @@               }             }           },-          "defaultValue": "[{fieldWithDefault: \"value from fieldWithDefault\", simpleField: EnumB}]"+          "defaultValue": "[{ fieldWithDefault: \"value from fieldWithDefault\", simpleField: EnumB }]"         }       ],       "interfaces": null,

@@ -1,7 +1,7 @@ {   "errors": [     {-      "message": "Variable \"$v1\" got invalid value. Expected type \"[[[Int!]!]]!\" found {id: \"12\"}.",+      "message": "Variable \"$v1\" got invalid value. Expected type \"[[[Int!]!]]!\" found { id: \"12\" }.",       "locations": [         {           "line": 1,

@@ -1,9 +1,12 @@ {   "errors": [     {-      "message": "Schema Validation Error, Name collision: \"A\" is used for different dataTypes in two separate modules",-      "locations": [-      ]+      "message": "There can Be only One TypeDefinition Named \"A\".",+      "locations": []+    },+    {+      "message": "There can Be only One TypeDefinition Named \"A\".",+      "locations": []     }   ] }

@@ -2,6 +2,7 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Feature.WrappedTypeName.API   ( api,@@ -9,9 +10,9 @@ where  import Data.Morpheus (interpreter)+import Data.Morpheus.Subscriptions (Event) import Data.Morpheus.Types-  ( Event,-    GQLRequest,+  ( GQLRequest,     GQLResponse,     GQLType (..),     RootResolver (..),@@ -19,8 +20,7 @@     constRes,     subscribe,   )-import Data.Text (Text)-import GHC.Generics (Generic)+import Relude  data Wrapped a b = Wrapped   { fieldA :: a,

@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Lib   ( getGQLBody,@@ -8,12 +9,11 @@   ) where -import Control.Applicative ((<|>)) import Data.Aeson (FromJSON, Value (..), decode) import qualified Data.ByteString.Lazy as L (readFile) import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Maybe (fromMaybe)-import Data.Text (Text, unpack)+import Data.Text (unpack)+import Relude hiding (ByteString)  path :: Text -> String path name = "test/" ++ unpack name

@@ -1,3 +1,4 @@+{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DuplicateRecordFields #-}@@ -9,6 +10,7 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Subscription.API   ( app,@@ -20,18 +22,25 @@  import Data.Morpheus (App, deriveApp) import Data.Morpheus.Document (importGQLDocument)-import Data.Morpheus.Types+import Data.Morpheus.Subscriptions   ( Event (..),-    RootResolver (..),+  )+import Data.Morpheus.Types+  ( RootResolver (..),     subscribe,   )-import Data.Text (Text)+import Relude import Subscription.Utils (SubM)  data Channel   = DEITY   | HUMAN-  deriving (Show, Eq)+  deriving+    ( Show,+      Eq,+      Generic,+      Hashable+    )  importGQLDocument "test/Subscription/schema.gql" 

@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Subscription.Case.ApolloRequest   ( testApolloRequest,@@ -9,11 +10,11 @@ where  import Data.ByteString.Lazy.Char8 (ByteString)-import Data.Function ((&)) import Data.Morpheus (App)-import Data.Morpheus.Types+import Data.Morpheus.Subscriptions   ( Event,   )+import Relude hiding (ByteString) import Subscription.Utils   ( SimulationState (..),     SubM,@@ -36,7 +37,7 @@ type WSApp ch a = App (Event ch a) (SubM (Event ch a))  testUnknownType ::-  (Eq ch) =>+  (Eq ch, Show ch, Hashable ch) =>   App (Event ch a) (SubM (Event ch a)) ->   IO TestTree testUnknownType =@@ -55,7 +56,7 @@         ]  testConnectionInit ::-  (Eq ch) =>+  (Eq ch, Show ch, Hashable ch) =>   App (Event ch a) (SubM (Event ch a)) ->   IO TestTree testConnectionInit = testSimulation test [apolloInit]@@ -74,7 +75,10 @@ startSub :: ByteString -> ByteString startSub = apolloStart "subscription MySubscription { newDeity { name }}" -testSubscriptionStart :: (Eq ch) => WSApp ch a -> IO TestTree+testSubscriptionStart ::+  (Eq ch, Show ch, Hashable ch) =>+  WSApp ch a ->+  IO TestTree testSubscriptionStart =   testSimulation     test@@ -96,7 +100,10 @@             store         ] -testSubscriptionStop :: (Eq ch) => WSApp ch a -> IO TestTree+testSubscriptionStop ::+  (Eq ch, Show ch, Hashable ch) =>+  WSApp ch a ->+  IO TestTree testSubscriptionStop =   testSimulation     test@@ -120,7 +127,7 @@         ]  testApolloRequest ::-  (Eq ch) =>+  (Eq ch, Show ch, Hashable ch) =>   App (Event ch a) (SubM (Event ch a)) ->   IO TestTree testApolloRequest app =

@@ -1,6 +1,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Subscription.Case.Publishing   ( testPublishing,@@ -10,12 +11,12 @@ import Data.ByteString.Lazy.Char8   ( ByteString,   )-import Data.Morpheus.Types+import Data.Morpheus.Subscriptions   ( Event (..),-    Input,   )-import Data.Morpheus.Types.Internal.Subscription-  ( WS,+import Data.Morpheus.Subscriptions.Internal+  ( Input,+    SUB,     connect,     empty,   )@@ -41,6 +42,7 @@   ( TestTree,     testGroup,   )+import Prelude  startNewDeity :: ByteString -> ByteString startNewDeity = apolloStart "subscription MySubscription { newDeity { name , age }}"@@ -48,7 +50,7 @@ startNewHuman :: ByteString -> ByteString startNewHuman = apolloStart "subscription MySubscription { newHuman { name , age }}" -simulateSubscriptions :: IO (Input WS, SimulationState EVENT)+simulateSubscriptions :: IO (Input SUB, SimulationState EVENT) simulateSubscriptions = do   input <- connect   state <-

@@ -23,33 +23,21 @@   ) where -import Control.Monad ((>>=))-import Control.Monad.State.Lazy-  ( StateT,-    runStateT,-    state,-  ) import Data.ByteString.Lazy.Char8   ( ByteString,   )-import Data.List-  ( sort,-  )-import Data.Maybe-  ( isJust,-  )+import Data.List (lookup) import Data.Morpheus   ( App,   )-import Data.Morpheus.Types+import Data.Morpheus.Subscriptions   ( Event,   )-import Data.Morpheus.Types.Internal.Subscription-  ( ClientConnectionStore,+import Data.Morpheus.Subscriptions.Internal+  ( ApiContext (..),+    ClientConnectionStore,     Input (..),-    Scope (..),-    SessionID,-    WS,+    SUB,     connect,     connectionSessionIds,     empty,@@ -58,8 +46,10 @@     streamApp,     toList,   )-import Data.Semigroup-  ( (<>),+import Relude hiding+  ( ByteString,+    empty,+    toList,   ) import Test.Tasty   ( TestTree,@@ -69,21 +59,6 @@     assertFailure,     testCase,   )-import Prelude-  ( ($),-    (.),-    (<$>),-    Eq (..),-    IO,-    Maybe (..),-    Show (..),-    length,-    lookup,-    null,-    otherwise,-    pure,-    snd,-  )  data SimulationState e = SimulationState   { inputs :: [ByteString],@@ -98,45 +73,48 @@ addOutput :: ByteString -> SimulationState e -> ((), SimulationState e) addOutput x (SimulationState i xs st) = ((), SimulationState i (xs <> [x]) st) -updateStore :: (Store e -> Store e) -> SimulationState e -> ((), SimulationState e)-updateStore up (SimulationState i o st) = ((), SimulationState i o (up st))+mockUpdateStore :: (Store e -> Store e) -> SimulationState e -> ((), SimulationState e)+mockUpdateStore up (SimulationState i o st) = ((), SimulationState i o (up st))  readInput :: SimulationState e -> (ByteString, SimulationState e) readInput (SimulationState (i : ins) o s) = (i, SimulationState ins o s) readInput (SimulationState [] o s) = ("<Error>", SimulationState [] o s)  wsApp ::-  App e (SubM e) ->-  Input WS ->-  SubM e ()+  (Eq ch, Hashable ch) =>+  App (Event ch e) (SubM (Event ch e)) ->+  Input SUB ->+  SubM (Event ch e) () wsApp app =   runStreamWS-    ScopeWS-      { update = state . updateStore,+    SubContext+      { updateStore = state . mockUpdateStore,         listener = state readInput,         callback = state . addOutput       }     . streamApp app  simulatePublish ::-  Eq ch =>+  (Eq ch, Show ch, Hashable ch) =>   Event ch con ->   SimulationState (Event ch con) ->   IO (SimulationState (Event ch con)) simulatePublish event s = snd <$> runStateT (publish event (store s)) s  simulate ::-  App e (SubM e) ->-  Input WS ->-  SimulationState e ->-  IO (SimulationState e)+  (Eq ch, Hashable ch) =>+  App (Event ch con) (SubM (Event ch con)) ->+  Input SUB ->+  SimulationState (Event ch con) ->+  IO (SimulationState (Event ch con)) simulate _ _ s@SimulationState {inputs = []} = pure s simulate api input s = runStateT (wsApp api input) s >>= simulate api input . snd  testSimulation ::-  (Input WS -> SimulationState e -> TestTree) ->+  (Eq ch, Hashable ch) =>+  (Input SUB -> SimulationState (Event ch con) -> TestTree) ->   [ByteString] ->-  App e (SubM e) ->+  App (Event ch con) (SubM (Event ch con)) ->   IO TestTree testSimulation test simInputs api = do   input <- connect@@ -163,7 +141,7 @@       "input stream should be consumed"       [] -storeIsEmpty :: Store e -> TestTree+storeIsEmpty :: (Show ch) => Store (Event ch con) -> TestTree storeIsEmpty cStore   | null (toList cStore) =     testCase "connectionStore: is empty" $ pure ()@@ -174,7 +152,7 @@         <> show           cStore -storedSingle :: Store e -> TestTree+storedSingle :: (Show ch) => Store (Event ch con) -> TestTree storedSingle cStore   | length (toList cStore) == 1 =     testCase "stored single connection" $ pure ()@@ -185,8 +163,8 @@         <> show           cStore -stored :: Input WS -> Store e -> TestTree-stored (Init uuid) cStore+stored :: (Show ch) => Input SUB -> Store (Event ch con) -> TestTree+stored (InitConnection uuid) cStore   | isJust (lookup uuid (toList cStore)) =     testCase "stored connection" $ pure ()   | otherwise =@@ -197,12 +175,13 @@           cStore  storeSubscriptions ::-  Input WS ->-  [SessionID] ->-  Store e ->+  (Show ch) =>+  Input SUB ->+  [Text] ->+  Store (Event ch con) ->   TestTree storeSubscriptions-  (Init uuid)+  (InitConnection uuid)   sids   cStore =     checkSession (lookup uuid (toList cStore))

@@ -1,6 +1,7 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE NoImplicitPrelude #-}  module Types   ( Case (..),@@ -10,10 +11,11 @@ where  import Data.Aeson (FromJSON)-import Data.Text (Text, unpack)+import Data.Text (unpack) import qualified Data.Text as T (concat) import GHC.Generics import Lib (getCases)+import Relude import Test.Tasty (TestTree, testGroup)  type Name = Text