mu-rpc 0.3.0.0 → 0.4.0.0

raw patch · 5 files changed

+463/−125 lines, 5 filesdep +aesondep +http-typesdep +waidep ~conduitdep ~mtldep ~mu-schemaPVP ok

version bump matches the API change (PVP)

Dependencies added: aeson, http-types, wai

Dependency ranges changed: conduit, mtl, mu-schema, sop-core, template-haskell, text

API changes (from Hackage documentation)

Files

• mu-rpc.cabal +12/−8
• src/Mu/Rpc.hs +170/−34
• src/Mu/Rpc/Annotations.hs +111/−0
• src/Mu/Rpc/Examples.hs +28/−17
• src/Mu/Server.hs +142/−66

@@ -1,5 +1,5 @@ name:               mu-rpc-version:            0.3.0.0+version:            0.4.0.0 synopsis:           Protocol-independent declaration of services and servers. description:   Protocol-independent declaration of services and servers for mu-haskell.@@ -23,17 +23,21 @@ library   exposed-modules:     Mu.Rpc+    Mu.Rpc.Annotations     Mu.Rpc.Examples     Mu.Server    build-depends:-      base              >=4.12  && <5-    , conduit-    , mtl-    , mu-schema         >=0.3.0-    , sop-core-    , template-haskell-    , text+      aeson+    , base              >=4.12  && <5+    , conduit           >=1.3.2 && <1.4+    , http-types        >=0.12  && <0.13+    , mtl               >=2.2   && <2.3+    , mu-schema         ==0.3.*+    , sop-core          >=0.5   && <0.6+    , template-haskell  >=2.14  && <2.16+    , text              >=1.2   && <1.3+    , wai               >=3.2   && <4    hs-source-dirs:   src   default-language: Haskell2010

@@ -1,8 +1,13 @@ {-# language ConstraintKinds           #-} {-# language DataKinds                 #-} {-# language ExistentialQuantification #-}+{-# language FlexibleInstances         #-} {-# language GADTs                     #-}+{-# language MultiParamTypeClasses     #-}+{-# language OverloadedStrings         #-} {-# language PolyKinds                 #-}+{-# language ScopedTypeVariables       #-}+{-# language TypeApplications          #-} {-# language TypeFamilies              #-} {-# language TypeOperators             #-} {-# language UndecidableInstances      #-}@@ -16,46 +21,47 @@ module Mu.Rpc (   Package', Package(..) , Service', Service(..), Object-, ServiceAnnotation, Method', Method(..), ObjectField+, Method', Method(..), ObjectField , LookupService, LookupMethod , TypeRef(..), Argument', Argument(..), Return(..)+, TyInfo(..), RpcInfo(..), ReflectRpcInfo(..) ) where  import           Data.Kind+import           Data.Text                 (Text)+import qualified Data.Text                 as T import           GHC.TypeLits-import qualified Language.Haskell.TH as TH+import qualified Language.Haskell.TH       as TH+import           Network.HTTP.Types.Header+import           Type.Reflection  import           Mu.Schema import           Mu.Schema.Registry  -- | Packages whose names are given by type-level strings.-type Package' = Package Symbol Symbol Symbol+type Package' = Package Symbol Symbol Symbol (TypeRef Symbol) -- | Services whose names are given by type-level strings.-type Service' = Service Symbol Symbol Symbol+type Service' = Service Symbol Symbol Symbol (TypeRef Symbol) -- | Methods whose names are given by type-level strings.-type Method' = Method Symbol Symbol Symbol+type Method' = Method Symbol Symbol Symbol (TypeRef Symbol) -- | Arguments whose names are given by type-level strings.-type Argument' = Argument Symbol Symbol--- | Annotations for services. At this moment, such---   annotations can be of any type.-type ServiceAnnotation = Type+type Argument' = Argument Symbol Symbol (TypeRef Symbol)  -- | A package is a set of services.-data Package serviceName methodName argName+data Package serviceName methodName argName tyRef   = Package (Maybe serviceName)-            [Service serviceName methodName argName]+            [Service serviceName methodName argName tyRef]  -- | A service is a set of methods.-data Service serviceName methodName argName+data Service serviceName methodName argName tyRef   = Service serviceName-            [ServiceAnnotation]-            [Method serviceName methodName argName]+            [Method serviceName methodName argName tyRef]  -- | A method is defined by its name, arguments, and return type.-data Method serviceName methodName argName-  = Method methodName [ServiceAnnotation]-           [Argument serviceName argName]-           (Return serviceName)+data Method serviceName methodName argName tyRef+  = Method methodName+           [Argument serviceName argName tyRef]+           (Return serviceName tyRef)  -- Synonyms for GraphQL -- | An object is a set of fields, in GraphQL lingo.@@ -66,16 +72,18 @@ type ObjectField = 'Method  -- | Look up a service in a package definition using its name.-type family LookupService (ss :: [Service snm mnm anm]) (s :: snm) :: Service snm mnm anm where+type family LookupService (ss :: [Service snm mnm anm tr]) (s :: snm)+              :: Service snm mnm anm tr where   LookupService '[] s = TypeError ('Text "could not find method " ':<>: 'ShowType s)-  LookupService ('Service s anns ms ': ss) s = 'Service s anns ms-  LookupService (other              ': ss) s = LookupService ss s+  LookupService ('Service s ms ': ss) s = 'Service s ms+  LookupService (other         ': ss) s = LookupService ss s  -- | Look up a method in a service definition using its name.-type family LookupMethod (s :: [Method snm mnm anm]) (m :: mnm) :: Method snm mnm anm where+type family LookupMethod (s :: [Method snm mnm anm tr]) (m :: mnm)+              :: Method snm mnm anm tr where   LookupMethod '[] m = TypeError ('Text "could not find method " ':<>: 'ShowType m)-  LookupMethod ('Method m anns args r ': ms) m = 'Method m anns args r-  LookupMethod (other                 ': ms) m = LookupMethod ms m+  LookupMethod ('Method m args r ': ms) m = 'Method m args r+  LookupMethod (other            ': ms) m = LookupMethod ms m  -- | Defines a reference to a type, either primitive or coming from the schema. --   'TypeRef's are used to define arguments and result types.@@ -96,23 +104,151 @@   -- | Represents a possibly-missing value.   OptionalRef  :: TypeRef serviceName -> TypeRef serviceName +instance Show (TypeRef s) where+  show _ = "ty"+ -- | Defines the way in which arguments are handled.-data Argument serviceName argName where+data Argument serviceName argName tyRef where   -- | Use a single value.-  ArgSingle :: Maybe argName -> [ServiceAnnotation]-            -> TypeRef serviceName -> Argument serviceName argName+  ArgSingle :: Maybe argName+            -> tyRef+            -> Argument serviceName argName tyRef   -- | Consume a stream of values.-  ArgStream :: Maybe argName -> [ServiceAnnotation]-            -> TypeRef serviceName -> Argument serviceName argName+  ArgStream :: Maybe argName+            -> tyRef+            -> Argument serviceName argName tyRef  -- | Defines the different possibilities for returning --   information from a method.-data Return serviceName where+data Return serviceName tyRef where   -- | Fire and forget.-  RetNothing :: Return serviceName+  RetNothing :: Return serviceName tyRef   -- | Return a single value.-  RetSingle  :: TypeRef serviceName -> Return serviceName+  RetSingle  :: tyRef -> Return serviceName tyRef   -- | Return a stream of values.-  RetStream  :: TypeRef serviceName -> Return serviceName+  RetStream  :: tyRef -> Return serviceName tyRef   -- | Return a value or an error.-  RetThrows  :: TypeRef serviceName -> TypeRef serviceName -> Return serviceName+  RetThrows  :: tyRef -> tyRef -> Return serviceName tyRef++-- | Reflection++data RpcInfo i+  = NoRpcInfo+  | RpcInfo { packageInfo :: Package Text Text Text TyInfo+            , serviceInfo :: Service Text Text Text TyInfo+            , methodInfo  :: Method  Text Text Text TyInfo+            , headers     :: RequestHeaders+            , extraInfo   :: i+            }++data TyInfo+  = TyList   TyInfo+  | TyOption TyInfo+  | TyTy     Text+  deriving (Show, Eq)++instance Show (RpcInfo i) where+  show NoRpcInfo+    = "<no info>"+  show (RpcInfo (Package Nothing _) (Service s _) (Method m _ _) _ _)+    = T.unpack (s <> ":" <> m)+  show (RpcInfo (Package (Just p) _) (Service s _) (Method m _ _) _ _)+    = T.unpack (p <> ":" <> s <> ":" <> m)++class ReflectRpcInfo (p :: Package') (s :: Service') (m :: Method') where+  reflectRpcInfo :: Proxy p -> Proxy s -> Proxy m -> RequestHeaders -> i -> RpcInfo i+class ReflectService (s :: Service') where+  reflectService :: Proxy s -> Service Text Text Text TyInfo+class ReflectMethod (m :: Method') where+  reflectMethod  :: Proxy m -> Method Text Text Text TyInfo+class ReflectArg (arg :: Argument') where+  reflectArg     :: Proxy arg -> Argument Text Text TyInfo+class ReflectReturn (r :: Return Symbol (TypeRef Symbol)) where+  reflectReturn  :: Proxy r -> Return Text TyInfo+class ReflectTyRef (r :: TypeRef Symbol) where+  reflectTyRef   :: Proxy r -> TyInfo++class KnownMaySymbol (m :: Maybe Symbol) where+  maySymbolVal :: Proxy m -> Maybe Text+instance KnownMaySymbol 'Nothing where+  maySymbolVal _ = Nothing+instance (KnownSymbol s) => KnownMaySymbol ('Just s) where+  maySymbolVal _ = Just $ T.pack $ symbolVal (Proxy @s)++class ReflectServices (ss :: [Service']) where+  reflectServices :: Proxy ss -> [Service Text Text Text TyInfo]+instance ReflectServices '[] where+  reflectServices _ = []+instance (ReflectService s, ReflectServices ss)+         => ReflectServices (s ': ss) where+  reflectServices _ = reflectService (Proxy @s) : reflectServices (Proxy @ss)++class ReflectMethods (ms :: [Method']) where+  reflectMethods :: Proxy ms -> [Method Text Text Text TyInfo]+instance ReflectMethods '[] where+  reflectMethods _ = []+instance (ReflectMethod m, ReflectMethods ms)+         => ReflectMethods (m ': ms) where+  reflectMethods _ = reflectMethod (Proxy @m) : reflectMethods (Proxy @ms)++class ReflectArgs (ms :: [Argument']) where+  reflectArgs :: Proxy ms -> [Argument Text Text TyInfo]+instance ReflectArgs '[] where+  reflectArgs _ = []+instance (ReflectArg m, ReflectArgs ms)+         => ReflectArgs (m ': ms) where+  reflectArgs _ = reflectArg (Proxy @m) : reflectArgs (Proxy @ms)++instance (KnownMaySymbol pname, ReflectServices ss, ReflectService s, ReflectMethod m)+         => ReflectRpcInfo ('Package pname ss) s m where+  reflectRpcInfo _ ps pm req extra+    = RpcInfo (Package (maySymbolVal (Proxy @pname))+                       (reflectServices (Proxy @ss)))+              (reflectService ps) (reflectMethod pm) req extra++instance (KnownSymbol sname, ReflectMethods ms)+         => ReflectService ('Service sname ms) where+  reflectService _+    = Service (T.pack $ symbolVal (Proxy @sname))+              (reflectMethods (Proxy @ms))++instance (KnownSymbol mname, ReflectArgs args, ReflectReturn r)+         => ReflectMethod ('Method mname args r) where+  reflectMethod _+    = Method (T.pack $ symbolVal (Proxy @mname))+             (reflectArgs (Proxy @args)) (reflectReturn (Proxy @r))++instance (KnownMaySymbol aname, ReflectTyRef t)+         => ReflectArg ('ArgSingle aname t) where+  reflectArg _+    = ArgSingle (maySymbolVal (Proxy @aname)) (reflectTyRef (Proxy @t))+instance (KnownMaySymbol aname, ReflectTyRef t)+         => ReflectArg ('ArgStream aname t) where+  reflectArg _+    = ArgStream (maySymbolVal (Proxy @aname)) (reflectTyRef (Proxy @t))++instance ReflectReturn 'RetNothing where+  reflectReturn _ = RetNothing+instance (ReflectTyRef t)+         => ReflectReturn ('RetSingle t) where+  reflectReturn _ = RetSingle (reflectTyRef (Proxy @t))+instance (ReflectTyRef t)+         => ReflectReturn ('RetStream t) where+  reflectReturn _ = RetStream (reflectTyRef (Proxy @t))+instance (ReflectTyRef e, ReflectTyRef t)+         => ReflectReturn ('RetThrows e t) where+  reflectReturn _ = RetThrows (reflectTyRef (Proxy @e))+                              (reflectTyRef (Proxy @t))++instance ReflectTyRef t => ReflectTyRef ('ListRef t) where+  reflectTyRef _ = TyList (reflectTyRef (Proxy @t))+instance ReflectTyRef t => ReflectTyRef ('OptionalRef t) where+  reflectTyRef _ = TyOption (reflectTyRef (Proxy @t))+instance Typeable t => ReflectTyRef ('PrimitiveRef t) where+  reflectTyRef _ = TyTy (T.pack $ show $ typeRep @t)+instance KnownSymbol s => ReflectTyRef ('ObjectRef s) where+  reflectTyRef _ = TyTy (T.pack $ symbolVal $ Proxy @s)+instance KnownSymbol s => ReflectTyRef ('SchemaRef sch s) where+  reflectTyRef _ = TyTy (T.pack $ symbolVal $ Proxy @s)+instance Typeable t => ReflectTyRef ('RegistryRef r t n) where+  reflectTyRef _ = TyTy (T.pack $ show $ typeRep @t)

@@ -0,0 +1,111 @@+{-# language DataKinds            #-}+{-# language GADTs                #-}+{-# language PolyKinds            #-}+{-# language TypeFamilies         #-}+{-# language TypeOperators        #-}+{-# language UndecidableInstances #-}+{-|+Description : Protocol-defined annotations.++Libraries can define custom annotations to+indicate additional information not found+in the 'Package' itself. For example, GraphQL+has optional default values for arguments.+-}+module Mu.Rpc.Annotations+( RpcAnnotation (..)+, AnnotatedPackage+, GetPackageAnnotation+, GetPackageAnnotationMay+, GetServiceAnnotation+, GetServiceAnnotationMay+, GetMethodAnnotation+, GetMethodAnnotationMay+, GetArgAnnotation+, GetArgAnnotationMay+)+where++import           GHC.TypeLits++import           Mu.Rpc++-- | Annotations proper.+data RpcAnnotation domain serviceName methodName argName where+  -- | Annotation over the whole package.+  AnnPackage :: domain+             -> RpcAnnotation domain serviceName methodName argName+  -- | Annotation over a service.+  AnnService :: serviceName -> domain+             -> RpcAnnotation domain serviceName methodName argName+  -- | Annotation over a method.+  AnnMethod  :: serviceName -> methodName -> domain+             -> RpcAnnotation domain serviceName methodName argName+  -- | Annotation over an argument.+  AnnArg     :: serviceName -> methodName -> argName -> domain+             -> RpcAnnotation domain serviceName methodName argName++-- |  This type family links each schema to+--    its corresponding annotations from one domain.+type family AnnotatedPackage domain (sch :: Package serviceName methodName argName tyRef) ::+    [RpcAnnotation domain serviceName methodName argName]++-- | Find the annotation over the package in the given set.+--   If the annotation cannot be found, raise a 'TypeError'.+type family GetPackageAnnotation (anns :: [RpcAnnotation domain s m a]) :: domain where+  GetPackageAnnotation '[]+    = TypeError ('Text "cannot find package annotation")+  GetPackageAnnotation ('AnnPackage d ': rs) = d+  GetPackageAnnotation (r ': rs) = GetPackageAnnotation rs++-- | Find the annotation over the package in the given set.+--   If the annotation cannot be found, return Nothing+type family GetPackageAnnotationMay (anns :: [RpcAnnotation domain s m a]) :: Maybe domain where+  GetPackageAnnotationMay '[] = 'Nothing+  GetPackageAnnotationMay ('AnnPackage d ': rs) = 'Just d+  GetPackageAnnotationMay (r ': rs) = GetPackageAnnotationMay rs++-- | Find the annotation over the given service in the given set.+--   If the annotation cannot be found, raise a 'TypeError'.+type family GetServiceAnnotation (anns :: [RpcAnnotation domain s m a]) (snm :: s) :: domain where+  GetServiceAnnotation '[] snm+    = TypeError ('Text "cannot find service annotation for " ':<>: 'ShowType snm)+  GetServiceAnnotation ('AnnService snm d ': rs) snm = d+  GetServiceAnnotation (r ': rs) snm = GetServiceAnnotation rs snm++-- | Find the annotation over the given service in the given set.+--   If the annotation cannot be found, return Nothing+type family GetServiceAnnotationMay (anns :: [RpcAnnotation domain s m a]) (snm :: s) :: Maybe domain where+  GetServiceAnnotationMay '[] snm = 'Nothing+  GetServiceAnnotationMay ('AnnService snm d ': rs) snm = 'Just d+  GetServiceAnnotationMay (r ': rs) snm = GetServiceAnnotationMay rs snm++-- | Find the annotation over the given method in the given service.+--   If the annotation cannot be found, raise a 'TypeError'.+type family GetMethodAnnotation (anns :: [RpcAnnotation domain s m a]) (snm :: s) (mnm :: m) :: domain where+  GetMethodAnnotation '[] snm mnm+    = TypeError ('Text "cannot find method annotation for " ':<>: 'ShowType snm ':<>: 'Text "/" ':<>: 'ShowType mnm)+  GetMethodAnnotation ('AnnMethod snm mnm d ': rs) snm mnm = d+  GetMethodAnnotation (r ': rs) snm mnm = GetMethodAnnotation rs snm mnm++-- | Find the annotation over the given method in the given service.+--   If the annotation cannot be found, return Nothing+type family GetMethodAnnotationMay (anns :: [RpcAnnotation domain s m a]) (snm :: s) (mnm :: m) :: Maybe domain where+  GetMethodAnnotationMay '[] snm mnm = 'Nothing+  GetMethodAnnotationMay ('AnnMethod snm mnm d ': rs) snm mnm = 'Just d+  GetMethodAnnotationMay (r ': rs) snm mnm = GetMethodAnnotationMay rs snm mnm++-- | Find the annotation over the given argument in the given method in the given service.+--   If the annotation cannot be found, raise a 'TypeError'.+type family GetArgAnnotation (anns :: [RpcAnnotation domain s m a]) (snm :: s) (mnm :: m) (anm :: a) :: domain where+  GetArgAnnotation '[] snm mnm anm+    = TypeError ('Text "cannot find argument annotation for " ':<>: 'ShowType snm ':<>: 'Text "/" ':<>: 'ShowType mnm ':<>: 'Text "/" ':<>: 'ShowType anm)+  GetArgAnnotation ('AnnArg snm mnm anm d ': rs) snm mnm anm = d+  GetArgAnnotation (r ': rs) snm mnm anm = GetArgAnnotation rs snm mnm anm++-- | Find the annotation over the given argument in the given method in the given service.+--   If the annotation cannot be found, return Nothing+type family GetArgAnnotationMay (anns :: [RpcAnnotation domain s m a]) (snm :: s) (mnm :: m) (anm :: a) :: Maybe domain where+  GetArgAnnotationMay '[] snm mnm anm = 'Nothing+  GetArgAnnotationMay ('AnnArg snm mnm anm d ': rs) snm mnm anm = 'Just d+  GetArgAnnotationMay (r ': rs) snm mnm anm = GetArgAnnotationMay rs snm mnm anm

@@ -1,6 +1,7 @@ {-# language DataKinds             #-} {-# language DeriveAnyClass        #-} {-# language DeriveGeneric         #-}+{-# language DerivingVia           #-} {-# language FlexibleContexts      #-} {-# language FlexibleInstances     #-} {-# language GADTs                 #-}@@ -20,11 +21,14 @@ -} module Mu.Rpc.Examples where +import qualified Data.Aeson as J import           Data.Conduit import           Data.Conduit.Combinators as C import qualified Data.Text                as T import           GHC.Generics+import           GHC.TypeLits +import           Mu.Adapter.Json () import           Mu.Rpc import           Mu.Schema import           Mu.Server@@ -43,34 +47,40 @@  type QuickStartService   = 'Package ('Just "helloworld")-      '[ 'Service "Greeter" '[]-        '[ 'Method "SayHello" '[]-          '[ 'ArgSingle 'Nothing '[] ('SchemaRef QuickstartSchema "HelloRequest") ]+      '[ 'Service "Greeter"+        '[ 'Method "SayHello"+          '[ 'ArgSingle ('Nothing @Symbol) ('SchemaRef QuickstartSchema "HelloRequest") ]             ('RetSingle ('SchemaRef QuickstartSchema "HelloResponse"))-        , 'Method "SayHi" '[]-          '[ 'ArgSingle 'Nothing '[] ('SchemaRef QuickstartSchema "HiRequest")]+        , 'Method "SayHi"+          '[ 'ArgSingle ('Nothing @Symbol) ('SchemaRef QuickstartSchema "HiRequest")]             ('RetStream ('SchemaRef QuickstartSchema "HelloResponse"))-        , 'Method "SayManyHellos" '[]-          '[ 'ArgStream 'Nothing '[] ('SchemaRef QuickstartSchema "HelloRequest")]-                ('RetStream ('SchemaRef QuickstartSchema "HelloResponse")) ] ]+        , 'Method "SayManyHellos"+          '[ 'ArgStream ('Nothing @Symbol) ('SchemaRef QuickstartSchema "HelloRequest")]+                ('RetStream ('SchemaRef QuickstartSchema "HelloResponse")) ] ] :: Package'  newtype HelloRequest = HelloRequest { name :: T.Text }   deriving ( Show, Eq, Generic            , ToSchema   QuickstartSchema "HelloRequest"            , FromSchema QuickstartSchema "HelloRequest" )+  deriving (J.ToJSON, J.FromJSON)+    via (WithSchema QuickstartSchema "HelloRequest" HelloRequest)  newtype HelloResponse = HelloResponse { message :: T.Text }   deriving ( Show, Eq, Generic            , ToSchema   QuickstartSchema "HelloResponse"            , FromSchema QuickstartSchema "HelloResponse" )+  deriving (J.ToJSON, J.FromJSON)+    via (WithSchema QuickstartSchema "HelloResponse" HelloResponse)  newtype HiRequest = HiRequest { number :: Int }   deriving ( Show, Eq, Generic            , ToSchema   QuickstartSchema "HiRequest"            , FromSchema QuickstartSchema "HiRequest" )+  deriving (J.ToJSON, J.FromJSON)+    via (WithSchema QuickstartSchema "HiRequest" HiRequest) -quickstartServer :: forall m. (MonadServer m)-                 => ServerT '[] QuickStartService m _+quickstartServer :: forall m i. (MonadServer m)+                 => ServerT '[] i QuickStartService m _ quickstartServer   -- = Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0)   = singleService ( method @"SayHello" sayHello@@ -94,13 +104,13 @@ -- From https://www.apollographql.com/docs/apollo-server/schema/schema/ type ApolloService   = 'Package ('Just "apollo")-      '[ Object "Book" '[]-        '[ ObjectField "title"  '[] '[] ('RetSingle ('PrimitiveRef String))-        , ObjectField "author" '[] '[] ('RetSingle ('ObjectRef "Author"))+      '[ Object "Book"+        '[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))+        , ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))         ]-      , Object "Author" '[]-        '[ ObjectField "name"  '[] '[] ('RetSingle ('PrimitiveRef String))-        , ObjectField "books" '[] '[] ('RetSingle ('ListRef ('ObjectRef "Book")))+      , Object "Author"+        '[ ObjectField "name" '[] ('RetSingle ('PrimitiveRef String))+        , ObjectField "books" '[] ('RetSingle ('ListRef ('ObjectRef "Book")))         ]       ] @@ -109,7 +119,8 @@   , "Author" ':-> Integer   ] -apolloServer :: forall m. (MonadServer m) => ServerT ApolloBookAuthor ApolloService m _+apolloServer :: forall m i. (MonadServer m)+             => ServerT ApolloBookAuthor i ApolloService m _ apolloServer   = resolver       ( object @"Author" ( field @"name"   authorName

@@ -49,11 +49,16 @@ module Mu.Server (   -- * Servers and handlers   MonadServer, ServiceChain, noContext+, wrapServer   -- ** Definitions by name-, singleService, method, resolver, object, field, NamedList(..)+, singleService+, method, methodWithInfo+, resolver, object+, field, fieldWithInfo+, NamedList(..)   -- ** Definitions by position , SingleServerT, pattern Server-, ServerT(..), ServicesT(..), HandlersT(.., (:<|>:))+, ServerT(..), ServicesT(..), HandlersT(.., (:<||>:), (:<|>:))   -- ** Simple servers using only IO , ServerErrorIO, ServerIO   -- * Errors which might be raised@@ -64,6 +69,7 @@ , Handles, FromRef, ToRef ) where +import           Control.Exception    (Exception) import           Control.Monad.Except import           Data.Conduit import           Data.Kind@@ -79,7 +85,7 @@  -- | Simple 'ServerT' which uses only 'IO' and errors, --   and whose service has no back-references.-type ServerIO srv = ServerT '[] srv ServerErrorIO+type ServerIO info srv = ServerT '[] info srv ServerErrorIO  -- | Stop the current handler, --   returning an error to the client.@@ -96,13 +102,16 @@  -- | To declare that the function doesn't use --   its context.-noContext :: b -> a -> b-noContext = const+noContext :: b -> a1 -> a2 -> b+noContext x _ _ = x  -- | Errors raised in a handler. data ServerError   = ServerError ServerErrorCode String+  deriving Show +instance Exception ServerError+ -- | Possible types of errors. --   Some of these are handled in a special way --   by different transpoprt layers.@@ -128,26 +137,27 @@ -- | Definition of a complete server --   for a set of services, with possible --   references between them.-data ServerT (chn :: ServiceChain snm) (s :: Package snm mnm anm)+data ServerT (chn :: ServiceChain snm) (info :: Type)+             (s :: Package snm mnm anm (TypeRef snm))              (m :: Type -> Type) (hs :: [[Type]]) where-  Services :: ServicesT chn s m hs-           -> ServerT chn ('Package pname s) m hs+  Services :: ServicesT chn info s m hs+           -> ServerT chn info ('Package pname s) m hs  pattern Server :: (MappingRight chn sname ~ ())-               => HandlersT chn () methods m hs-               -> ServerT chn ('Package pname '[ 'Service sname sanns methods ]) m '[hs]+               => HandlersT chn info () methods m hs+               -> ServerT chn info ('Package pname '[ 'Service sname methods ]) m '[hs] pattern Server svr = Services (svr :<&>: S0)  infixr 3 :<&>: -- | Definition of a complete server for a service.-data ServicesT (chn :: ServiceChain snm) (s :: [Service snm mnm anm])+data ServicesT (chn :: ServiceChain snm) (info :: Type)+               (s :: [Service snm mnm anm (TypeRef snm)])                (m :: Type -> Type) (hs :: [[Type]]) where-  S0 :: ServicesT chn '[] m '[]-  (:<&>:) :: HandlersT chn (MappingRight chn sname) methods m hs-          -> ServicesT chn rest m hss-          -> ServicesT chn ('Service sname anns methods ': rest) m (hs ': hss)+  S0 :: ServicesT chn info '[] m '[]+  (:<&>:) :: HandlersT chn info (MappingRight chn sname) methods m hs+          -> ServicesT chn info rest m hss+          -> ServicesT chn info ('Service sname methods ': rest) m (hs ': hss) -infixr 4 :<||>: -- | 'HandlersT' is a sequence of handlers. --   Note that the handlers for your service --   must appear __in the same order__ as they@@ -167,25 +177,37 @@ --   * Output streams turn into an __additional argument__ --     of type @Conduit t Void m ()@. This stream should --     be connected to a source to get the elements.-data HandlersT (chn :: ServiceChain snm)-               (inh :: *) (methods :: [Method snm mnm anm])+data HandlersT (chn :: ServiceChain snm) (info :: Type)+               (inh :: *) (methods :: [Method snm mnm anm (TypeRef snm)])                (m :: Type -> Type) (hs :: [Type]) where-  H0 :: HandlersT chn inh '[] m '[]-  (:<||>:) :: Handles chn args ret m h-           => (inh -> h) -> HandlersT chn inh ms m hs-           -> HandlersT chn inh ('Method name anns args ret ': ms) m (h ': hs)+  H0 :: HandlersT chn info inh '[] m '[]+  Hmore :: Handles chn args ret m h+        => Proxy args -> Proxy ret+        -> (RpcInfo info -> inh -> h)+        -> HandlersT chn info inh ms m hs+        -> HandlersT chn info inh ('Method name args ret ': ms) m (h ': hs) +infixr 4 :<||>:+pattern (:<||>:) :: Handles chn args ret m h+                 => (RpcInfo info -> inh -> h) -> HandlersT chn info inh ms m hs+                 -> HandlersT chn info inh ('Method name args ret ': ms) m (h ': hs)+pattern x :<||>: xs <- Hmore _ _ x xs where+  x :<||>: xs = Hmore Proxy Proxy x xs+ infixr 4 :<|>: pattern (:<|>:) :: (Handles chn args ret m h)-                => h -> HandlersT chn () ms m hs-                -> HandlersT chn () ('Method name anns args ret ': ms) m (h ': hs)-pattern x :<|>: xs <- (($ ()) -> x) :<||>: xs where+                => h -> HandlersT chn info () ms m hs+                -> HandlersT chn info () ('Method name args ret ': ms) m (h ': hs)+pattern x :<|>: xs <- (($ ()) . ($ NoRpcInfo) -> x) :<||>: xs where   x :<|>: xs = noContext x :<||>: xs  -- | Defines a relation for handling. class Handles (chn :: ServiceChain snm)-              (args :: [Argument snm anm]) (ret :: Return snm)-              (m :: Type -> Type) (h :: Type)+              (args :: [Argument snm anm (TypeRef snm)])+              (ret :: Return snm (TypeRef snm))+              (m :: Type -> Type) (h :: Type) where+  wrapHandler :: Proxy '(chn, m) -> Proxy args -> Proxy ret+              -> (forall a. m a -> m a) -> h -> h -- | Defines whether a given type @t@ --   can be turned into the 'TypeRef' @ref@. class ToRef   (chn :: ServiceChain snm)@@ -211,21 +233,30 @@ instance (FromRef chn ref t, Maybe t ~ s) => FromRef chn ('OptionalRef ref) s  -- Arguments-instance (FromRef chn ref t, Handles chn args ret m h,-          handler ~ (t -> h))-         => Handles chn ('ArgSingle aname anns ref ': args) ret m handler+instance forall chn ref args ret m handler h t aname.+         ( FromRef chn ref t, Handles chn args ret m h+         , handler ~ (t -> h) )+         => Handles chn ('ArgSingle aname ref ': args) ret m handler where+  wrapHandler pchn _ pr f h = wrapHandler pchn (Proxy @args) pr f . h instance (MonadError ServerError m, FromRef chn ref t, Handles chn args ret m h,           handler ~ (ConduitT () t m () -> h))-         => Handles chn ('ArgStream aname anns ref ': args) ret m handler+         => Handles chn ('ArgStream aname ref ': args) ret m handler where+  wrapHandler pchn _ pr f h = wrapHandler pchn (Proxy @args) pr f . h -- Result with exception instance (MonadError ServerError m, handler ~ m ())-         => Handles chn '[] 'RetNothing m handler-instance (MonadError ServerError m, ToRef chn eref e, ToRef chn vref v, handler ~ m (Either e v))-         => Handles chn '[] ('RetThrows eref vref) m handler+         => Handles chn '[] 'RetNothing m handler where+  wrapHandler _ _ _ f h = f h+instance ( MonadError ServerError m, ToRef chn eref e, ToRef chn vref v+         , handler ~ m (Either e v) )+         => Handles chn '[] ('RetThrows eref vref) m handler where+  wrapHandler _ _ _ f h = f h instance (MonadError ServerError m, ToRef chn ref v, handler ~ m v)-         => Handles chn '[] ('RetSingle ref) m handler-instance (MonadError ServerError m, ToRef chn ref v, handler ~ (ConduitT v Void m () -> m ()))-         => Handles chn '[] ('RetStream ref) m handler+         => Handles chn '[] ('RetSingle ref) m handler where+  wrapHandler _ _ _ f h = f h+instance ( MonadError ServerError m, ToRef chn ref v+         , handler ~ (ConduitT v Void m () -> m ()) )+         => Handles chn '[] ('RetStream ref) m handler where+  wrapHandler _ _ _ f h = f . h  -- SIMPLER WAY TO DECLARE SERVICES @@ -233,23 +264,41 @@ --   Intended to be used with @TypeApplications@: -- --   > method @"myMethod" myHandler-method :: forall n p. p -> Named n (() -> p)-method f = Named (\() -> f)+method :: forall n a p. p -> Named n (a -> () -> p)+method f = Named (\_ _ -> f) +-- | Declares the handler for a method in the service,+--   which is passed additional information about the call.+--   Intended to be used with @TypeApplications@:+--+--   > methodWithInfo @"myMethod" myHandler+methodWithInfo :: forall n p info. (RpcInfo info -> p) -> Named n (RpcInfo info -> () -> p)+methodWithInfo f = Named (\x () -> f x)+ -- | Declares the handler for a field in an object. --   Intended to be used with @TypeApplications@: -- --   > field @"myField" myHandler-field :: forall n h. h -> Named n h-field  = Named+field :: forall n h info. h -> Named n (RpcInfo info -> h)+field f = Named (const f) +-- | Declares the handler for a field in an object,+--   which is passed additional information about the call.+--   Intended to be used with @TypeApplications@:+--+--   > fieldWithInfo @"myField" myHandler+fieldWithInfo :: forall n h info. (RpcInfo info -> h) -> Named n (RpcInfo info -> h)+fieldWithInfo  = Named+ -- | Defines a server for a package with a single service. --   Intended to be used with a tuple of 'method's: -- --   > singleService (method @"m1" h1, method @"m2" h2) singleService-  :: (ToNamedList p nl, ToHandlers chn () methods m hs nl, MappingRight chn sname ~ ())-  => p -> ServerT chn ('Package pname '[ 'Service sname sanns methods ]) m '[hs]+  :: ( ToNamedList p nl+     , ToHandlers chn info () methods m hs nl+     , MappingRight chn sname ~ () )+  => p -> ServerT chn info ('Package pname '[ 'Service sname methods ]) m '[hs] singleService nl = Server $ toHandlers $ toNamedList nl  -- | Defines the implementation of a single GraphQL object,@@ -262,9 +311,10 @@ --   Note: for the root objects in GraphQL (query, mutation, subscription) --   use 'method' instead of 'object'. object-  :: forall sname p nl chn ms m hs.-     (ToNamedList p nl, ToHandlers chn (MappingRight chn sname) ms m hs nl)-  => p -> Named sname (HandlersT chn (MappingRight chn sname) ms m hs)+  :: forall sname p nl chn info ms m hs.+     ( ToNamedList p nl+     , ToHandlers chn info (MappingRight chn sname) ms m hs nl )+  => p -> Named sname (HandlersT chn info (MappingRight chn sname) ms m hs) object nl = Named $ toHandlers $ toNamedList nl  -- | Combines the implementation of several GraphQL objects,@@ -273,8 +323,8 @@ -- --   > resolver (object @"o1" ..., object @"o2" ...) resolver-  :: (ToNamedList p nl, ToServices chn ss m hs nl)-  => p -> ServerT chn ('Package pname ss) m hs+  :: (ToNamedList p nl, ToServices chn info ss m hs nl)+  => p -> ServerT chn info ('Package pname ss) m hs resolver nl = Services $ toServices $ toNamedList nl  -- | A value tagged with a type-level name.@@ -324,37 +374,39 @@                      '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8), '(n9, h9) ] where   toNamedList (n1, n2, n3, n4, n5, n6, n7, n8, n9) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: n7 :|: n8 :|: n9 :|: N0 -class ToHandlers chn inh ms m hs nl | chn inh ms m nl -> hs where+class ToHandlers chn info inh ms m hs nl | chn inh ms m nl -> hs where   toHandlers :: NamedList nl-             -> HandlersT chn inh ms m hs+             -> HandlersT chn info inh ms m hs -instance ToHandlers chn inh '[] m '[] nl where+instance ToHandlers chn info inh '[] m '[] nl where   toHandlers _ = H0-instance (FindHandler name inh h nl, Handles chn args ret m h, ToHandlers chn inh ms m hs nl)-         => ToHandlers chn inh ('Method name anns args ret ': ms) m (h ': hs) nl where+instance ( FindHandler name info inh h nl+         , Handles chn args ret m h+         , ToHandlers chn info inh ms m hs nl )+         => ToHandlers chn info inh ('Method name args ret ': ms) m (h ': hs) nl where   toHandlers nl = findHandler (Proxy @name) nl :<||>: toHandlers nl -class FindHandler name inh h nl | name nl -> inh h where-  findHandler :: Proxy name -> NamedList nl -> inh -> h+class FindHandler name info inh h nl | name nl -> inh h where+  findHandler :: Proxy name -> NamedList nl -> RpcInfo info -> inh -> h instance (inh ~ h, h ~ TypeError ('Text "cannot find handler for " ':<>: 'ShowType name))-         => FindHandler name inh h '[] where+         => FindHandler name info inh h '[] where   findHandler = error "this should never be called"-instance {-# OVERLAPS #-} (inh ~ inh', h ~ h')-         => FindHandler name inh h ( '(name, inh' -> h') ': rest ) where+instance {-# OVERLAPS #-} (RpcInfo info ~ rpc', inh ~ inh', h ~ h')+         => FindHandler name info inh h ( '(name, rpc' -> inh' -> h') ': rest ) where   findHandler _ (Named f :|: _) = f-instance {-# OVERLAPPABLE #-} FindHandler name inh h rest-         => FindHandler name inh h (thing ': rest) where+instance {-# OVERLAPPABLE #-} FindHandler name info inh h rest+         => FindHandler name info inh h (thing ': rest) where   findHandler p (_ :|: rest) = findHandler p rest -class ToServices chn ss m hs nl | chn ss m nl -> hs where+class ToServices chn info ss m hs nl | chn ss m nl -> hs where   toServices :: NamedList nl-             -> ServicesT chn ss m hs+             -> ServicesT chn info ss m hs -instance ToServices chn '[] m '[] nl where+instance ToServices chn info '[] m '[] nl where   toServices _ = S0-instance ( FindService name (HandlersT chn (MappingRight chn name) methods m h) nl-         , ToServices chn ss m hs nl)-         => ToServices chn ('Service name anns methods ': ss) m (h ': hs) nl where+instance ( FindService name (HandlersT chn info (MappingRight chn name) methods m h) nl+         , ToServices chn info ss m hs nl)+         => ToServices chn info ('Service name methods ': ss) m (h ': hs) nl where   toServices nl = findService (Proxy @name) nl :<&>: toServices nl  class FindService name h nl | name nl -> h where@@ -368,3 +420,27 @@ instance {-# OVERLAPPABLE #-} FindService name h rest          => FindService name h (thing ': rest) where   findService p (_ :|: rest) = findService p rest++-- WRAPPING MECHANISM++wrapServer+  :: forall chn info p m topHs.+     (forall a. RpcInfo info -> m a -> m a)+  -> ServerT chn info p m topHs -> ServerT chn info p m topHs+wrapServer f (Services ss) = Services (wrapServices ss)+  where+    wrapServices :: forall ss hs.+                    ServicesT chn info ss m hs+                 -> ServicesT chn info ss m hs+    wrapServices S0 = S0+    wrapServices (h :<&>: rest)+      = wrapHandlers h :<&>: wrapServices rest++    wrapHandlers :: forall inh ms innerHs.+                    HandlersT chn info inh ms m innerHs+                 -> HandlersT chn info inh ms m innerHs+    wrapHandlers H0 = H0+    wrapHandlers (Hmore pargs pret h rest)+      = Hmore pargs pret+              (\rpc inh -> wrapHandler (Proxy @'(chn, m)) pargs pret (f rpc) (h rpc inh))+              (wrapHandlers rest)