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.2.0.0 +version: 0.3.0.0 synopsis: Protocol-independent declaration of services and servers. description: Protocol-independent declaration of services and servers for mu-haskell. @@ -30,7 +30,7 @@ base >=4.12 && <5 , conduit , mtl - , mu-schema >=0.2.0 + , mu-schema >=0.3.0 , sop-core , template-haskell , text diff --git a/src/Mu/Rpc.hs b/src/Mu/Rpc.hs --- a/src/Mu/Rpc.hs +++ b/src/Mu/Rpc.hs @@ -14,10 +14,11 @@ and protocol. -} module Mu.Rpc ( - Service', Service(..) -, ServiceAnnotation, Package, FindPackageName -, Method(..), (:-->:) -, TypeRef(..), Argument(..), Return(..) + Package', Package(..) +, Service', Service(..), Object +, ServiceAnnotation, Method', Method(..), ObjectField +, LookupService, LookupMethod +, TypeRef(..), Argument', Argument(..), Return(..) ) where import Data.Kind @@ -27,66 +28,91 @@ import Mu.Schema import Mu.Schema.Registry +-- | Packages whose names are given by type-level strings. +type Package' = Package Symbol Symbol Symbol -- | Services whose names are given by type-level strings. -type Service' = Service Symbol Symbol +type Service' = Service Symbol Symbol Symbol +-- | Methods whose names are given by type-level strings. +type Method' = Method Symbol Symbol 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 +-- | A package is a set of services. +data Package serviceName methodName argName + = Package (Maybe serviceName) + [Service serviceName methodName argName] + -- | A service is a set of methods. -data Service serviceName methodName - = Service serviceName [ServiceAnnotation] [Method methodName] +data Service serviceName methodName argName + = Service serviceName + [ServiceAnnotation] + [Method serviceName methodName argName] --- | An annotation to define a package name. --- This is used by some handlers, like gRPC. -data Package (s :: Symbol) +-- | A method is defined by its name, arguments, and return type. +data Method serviceName methodName argName + = Method methodName [ServiceAnnotation] + [Argument serviceName argName] + (Return serviceName) --- | Find the 'Package' for a service, to be found --- as part of the annotations. -type family FindPackageName (anns :: [ServiceAnnotation]) :: Symbol where - FindPackageName '[] = TypeError ('Text "Cannot find package name for the service") - FindPackageName (Package s ': rest) = s - FindPackageName (other ': rest) = FindPackageName rest +-- Synonyms for GraphQL +-- | An object is a set of fields, in GraphQL lingo. +type Object = 'Service +-- | A field in an object takes some input objects, +-- and returns a value or some other object, +-- in GraphQL lingo. +type ObjectField = 'Method --- | A method is defined by its name, arguments, and return type. -data Method methodName - = Method methodName [ServiceAnnotation] [Argument] Return +-- | 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 + 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 -- | Look up a method in a service definition using its name. --- Useful to declare handlers like @HandlerIO (MyService :-->: "MyMethod")@. -type family (:-->:) (s :: Service snm mnm) (m :: mnm) :: Method mnm where - 'Service sname anns methods :-->: m = LookupMethod methods m - -type family LookupMethod (s :: [Method mnm]) (m :: snm) :: Method snm where +type family LookupMethod (s :: [Method snm mnm anm]) (m :: mnm) :: Method snm mnm anm 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 --- | Defines how to handle the type -data TypeRef where - ViaSchema :: Schema typeName fieldName -> typeName -> TypeRef +-- | Defines a reference to a type, either primitive or coming from the schema. +-- 'TypeRef's are used to define arguments and result types. +data TypeRef serviceName where + -- | A primitive type. + PrimitiveRef :: Type -> TypeRef serviceName + -- | Chain with another service. + ObjectRef :: serviceName -> TypeRef serviceName + -- | Point to schema. + SchemaRef :: Schema typeName fieldName -> typeName -> TypeRef serviceName -- | Registry subject, type to convert to, and preferred serialization version - ViaRegistry :: Registry -> Type -> Nat -> TypeRef + RegistryRef :: Registry -> Type -> Nat -> TypeRef serviceName -- | To be used only during TH generation! - ViaTH :: TH.Type -> TypeRef + THRef :: TH.Type -> TypeRef serviceName + -- Combinators found in the gRPC and GraphQL languages. + -- | Represents a list of values. + ListRef :: TypeRef serviceName -> TypeRef serviceName + -- | Represents a possibly-missing value. + OptionalRef :: TypeRef serviceName -> TypeRef serviceName -- | Defines the way in which arguments are handled. -data Argument where +data Argument serviceName argName where -- | Use a single value. - ArgSingle :: TypeRef -> Argument + ArgSingle :: Maybe argName -> [ServiceAnnotation] + -> TypeRef serviceName -> Argument serviceName argName -- | Consume a stream of values. - ArgStream :: TypeRef -> Argument + ArgStream :: Maybe argName -> [ServiceAnnotation] + -> TypeRef serviceName -> Argument serviceName argName -- | Defines the different possibilities for returning -- information from a method. -data Return where +data Return serviceName where -- | Fire and forget. - RetNothing :: Return + RetNothing :: Return serviceName -- | Return a single value. - RetSingle :: TypeRef -> Return - -- | Return a value or an error - -- (this can be found in Avro IDL). - RetThrows :: TypeRef -> TypeRef -> Return - -- | Return a stream of values - -- (this can be found in gRPC). - RetStream :: TypeRef -> Return + RetSingle :: TypeRef serviceName -> Return serviceName + -- | Return a stream of values. + RetStream :: TypeRef serviceName -> Return serviceName + -- | Return a value or an error. + RetThrows :: TypeRef serviceName -> TypeRef serviceName -> Return serviceName 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 @@ -9,10 +9,9 @@ {-# language PartialTypeSignatures #-} {-# language PolyKinds #-} {-# language ScopedTypeVariables #-} -{-# language StandaloneDeriving #-} +{-# language TypeApplications #-} {-# language TypeFamilies #-} {-# language TypeOperators #-} -{-# language ViewPatterns #-} {-# OPTIONS_GHC -fno-warn-partial-type-signatures #-} {-| Description : Examples for service and server definitions @@ -23,7 +22,6 @@ import Data.Conduit import Data.Conduit.Combinators as C -import Data.Functor.MaybeLike import qualified Data.Text as T import GHC.Generics @@ -36,54 +34,90 @@ type QuickstartSchema = '[ 'DRecord "HelloRequest" - '[ 'FieldDef "name" ('TPrimitive T.Text) ] + '[ 'FieldDef "name" ('TPrimitive T.Text) ] , 'DRecord "HelloResponse" - '[ 'FieldDef "message" ('TPrimitive T.Text) ] + '[ 'FieldDef "message" ('TPrimitive T.Text) ] , 'DRecord "HiRequest" - '[ 'FieldDef "number" ('TPrimitive Int) ] + '[ 'FieldDef "number" ('TPrimitive Int) ] ] type QuickStartService - = 'Service "Greeter" '[Package "helloworld"] - '[ 'Method "SayHello" '[] - '[ 'ArgSingle ('ViaSchema QuickstartSchema "HelloRequest") ] - ('RetSingle ('ViaSchema QuickstartSchema "HelloResponse")) - , 'Method "SayHi" '[] - '[ 'ArgSingle ('ViaSchema QuickstartSchema "HiRequest")] - ('RetStream ('ViaSchema QuickstartSchema "HelloResponse")) - , 'Method "SayManyHellos" '[] - '[ 'ArgStream ('ViaSchema QuickstartSchema "HelloRequest")] - ('RetStream ('ViaSchema QuickstartSchema "HelloResponse")) ] + = 'Package ('Just "helloworld") + '[ 'Service "Greeter" '[] + '[ 'Method "SayHello" '[] + '[ 'ArgSingle 'Nothing '[] ('SchemaRef QuickstartSchema "HelloRequest") ] + ('RetSingle ('SchemaRef QuickstartSchema "HelloResponse")) + , 'Method "SayHi" '[] + '[ 'ArgSingle 'Nothing '[] ('SchemaRef QuickstartSchema "HiRequest")] + ('RetStream ('SchemaRef QuickstartSchema "HelloResponse")) + , 'Method "SayManyHellos" '[] + '[ 'ArgStream 'Nothing '[] ('SchemaRef QuickstartSchema "HelloRequest")] + ('RetStream ('SchemaRef QuickstartSchema "HelloResponse")) ] ] -newtype HelloRequest f = HelloRequest { name :: f T.Text } deriving (Generic) -deriving instance Functor f => ToSchema f QuickstartSchema "HelloRequest" (HelloRequest f) -deriving instance Functor f => FromSchema f QuickstartSchema "HelloRequest" (HelloRequest f) +newtype HelloRequest = HelloRequest { name :: T.Text } + deriving ( Show, Eq, Generic + , ToSchema QuickstartSchema "HelloRequest" + , FromSchema QuickstartSchema "HelloRequest" ) -newtype HelloResponse f = HelloResponse { message :: f T.Text } deriving (Generic) -deriving instance Functor f => ToSchema f QuickstartSchema "HelloResponse" (HelloResponse f) -deriving instance Functor f => FromSchema f QuickstartSchema "HelloResponse" (HelloResponse f) +newtype HelloResponse = HelloResponse { message :: T.Text } + deriving ( Show, Eq, Generic + , ToSchema QuickstartSchema "HelloResponse" + , FromSchema QuickstartSchema "HelloResponse" ) -newtype HiRequest f = HiRequest { number :: f Int } deriving (Generic) -deriving instance Functor f => ToSchema f QuickstartSchema "HiRequest" (HiRequest f) -deriving instance Functor f => FromSchema f QuickstartSchema "HiRequest" (HiRequest f) +newtype HiRequest = HiRequest { number :: Int } + deriving ( Show, Eq, Generic + , ToSchema QuickstartSchema "HiRequest" + , FromSchema QuickstartSchema "HiRequest" ) -quickstartServer :: forall m f. - (MonadServer m, Applicative f, MaybeLike f) - => ServerT f QuickStartService m _ +quickstartServer :: forall m. (MonadServer m) + => ServerT '[] QuickStartService m _ quickstartServer - = Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0) - where sayHello :: HelloRequest f -> m (HelloResponse f) - sayHello (HelloRequest nm) - = return (HelloResponse (("hi, " <>) <$> nm)) - sayHi :: HiRequest f - -> ConduitT (HelloResponse f) Void m () - -> m () - sayHi (HiRequest (likeMaybe -> Just n)) sink - = runConduit $ C.replicate n (HelloResponse $ pure "hi!") .| sink - sayHi (HiRequest _) sink - = runConduit $ return () .| sink - sayManyHellos :: ConduitT () (HelloRequest f) m () - -> ConduitT (HelloResponse f) Void m () - -> m () - sayManyHellos source sink - = runConduit $ source .| C.mapM sayHello .| sink + -- = Server (sayHello :<|>: sayHi :<|>: sayManyHellos :<|>: H0) + = singleService ( method @"SayHello" sayHello + , method @"SayManyHellos" sayManyHellos + , method @"SayHi" sayHi ) + where + sayHello :: HelloRequest -> m HelloResponse + sayHello (HelloRequest nm) + = pure $ HelloResponse $ "hi, " <> nm + sayHi :: HiRequest + -> ConduitT HelloResponse Void m () + -> m () + sayHi (HiRequest n) sink + = runConduit $ C.replicate n (HelloResponse "hi!") .| sink + sayManyHellos :: ConduitT () HelloRequest m () + -> ConduitT HelloResponse Void m () + -> m () + sayManyHellos source sink + = runConduit $ source .| C.mapM sayHello .| sink + +-- 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 "Author" '[] + '[ ObjectField "name" '[] '[] ('RetSingle ('PrimitiveRef String)) + , ObjectField "books" '[] '[] ('RetSingle ('ListRef ('ObjectRef "Book"))) + ] + ] + +type ApolloBookAuthor = '[ + "Book" ':-> (String, Integer) + , "Author" ':-> Integer + ] + +apolloServer :: forall m. (MonadServer m) => ServerT ApolloBookAuthor ApolloService m _ +apolloServer + = resolver + ( object @"Author" ( field @"name" authorName + , field @"books" authorBooks ) + , object @"Book" ( field @"author" (pure . snd) + , field @"title" (pure . fst) ) ) + where + authorName :: Integer -> m String + authorName _ = pure "alex" -- this would run in the DB + authorBooks :: Integer -> m [(String, Integer)] + authorBooks _ = pure [] diff --git a/src/Mu/Server.hs b/src/Mu/Server.hs --- a/src/Mu/Server.hs +++ b/src/Mu/Server.hs @@ -3,13 +3,17 @@ {-# language ExistentialQuantification #-} {-# language FlexibleContexts #-} {-# language FlexibleInstances #-} +{-# language FunctionalDependencies #-} {-# language GADTs #-} -{-# language MultiParamTypeClasses #-} +{-# language PatternSynonyms #-} {-# language PolyKinds #-} {-# language RankNTypes #-} +{-# language ScopedTypeVariables #-} +{-# language TypeApplications #-} {-# language TypeFamilies #-} {-# language TypeOperators #-} {-# language UndecidableInstances #-} +{-# language ViewPatterns #-} {-| Description : Protocol-independent declaration of servers. @@ -17,16 +21,26 @@ of handlers (represented by 'HandlersT'), one for each operation in the corresponding Mu service declaration. -In general, you should declare a server as: +In general, you can declare a server by naming +each of the methods with their handlers: -> server :: MonadServer m => ServerT w MyService m _ +> server :: MonadServer m => ServerT MyService m _ +> server = singleService ( method @"m1" h1 +> , method @"m2" h2 +> , ... ) + +or by position: + +> server :: MonadServer m => ServerT MyService m _ > server = Server (h1 :<|>: h2 :<|>: ... :<|>: H0) where each of @h1@, @h2@, ... handles each method in @MyService@ /in the order they were declared/. -The @_@ in the type allows GHC to fill in the boring -and long type you would need to write there otherwise. +In both cases, the @_@ in the type allows GHC to fill +in the boring and long type you would need to write +there otherwise. + /Implementation note/: exceptions raised in handlers produce an error to be sent as response to the client. We recommend you to catch exceptions and return custom @@ -34,18 +48,26 @@ -} module Mu.Server ( -- * Servers and handlers - MonadServer, ServerT(..), HandlersT(..) + MonadServer, ServiceChain, noContext + -- ** Definitions by name +, singleService, method, resolver, object, field, NamedList(..) + -- ** Definitions by position +, SingleServerT, pattern Server +, ServerT(..), ServicesT(..), HandlersT(.., (:<|>:)) -- ** Simple servers using only IO , ServerErrorIO, ServerIO -- * Errors which might be raised , serverError, ServerError(..), ServerErrorCode(..) -- ** Useful when you do not want to deal with errors , alwaysOk + -- * For internal use +, Handles, FromRef, ToRef ) where import Control.Monad.Except import Data.Conduit import Data.Kind +import GHC.TypeLits import Mu.Rpc import Mu.Schema @@ -54,9 +76,11 @@ type MonadServer m = (MonadError ServerError m, MonadIO m) -- | Simplest monad which satisfies 'MonadServer'. type ServerErrorIO = ExceptT ServerError IO --- | Simple 'ServerT' which uses only 'IO' and errors. -type ServerIO w srv = ServerT w srv ServerErrorIO +-- | Simple 'ServerT' which uses only 'IO' and errors, +-- and whose service has no back-references. +type ServerIO srv = ServerT '[] srv ServerErrorIO + -- | Stop the current handler, -- returning an error to the client. serverError :: (MonadError ServerError m) @@ -70,6 +94,11 @@ => IO a -> m a alwaysOk = liftIO +-- | To declare that the function doesn't use +-- its context. +noContext :: b -> a -> b +noContext = const + -- | Errors raised in a handler. data ServerError = ServerError ServerErrorCode String @@ -87,11 +116,38 @@ | NotFound deriving (Eq, Show) +-- | Defines a mapping between outcome of +-- a service, and its representation as +-- Haskell type. +type ServiceChain snm = Mappings snm Type + +-- | A server for a single service, +-- like most RPC ones. +type SingleServerT = ServerT '[] + +-- | 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) + (m :: Type -> Type) (hs :: [[Type]]) where + Services :: ServicesT chn s m hs + -> ServerT chn ('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] +pattern Server svr = Services (svr :<&>: S0) + +infixr 3 :<&>: -- | Definition of a complete server for a service. -data ServerT (w :: Type -> Type) (s :: Service snm mnm) (m :: Type -> Type) (hs :: [Type]) where - Server :: HandlersT w methods m hs -> ServerT w ('Service sname anns methods) m hs +data ServicesT (chn :: ServiceChain snm) (s :: [Service snm mnm anm]) + (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) -infixr 5 :<|>: +infixr 4 :<||>: -- | 'HandlersT' is a sequence of handlers. -- Note that the handlers for your service -- must appear __in the same order__ as they @@ -111,36 +167,204 @@ -- * 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 (w :: Type -> Type) (methods :: [Method mnm]) (m :: Type -> Type) (hs :: [Type]) where - H0 :: HandlersT w '[] m '[] - (:<|>:) :: Handles w args ret m h => h -> HandlersT w ms m hs - -> HandlersT w ('Method name anns args ret ': ms) m (h ': hs) +data HandlersT (chn :: ServiceChain snm) + (inh :: *) (methods :: [Method snm mnm anm]) + (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) --- Define a relation for handling -class Handles (w :: Type -> Type) (args :: [Argument]) (ret :: Return) +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 + 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) -class ToRef (w :: Type -> Type) (ref :: TypeRef) (t :: Type) -class FromRef (w :: Type -> Type) (ref :: TypeRef) (t :: Type) +-- | Defines whether a given type @t@ +-- can be turned into the 'TypeRef' @ref@. +class ToRef (chn :: ServiceChain snm) + (ref :: TypeRef snm) (t :: Type) +-- | Defines whether a given type @t@ +-- can be obtained from the 'TypeRef' @ref@. +class FromRef (chn :: ServiceChain snm) + (ref :: TypeRef snm) (t :: Type) -- Type references -instance ToSchema w sch sty t => ToRef w ('ViaSchema sch sty) t -instance ToRef w ('ViaRegistry subject t last) t -instance FromSchema w sch sty t => FromRef w ('ViaSchema sch sty) t -instance FromRef w ('ViaRegistry subject t last) t +instance t ~ s => ToRef chn ('PrimitiveRef t) s +instance ToSchema sch sty t => ToRef chn ('SchemaRef sch sty) t +instance MappingRight chn ref ~ t => ToRef chn ('ObjectRef ref) t +instance t ~ s => ToRef chn ('RegistryRef subject t last) s +instance (ToRef chn ref t, [t] ~ s) => ToRef chn ('ListRef ref) s +instance (ToRef chn ref t, Maybe t ~ s) => ToRef chn ('OptionalRef ref) s +instance t ~ s => FromRef chn ('PrimitiveRef t) s +instance FromSchema sch sty t => FromRef chn ('SchemaRef sch sty) t +instance MappingRight chn ref ~ t => FromRef chn ('ObjectRef ref) t +instance t ~ s => FromRef chn ('RegistryRef subject t last) s +instance (FromRef chn ref t, [t] ~ s) => FromRef chn ('ListRef ref) s +instance (FromRef chn ref t, Maybe t ~ s) => FromRef chn ('OptionalRef ref) s + -- Arguments -instance (FromRef w ref t, Handles w args ret m h, +instance (FromRef chn ref t, Handles chn args ret m h, handler ~ (t -> h)) - => Handles w ('ArgSingle ref ': args) ret m handler -instance (MonadError ServerError m, FromRef w ref t, Handles w args ret m h, + => Handles chn ('ArgSingle aname anns ref ': args) ret m handler +instance (MonadError ServerError m, FromRef chn ref t, Handles chn args ret m h, handler ~ (ConduitT () t m () -> h)) - => Handles w ('ArgStream ref ': args) ret m handler + => Handles chn ('ArgStream aname anns ref ': args) ret m handler -- Result with exception instance (MonadError ServerError m, handler ~ m ()) - => Handles w '[] 'RetNothing m handler -instance (MonadError ServerError m, ToRef w eref e, ToRef w vref v, handler ~ m (Either e v)) - => Handles w '[] ('RetThrows eref vref) m handler -instance (MonadError ServerError m, ToRef w ref v, handler ~ m v) - => Handles w '[] ('RetSingle ref) m handler -instance (MonadError ServerError m, ToRef w ref v, handler ~ (ConduitT v Void m () -> m ())) - => Handles w '[] ('RetStream ref) m handler + => 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 +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 + +-- SIMPLER WAY TO DECLARE SERVICES + +-- | Declares the handler for a method in the service. +-- Intended to be used with @TypeApplications@: +-- +-- > method @"myMethod" myHandler +method :: forall n p. p -> Named n (() -> p) +method f = Named (\() -> f) + +-- | 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 + +-- | 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] +singleService nl = Server $ toHandlers $ toNamedList nl + +-- | Defines the implementation of a single GraphQL object, +-- which translates as a single Mu service. +-- Intended to be used with @TypeApplications@ +-- and a tuple of 'field's: +-- +-- > object @"myObject" (field @"f1" h1, fielf @"f2" h2) +-- +-- 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) +object nl = Named $ toHandlers $ toNamedList nl + +-- | Combines the implementation of several GraphQL objects, +-- which means a whole Mu service for a GraphQL server. +-- Intented to be used with a tuple of 'objects': +-- +-- > resolver (object @"o1" ..., object @"o2" ...) +resolver + :: (ToNamedList p nl, ToServices chn ss m hs nl) + => p -> ServerT chn ('Package pname ss) m hs +resolver nl = Services $ toServices $ toNamedList nl + +-- | A value tagged with a type-level name. +data Named n h where + Named :: forall n h. h -> Named n h + +infixr 4 :|: +-- | Heterogeneous list in which each element +-- is tagged with a type-level name. +data NamedList (hs :: [(Symbol, *)]) where + N0 :: NamedList '[] + (:|:) :: Named n h -> NamedList hs + -> NamedList ('(n, h) ': hs) + +-- | Used to turn tuples into 'NamedList's. +class ToNamedList p nl | p -> nl where + toNamedList :: p -> NamedList nl + +instance ToNamedList (NamedList nl) nl where + toNamedList = id +instance ToNamedList () '[] where + toNamedList _ = N0 +instance ToNamedList (Named n h) '[ '(n, h) ] where + toNamedList n = n :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2) + '[ '(n1, h1), '(n2, h2) ] where + toNamedList (n1, n2) = n1 :|: n2 :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3) + '[ '(n1, h1), '(n2, h2), '(n3, h3) ] where + toNamedList (n1, n2, n3) = n1 :|: n2 :|: n3 :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4) + '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4) ] where + toNamedList (n1, n2, n3, n4) = n1 :|: n2 :|: n3 :|: n4 :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5) + '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5) ] where + toNamedList (n1, n2, n3, n4, n5) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6) + '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6) ] where + toNamedList (n1, n2, n3, n4, n5, n6) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6, Named n7 h7) + '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7) ] where + toNamedList (n1, n2, n3, n4, n5, n6, n7) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: n7 :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6, Named n7 h7, Named n8 h8) + '[ '(n1, h1), '(n2, h2), '(n3, h3), '(n4, h4), '(n5, h5), '(n6, h6), '(n7, h7), '(n8, h8) ] where + toNamedList (n1, n2, n3, n4, n5, n6, n7, n8) = n1 :|: n2 :|: n3 :|: n4 :|: n5 :|: n6 :|: n7 :|: n8 :|: N0 +instance ToNamedList (Named n1 h1, Named n2 h2, Named n3 h3, Named n4 h4, Named n5 h5, Named n6 h6, Named n7 h7, Named n8 h8, Named n9 h9) + '[ '(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 + toHandlers :: NamedList nl + -> HandlersT chn inh ms m hs + +instance ToHandlers chn 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 + 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 +instance (inh ~ h, h ~ TypeError ('Text "cannot find handler for " ':<>: 'ShowType name)) + => FindHandler name 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 + findHandler _ (Named f :|: _) = f +instance {-# OVERLAPPABLE #-} FindHandler name inh h rest + => FindHandler name inh h (thing ': rest) where + findHandler p (_ :|: rest) = findHandler p rest + +class ToServices chn ss m hs nl | chn ss m nl -> hs where + toServices :: NamedList nl + -> ServicesT chn ss m hs + +instance ToServices chn '[] 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 + toServices nl = findService (Proxy @name) nl :<&>: toServices nl + +class FindService name h nl | name nl -> h where + findService :: Proxy name -> NamedList nl -> h +instance (h ~ TypeError ('Text "cannot find handler for " ':<>: 'ShowType name)) + => FindService name h '[] where + findService = error "this should never be called" +instance {-# OVERLAPS #-} (h ~ h') + => FindService name h ( '(name, h') ': rest ) where + findService _ (Named f :|: _) = f +instance {-# OVERLAPPABLE #-} FindService name h rest + => FindService name h (thing ': rest) where + findService p (_ :|: rest) = findService p rest