diff --git a/mu-rpc.cabal b/mu-rpc.cabal --- a/mu-rpc.cabal +++ b/mu-rpc.cabal @@ -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 diff --git a/src/Mu/Rpc.hs b/src/Mu/Rpc.hs --- a/src/Mu/Rpc.hs +++ b/src/Mu/Rpc.hs @@ -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 + = "" + 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) diff --git a/src/Mu/Rpc/Annotations.hs b/src/Mu/Rpc/Annotations.hs new file mode 100644 --- /dev/null +++ b/src/Mu/Rpc/Annotations.hs @@ -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 diff --git a/src/Mu/Rpc/Examples.hs b/src/Mu/Rpc/Examples.hs --- a/src/Mu/Rpc/Examples.hs +++ b/src/Mu/Rpc/Examples.hs @@ -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 diff --git a/src/Mu/Server.hs b/src/Mu/Server.hs --- a/src/Mu/Server.hs +++ b/src/Mu/Server.hs @@ -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)