mirror of
https://github.com/higherkindness/mu-haskell.git
synced 2024-08-17 10:20:22 +03:00
Unions in GraphQL (#270)
This commit is contained in:
parent
8bb3a5cf6c
commit
e9d55fd6bf
@ -38,7 +38,7 @@ library
|
||||
, containers >=0.6 && <0.7
|
||||
, deepseq >=1.4 && <2
|
||||
, language-avro >=0.1.3 && <0.2
|
||||
, mu-rpc >=0.4 && <0.5
|
||||
, mu-rpc >=0.4 && <0.6
|
||||
, mu-schema >=0.3 && <0.4
|
||||
, sop-core >=0.5.0 && <0.6
|
||||
, tagged >=0.8.6 && <0.9
|
||||
|
@ -38,7 +38,7 @@ library
|
||||
, http-client >=0.6 && <0.7
|
||||
, http2-grpc-proto3-wire >=0.1 && <0.2
|
||||
, language-protobuf >=1.0.1 && <2
|
||||
, mu-rpc >=0.4 && <0.5
|
||||
, mu-rpc >=0.4 && <0.6
|
||||
, mu-schema >=0.3 && <0.4
|
||||
, proto3-wire >=1.1 && <2
|
||||
, servant-client-core >=0.16 && <0.19
|
||||
|
@ -1,5 +1,5 @@
|
||||
name: mu-rpc
|
||||
version: 0.4.0.1
|
||||
version: 0.5.0.0
|
||||
synopsis: Protocol-independent declaration of services and servers.
|
||||
description:
|
||||
Protocol-independent declaration of services and servers for mu-haskell.
|
||||
|
@ -20,7 +20,7 @@ and protocol.
|
||||
-}
|
||||
module Mu.Rpc (
|
||||
Package', Package(..)
|
||||
, Service', Service(..), Object
|
||||
, Service', Service(..), Object, Union
|
||||
, Method', Method(..), ObjectField
|
||||
, LookupService, LookupMethod
|
||||
, TypeRef(..), Argument', Argument(..), Return(..)
|
||||
@ -56,6 +56,7 @@ data Package serviceName methodName argName tyRef
|
||||
data Service serviceName methodName argName tyRef
|
||||
= Service serviceName
|
||||
[Method serviceName methodName argName tyRef]
|
||||
| OneOf serviceName [serviceName]
|
||||
|
||||
-- | A method is defined by its name, arguments, and return type.
|
||||
data Method serviceName methodName argName tyRef
|
||||
@ -66,6 +67,8 @@ data Method serviceName methodName argName tyRef
|
||||
-- Synonyms for GraphQL
|
||||
-- | An object is a set of fields, in GraphQL lingo.
|
||||
type Object = 'Service
|
||||
-- | A union is one of the objects.
|
||||
type Union = 'OneOf
|
||||
-- | A field in an object takes some input objects,
|
||||
-- and returns a value or some other object,
|
||||
-- in GraphQL lingo.
|
||||
@ -76,6 +79,7 @@ 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 ms ': ss) s = 'Service s ms
|
||||
LookupService ('OneOf s ms ': ss) s = 'OneOf s ms
|
||||
LookupService (other ': ss) s = LookupService ss s
|
||||
|
||||
-- | Look up a method in a service definition using its name.
|
||||
@ -136,7 +140,7 @@ data RpcInfo i
|
||||
= NoRpcInfo
|
||||
| RpcInfo { packageInfo :: Package Text Text Text TyInfo
|
||||
, serviceInfo :: Service Text Text Text TyInfo
|
||||
, methodInfo :: Method Text Text Text TyInfo
|
||||
, methodInfo :: Maybe (Method Text Text Text TyInfo)
|
||||
, headers :: RequestHeaders
|
||||
, extraInfo :: i
|
||||
}
|
||||
@ -150,10 +154,15 @@ data TyInfo
|
||||
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)
|
||||
show (RpcInfo (Package p _) s m _ _)
|
||||
= T.unpack $ showPkg p (showMth m (showSvc s))
|
||||
where
|
||||
showPkg Nothing = id
|
||||
showPkg (Just pkg) = ((pkg <> ":") <>)
|
||||
showMth Nothing = id
|
||||
showMth (Just (Method mt _ _)) = (<> (":" <> mt))
|
||||
showSvc (Service sv _) = sv
|
||||
showSvc (OneOf sv _) = sv
|
||||
|
||||
class ReflectRpcInfo (p :: Package') (s :: Service') (m :: Method') where
|
||||
reflectRpcInfo :: Proxy p -> Proxy s -> Proxy m -> RequestHeaders -> i -> RpcInfo i
|
||||
@ -175,6 +184,13 @@ instance KnownMaySymbol 'Nothing where
|
||||
instance (KnownSymbol s) => KnownMaySymbol ('Just s) where
|
||||
maySymbolVal _ = Just $ T.pack $ symbolVal (Proxy @s)
|
||||
|
||||
class KnownSymbols (m :: [Symbol]) where
|
||||
symbolsVal :: Proxy m -> [Text]
|
||||
instance KnownSymbols '[] where
|
||||
symbolsVal _ = []
|
||||
instance (KnownSymbol s, KnownSymbols ss) => KnownSymbols (s ': ss) where
|
||||
symbolsVal _ = T.pack (symbolVal (Proxy @s)) : symbolsVal (Proxy @ss)
|
||||
|
||||
class ReflectServices (ss :: [Service']) where
|
||||
reflectServices :: Proxy ss -> [Service Text Text Text TyInfo]
|
||||
instance ReflectServices '[] where
|
||||
@ -204,7 +220,7 @@ instance (KnownMaySymbol pname, ReflectServices ss, ReflectService s, ReflectMet
|
||||
reflectRpcInfo _ ps pm req extra
|
||||
= RpcInfo (Package (maySymbolVal (Proxy @pname))
|
||||
(reflectServices (Proxy @ss)))
|
||||
(reflectService ps) (reflectMethod pm) req extra
|
||||
(reflectService ps) (Just (reflectMethod pm)) req extra
|
||||
|
||||
instance (KnownSymbol sname, ReflectMethods ms)
|
||||
=> ReflectService ('Service sname ms) where
|
||||
@ -212,6 +228,12 @@ instance (KnownSymbol sname, ReflectMethods ms)
|
||||
= Service (T.pack $ symbolVal (Proxy @sname))
|
||||
(reflectMethods (Proxy @ms))
|
||||
|
||||
instance (KnownSymbol sname, KnownSymbols elts)
|
||||
=> ReflectService ('OneOf sname elts) where
|
||||
reflectService _
|
||||
= OneOf (T.pack $ symbolVal (Proxy @sname))
|
||||
(symbolsVal (Proxy @elts))
|
||||
|
||||
instance (KnownSymbol mname, ReflectArgs args, ReflectReturn r)
|
||||
=> ReflectMethod ('Method mname args r) where
|
||||
reflectMethod _
|
||||
|
@ -108,14 +108,21 @@ type ApolloService
|
||||
'[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))
|
||||
, ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))
|
||||
]
|
||||
, Object "Paper"
|
||||
'[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))
|
||||
, ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))
|
||||
]
|
||||
, Union "Writing" ["Book", "Paper"]
|
||||
, Object "Author"
|
||||
'[ ObjectField "name" '[] ('RetSingle ('PrimitiveRef String))
|
||||
, ObjectField "books" '[] ('RetSingle ('ListRef ('ObjectRef "Book")))
|
||||
, ObjectField "writings" '[] ('RetSingle ('ListRef ('ObjectRef "Writing")))
|
||||
]
|
||||
]
|
||||
|
||||
type ApolloBookAuthor = '[
|
||||
"Book" ':-> (String, Integer)
|
||||
, "Paper" ':-> (String, Integer)
|
||||
, "Writing" ':-> Either (String, Integer) (String, Integer)
|
||||
, "Author" ':-> Integer
|
||||
]
|
||||
|
||||
@ -124,11 +131,17 @@ apolloServer :: forall m i. (MonadServer m)
|
||||
apolloServer
|
||||
= resolver
|
||||
( object @"Author" ( field @"name" authorName
|
||||
, field @"books" authorBooks )
|
||||
, field @"writings" authorWrs )
|
||||
, object @"Book" ( field @"author" (pure . snd)
|
||||
, field @"title" (pure . fst) ) )
|
||||
, field @"title" (pure . fst) )
|
||||
, object @"Paper" ( field @"author" (pure . snd)
|
||||
, field @"title" (pure . fst) )
|
||||
, union @"Writing" writing )
|
||||
where
|
||||
authorName :: Integer -> m String
|
||||
authorName _ = pure "alex" -- this would run in the DB
|
||||
authorBooks :: Integer -> m [(String, Integer)]
|
||||
authorBooks _ = pure []
|
||||
authorWrs :: Integer -> m [Either (String, Integer) (String, Integer)]
|
||||
authorWrs _ = pure []
|
||||
|
||||
writing (Left c) = pure $ unionChoice @"Book" c
|
||||
writing (Right c) = pure $ unionChoice @"Paper" c
|
||||
|
@ -1,3 +1,4 @@
|
||||
{-# language AllowAmbiguousTypes #-}
|
||||
{-# language CPP #-}
|
||||
{-# language ConstraintKinds #-}
|
||||
{-# language DataKinds #-}
|
||||
@ -54,12 +55,13 @@ module Mu.Server (
|
||||
-- ** Definitions by name
|
||||
, singleService
|
||||
, method, methodWithInfo
|
||||
, resolver, object
|
||||
, resolver, object, union
|
||||
, field, fieldWithInfo
|
||||
, UnionChoice(..), unionChoice
|
||||
, NamedList(..)
|
||||
-- ** Definitions by position
|
||||
, SingleServerT, pattern Server
|
||||
, ServerT(..), ServicesT(..), HandlersT(.., (:<||>:), (:<|>:))
|
||||
, ServerT(..), ServicesT(..), ServiceT(..), HandlersT(.., (:<||>:), (:<|>:))
|
||||
-- ** Simple servers using only IO
|
||||
, ServerErrorIO, ServerIO
|
||||
-- * Errors which might be raised
|
||||
@ -74,6 +76,7 @@ import Control.Exception (Exception)
|
||||
import Control.Monad.Except
|
||||
import Data.Conduit
|
||||
import Data.Kind
|
||||
import Data.Typeable
|
||||
import GHC.TypeLits
|
||||
|
||||
import Mu.Rpc
|
||||
@ -151,7 +154,7 @@ data ServerT (chn :: ServiceChain snm) (info :: Type)
|
||||
pattern Server :: (MappingRight chn sname ~ ())
|
||||
=> HandlersT chn info () methods m hs
|
||||
-> ServerT chn info ('Package pname '[ 'Service sname methods ]) m '[hs]
|
||||
pattern Server svr = Services (svr :<&>: S0)
|
||||
pattern Server svr = Services (ProperSvc svr :<&>: S0)
|
||||
|
||||
infixr 3 :<&>:
|
||||
-- | Definition of a complete server for a service.
|
||||
@ -159,9 +162,31 @@ data ServicesT (chn :: ServiceChain snm) (info :: Type)
|
||||
(s :: [Service snm mnm anm (TypeRef snm)])
|
||||
(m :: Type -> Type) (hs :: [[Type]]) where
|
||||
S0 :: ServicesT chn info '[] m '[]
|
||||
(:<&>:) :: HandlersT chn info (MappingRight chn sname) methods m hs
|
||||
(:<&>:) :: ServiceT chn info svc m hs
|
||||
-> ServicesT chn info rest m hss
|
||||
-> ServicesT chn info ('Service sname methods ': rest) m (hs ': hss)
|
||||
-> ServicesT chn info (svc ': rest) m (hs ': hss)
|
||||
|
||||
type family InUnion (x :: k) (xs :: [k]) :: Constraint where
|
||||
InUnion x '[] = TypeError ('ShowType x ':<>: 'Text " is not part of the union")
|
||||
InUnion x (x ': xs) = ()
|
||||
InUnion x (y ': xs) = InUnion x xs
|
||||
|
||||
data UnionChoice chn elts where
|
||||
UnionChoice :: (InUnion elt elts, Typeable elt)
|
||||
=> Proxy elt -> MappingRight chn elt
|
||||
-> UnionChoice chn elts
|
||||
|
||||
unionChoice :: forall elt elts chn.
|
||||
(InUnion elt elts, Typeable elt)
|
||||
=> MappingRight chn elt -> UnionChoice chn elts
|
||||
unionChoice = UnionChoice (Proxy @elt)
|
||||
|
||||
-- | Definition of different kinds of services.
|
||||
data ServiceT chn info svc m hs where
|
||||
ProperSvc :: HandlersT chn info (MappingRight chn sname) methods m hs
|
||||
-> ServiceT chn info ('Service sname methods) m hs
|
||||
OneOfSvc :: (MappingRight chn sname -> m (UnionChoice chn elts))
|
||||
-> ServiceT chn info ('OneOf sname elts) m '[]
|
||||
|
||||
-- | 'HandlersT' is a sequence of handlers.
|
||||
-- Note that the handlers for your service
|
||||
@ -322,6 +347,11 @@ object
|
||||
=> p -> Named sname (HandlersT chn info (MappingRight chn sname) ms m hs)
|
||||
object nl = Named $ toHandlers $ toNamedList nl
|
||||
|
||||
union :: forall sname chn m elts.
|
||||
(MappingRight chn sname -> m (UnionChoice chn elts))
|
||||
-> Named sname (MappingRight chn sname -> m (UnionChoice chn elts))
|
||||
union = Named
|
||||
|
||||
-- | 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':
|
||||
@ -412,7 +442,12 @@ instance ToServices chn info '[] m '[] 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
|
||||
toServices nl = ProperSvc (findService (Proxy @name) nl) :<&>: toServices nl
|
||||
instance ( FindService name (MappingRight chn name -> m (UnionChoice chn elts)) nl
|
||||
, ToServices chn info ss m hs nl)
|
||||
=> ToServices chn info ('OneOf name elts ': ss) m ('[] ': hs) nl where
|
||||
toServices nl = OneOfSvc (findService (Proxy @name) nl) :<&>: toServices nl
|
||||
|
||||
|
||||
class FindService name h nl | name nl -> h where
|
||||
findService :: Proxy name -> NamedList nl -> h
|
||||
|
@ -1 +1 @@
|
||||
Subproject commit 851f9522792e843f2e4b5e478cae6714b5cefd79
|
||||
Subproject commit b2cfb27c24d14fe51c0d7d13b602eb7584a9a598
|
@ -1,6 +1,7 @@
|
||||
{-# language CPP #-}
|
||||
{-# language DataKinds #-}
|
||||
{-# language FlexibleContexts #-}
|
||||
{-# language LambdaCase #-}
|
||||
{-# language OverloadedStrings #-}
|
||||
{-# language PartialTypeSignatures #-}
|
||||
{-# language PolyKinds #-}
|
||||
@ -52,9 +53,14 @@ main = do
|
||||
(Proxy @'Nothing)
|
||||
(Proxy @('Just "Subscription"))
|
||||
|
||||
data WritingMapping
|
||||
= ABook (Integer, Integer) | AnArticle (Integer, Integer)
|
||||
|
||||
type ServiceMapping = '[
|
||||
"Book" ':-> (Integer, Integer)
|
||||
, "Article" ':-> (Integer, Integer)
|
||||
, "Author" ':-> Integer
|
||||
, "Writing" ':-> WritingMapping
|
||||
]
|
||||
|
||||
library :: [(Integer, T.Text, [(Integer, (T.Text, Integer))])]
|
||||
@ -64,39 +70,54 @@ library
|
||||
, (3, "Michael Ende", [(4, ("The Neverending Story", 5)), (5, ("Momo", 3))])
|
||||
]
|
||||
|
||||
articles :: [(Integer, T.Text, [(Integer, (T.Text, Integer))])]
|
||||
articles
|
||||
= [ (1, "Fuencislo Robles", [(6, ("On Warm Chocolate", 4)), (2, ("On Cold Chocolate", 4))]) ]
|
||||
|
||||
libraryServer :: forall m i. (MonadServer m)
|
||||
=> ServerT ServiceMapping i ServiceDefinition m _
|
||||
libraryServer
|
||||
= resolver ( object @"Book" ( field @"id" bookId
|
||||
= resolver ( object @"Book" ( field @"id" bookOrArticleId
|
||||
, field @"title" bookTitle
|
||||
, field @"author" bookAuthor
|
||||
, field @"author" bookOrArticleAuthor
|
||||
, field @"info" bookInfo )
|
||||
, object @"Article" ( field @"id" bookOrArticleId
|
||||
, field @"title" articleTitle
|
||||
, field @"author" bookOrArticleAuthor )
|
||||
, object @"Author" ( field @"id" authorId
|
||||
, field @"name" authorName
|
||||
, field @"books" authorBooks )
|
||||
, field @"writings" authorBooks )
|
||||
, object @"Query" ( method @"author" findAuthor
|
||||
, method @"book" findBookTitle
|
||||
, method @"authors" allAuthors
|
||||
, method @"books" allBooks' )
|
||||
, object @"Subscription" ( method @"books" allBooksConduit )
|
||||
, union @"Writing" (\case (ABook x) -> pure $ unionChoice @"Book" x
|
||||
(AnArticle x) -> pure $ unionChoice @"Article" x)
|
||||
)
|
||||
where
|
||||
findBook i = find ((==i) . fst3) library
|
||||
findArticle i = find ((==i) . fst3) articles
|
||||
|
||||
bookId (_, bid) = pure bid
|
||||
bookOrArticleId (_, bid) = pure bid
|
||||
bookOrArticleAuthor (aid, _) = pure aid
|
||||
bookTitle (aid, bid) = pure $ fromMaybe "" $ do
|
||||
bk <- findBook aid
|
||||
ev <- lookup bid (thd3 bk)
|
||||
pure (fst ev)
|
||||
bookAuthor (aid, _) = pure aid
|
||||
bookInfo (aid, bid) = pure $ do
|
||||
bk <- findBook aid
|
||||
ev <- lookup bid (thd3 bk)
|
||||
pure $ JSON.object ["score" JSON..= snd ev]
|
||||
articleTitle (aid, bid) = pure $ fromMaybe "" $ do
|
||||
bk <- findArticle aid
|
||||
ev <- lookup bid (thd3 bk)
|
||||
pure (fst ev)
|
||||
|
||||
authorId = pure
|
||||
authorName aid = pure $ maybe "" snd3 (findBook aid)
|
||||
authorBooks aid = pure $ maybe [] (map ((aid,) . fst) . thd3) (findBook aid)
|
||||
authorBooks aid = pure $ maybe [] (map (ABook . (aid,) . fst) . thd3) (findBook aid)
|
||||
<> maybe [] (map (AnArticle . (aid,) . fst) . thd3) (findArticle aid)
|
||||
|
||||
findAuthor rx = pure $ listToMaybe
|
||||
[aid | (aid, name, _) <- library, name =~ rx]
|
||||
|
@ -5,10 +5,18 @@ type Book {
|
||||
info: JSON
|
||||
}
|
||||
|
||||
type Article {
|
||||
id: Int!
|
||||
title: String!
|
||||
author: Author!
|
||||
}
|
||||
|
||||
union Writing = Book | Article
|
||||
|
||||
type Author {
|
||||
id: Int!
|
||||
name: String!
|
||||
books: [Book!]!
|
||||
writings: [Writing!]!
|
||||
}
|
||||
|
||||
type Query {
|
||||
|
@ -1,5 +1,5 @@
|
||||
name: mu-graphql
|
||||
version: 0.4.1.1
|
||||
version: 0.5.0.0
|
||||
synopsis: GraphQL support for Mu
|
||||
description: GraphQL servers and clients for Mu-Haskell
|
||||
cabal-version: >=1.10
|
||||
@ -40,7 +40,7 @@ library
|
||||
, list-t >=1.0 && <2
|
||||
, megaparsec >=8 && <10
|
||||
, mtl >=2.2 && <2.3
|
||||
, mu-rpc >=0.4 && <0.5
|
||||
, mu-rpc >=0.5 && <0.6
|
||||
, mu-schema >=0.3 && <0.4
|
||||
, parsers >=0.12 && <0.13
|
||||
, scientific >=0.3 && <0.4
|
||||
@ -73,7 +73,7 @@ executable library-graphql
|
||||
, aeson >=1.4 && <2
|
||||
, conduit >=1.3.2 && <1.4
|
||||
, mu-graphql
|
||||
, mu-rpc >=0.4 && <0.5
|
||||
, mu-rpc >=0.5 && <0.6
|
||||
, mu-schema >=0.3 && <0.4
|
||||
, regex-tdfa >=1.3 && <2
|
||||
, text >=1.2 && <2
|
||||
|
@ -61,7 +61,8 @@ data GQLType =
|
||||
| Object
|
||||
| Scalar
|
||||
| InputObject
|
||||
| Other
|
||||
| Union
|
||||
| Interface
|
||||
|
||||
classifySchema :: [GQL.TypeSystemDefinition] -> SchemaMap
|
||||
classifySchema = foldl' schemaToMap HM.empty
|
||||
@ -81,9 +82,9 @@ classify = HM.fromList . (typeToKeyValue <$>)
|
||||
typeToKeyValue (GQL.ObjectTypeDefinition _ name _ _ _)
|
||||
= (name, Object)
|
||||
typeToKeyValue (GQL.InterfaceTypeDefinition _ name _ _)
|
||||
= (name, Other)
|
||||
= (name, Interface)
|
||||
typeToKeyValue (GQL.UnionTypeDefinition _ name _ _)
|
||||
= (name, Other)
|
||||
= (name, Union)
|
||||
typeToKeyValue (GQL.EnumTypeDefinition _ name _ _)
|
||||
= (name, Enum)
|
||||
typeToKeyValue (GQL.InputObjectTypeDefinition _ name _ _)
|
||||
@ -118,8 +119,11 @@ defaultDeclToTy (sn, (mn, (an, dv)))
|
||||
typeToDec :: Name -> TypeMap -> SchemaMap -> GQL.TypeDefinition -> Q Result
|
||||
typeToDec _ _ _ GQL.InterfaceTypeDefinition {}
|
||||
= fail "interface types are not supported"
|
||||
typeToDec _ _ _ GQL.UnionTypeDefinition {}
|
||||
= fail "union types are not supported"
|
||||
typeToDec _ _ _ (GQL.UnionTypeDefinition _ nm _ (GQL.UnionMemberTypes elts)) = do
|
||||
selts <- mapM textToStrLit elts
|
||||
GQLService <$> [t| 'OneOf $(textToStrLit nm)
|
||||
$(pure $ typesToList selts) |]
|
||||
<*> pure []
|
||||
typeToDec schemaName tm _ (GQL.ScalarTypeDefinition _ s _) =
|
||||
GQLScalar <$ gqlTypeToType s tm schemaName
|
||||
typeToDec schemaName tm sm (GQL.ObjectTypeDefinition _ nm _ _ flds) = do
|
||||
|
@ -8,6 +8,7 @@ module Mu.GraphQL.Query.Definition where
|
||||
import Data.SOP.NP
|
||||
import Data.SOP.NS
|
||||
import Data.Text
|
||||
import Data.Typeable
|
||||
import qualified Language.GraphQL.AST as GQL
|
||||
import Mu.Rpc
|
||||
import Mu.Schema
|
||||
@ -27,9 +28,12 @@ data Document (p :: Package snm mnm anm (TypeRef snm))
|
||||
=> OneMethodQuery ('Package pname ss) (LookupService ss sub)
|
||||
-> Document ('Package pname ss) qr mut ('Just sub)
|
||||
|
||||
type ServiceQuery (p :: Package snm mnm anm (TypeRef snm))
|
||||
(s :: Service snm mnm anm (TypeRef snm))
|
||||
= [OneMethodQuery p s]
|
||||
data ServiceQuery (p :: Package snm mnm anm (TypeRef snm))
|
||||
(s :: Service snm mnm anm (TypeRef snm)) where
|
||||
ServiceQuery :: [OneMethodQuery p ('Service nm ms)]
|
||||
-> ServiceQuery p ('Service nm ms)
|
||||
OneOfQuery :: NP (ChosenOneOfQuery p) elts
|
||||
-> ServiceQuery p ('OneOf nm elts)
|
||||
|
||||
data OneMethodQuery (p :: Package snm mnm anm (TypeRef snm))
|
||||
(s :: Service snm mnm anm (TypeRef snm)) where
|
||||
@ -40,17 +44,23 @@ data OneMethodQuery (p :: Package snm mnm anm (TypeRef snm))
|
||||
-- the special '__typename' field
|
||||
TypeNameQuery
|
||||
:: Maybe Text
|
||||
-> OneMethodQuery p ('Service nm ms)
|
||||
-> OneMethodQuery p s
|
||||
-- introspection fields
|
||||
SchemaQuery
|
||||
:: Maybe Text
|
||||
-> [GQL.Selection]
|
||||
-> OneMethodQuery p ('Service nm ms)
|
||||
-> OneMethodQuery p s
|
||||
TypeQuery
|
||||
:: Maybe Text
|
||||
-> Text
|
||||
-> [GQL.Selection]
|
||||
-> OneMethodQuery p ('Service nm ms)
|
||||
-> OneMethodQuery p s
|
||||
|
||||
data ChosenOneOfQuery p elt where
|
||||
ChosenOneOfQuery
|
||||
:: Typeable elt => Proxy elt
|
||||
-> ServiceQuery ('Package pname ss) (LookupService ss elt)
|
||||
-> ChosenOneOfQuery ('Package pname ss) elt
|
||||
|
||||
data ChosenMethodQuery (p :: Package snm mnm anm (TypeRef snm))
|
||||
(m :: Method snm mnm anm (TypeRef snm)) where
|
||||
|
@ -37,6 +37,7 @@ data Type
|
||||
, typeName :: Maybe T.Text
|
||||
, fields :: [Field]
|
||||
, enumValues :: [EnumValue]
|
||||
, possibleTypes :: [Type]
|
||||
, ofType :: Maybe Type
|
||||
}
|
||||
| TypeRef { to :: T.Text }
|
||||
@ -74,16 +75,16 @@ data TypeKind
|
||||
deriving Show
|
||||
|
||||
tSimple :: T.Text -> Type
|
||||
tSimple t = Type SCALAR (Just t) [] [] Nothing
|
||||
tSimple t = Type SCALAR (Just t) [] [] [] Nothing
|
||||
|
||||
tList :: Type -> Type
|
||||
tList = Type LIST Nothing [] [] . Just
|
||||
tList = Type LIST Nothing [] [] [] . Just
|
||||
|
||||
tNonNull :: Type -> Type
|
||||
tNonNull = Type NON_NULL Nothing [] [] . Just
|
||||
tNonNull = Type NON_NULL Nothing [] [] [] . Just
|
||||
|
||||
unwrapNonNull :: Type -> Maybe Type
|
||||
unwrapNonNull (Type NON_NULL _ _ _ x) = x
|
||||
unwrapNonNull (Type NON_NULL _ _ _ _ x) = x
|
||||
unwrapNonNull _ = Nothing
|
||||
|
||||
-- BUILD INTROSPECTION DATA
|
||||
@ -175,12 +176,32 @@ instance ( KnownSymbol sname
|
||||
introspectServices _ psub = do
|
||||
let name = T.pack $ symbolVal (Proxy @sname)
|
||||
fs <- introspectFields (Proxy @smethods) (Proxy @(IsSub sname sub))
|
||||
let t = Type OBJECT (Just name) fs [] Nothing
|
||||
let t = Type OBJECT (Just name) fs [] [] Nothing
|
||||
-- add this one to the mix
|
||||
tell (HM.singleton name t)
|
||||
-- continue with the rest
|
||||
introspectServices (Proxy @ss) psub
|
||||
|
||||
instance ( KnownSymbol sname, KnownSymbols elts
|
||||
, IntrospectServices ss sub )
|
||||
=> IntrospectServices ('OneOf sname elts ': ss) sub where
|
||||
introspectServices _ psub = do
|
||||
let name = T.pack $ symbolVal (Proxy @sname)
|
||||
tys = map tSimple (symbolsVal (Proxy @elts))
|
||||
t = Type UNION (Just name) [] [] tys Nothing
|
||||
-- add this one to the mix
|
||||
tell (HM.singleton name t)
|
||||
-- continue with the rest
|
||||
introspectServices (Proxy @ss) psub
|
||||
|
||||
class KnownSymbols (ss :: [Symbol]) where
|
||||
symbolsVal :: Proxy ss -> [T.Text]
|
||||
instance KnownSymbols '[] where
|
||||
symbolsVal _ = []
|
||||
instance (KnownSymbol s, KnownSymbols ss)
|
||||
=> KnownSymbols (s ': ss) where
|
||||
symbolsVal _ = T.pack (symbolVal (Proxy @s)) : symbolsVal (Proxy @ss)
|
||||
|
||||
class IntrospectFields (fs :: [Method']) (isSub :: Bool) where
|
||||
introspectFields
|
||||
:: Proxy fs -> Proxy isSub -> Writer TypeMap [Field]
|
||||
@ -292,7 +313,7 @@ instance (KnownSymbol name, IntrospectSchemaFields fields, IntrospectSchema ts)
|
||||
introspectSchema k suffix _ = do
|
||||
let name = T.pack (symbolVal (Proxy @name)) <> suffix
|
||||
fs = introspectSchemaFields suffix (Proxy @fields)
|
||||
t = Type k (Just name) fs [] Nothing
|
||||
t = Type k (Just name) fs [] [] Nothing
|
||||
-- add this one to the mix
|
||||
tell (HM.singleton name t)
|
||||
-- continue with the rest
|
||||
@ -302,7 +323,7 @@ instance (KnownSymbol name, IntrospectSchemaEnum choices, IntrospectSchema ts)
|
||||
introspectSchema k suffix _ = do
|
||||
let name = T.pack (symbolVal (Proxy @name)) <> suffix
|
||||
cs = introspectSchemaEnum (Proxy @choices)
|
||||
t = Type ENUM (Just name) [] cs Nothing
|
||||
t = Type ENUM (Just name) [] cs [] Nothing
|
||||
-- add this one to the mix
|
||||
tell (HM.singleton name t)
|
||||
-- continue with the rest
|
||||
|
@ -22,8 +22,8 @@ import Data.Int (Int32)
|
||||
import Data.List (find)
|
||||
import Data.Maybe
|
||||
import Data.Proxy
|
||||
import Data.Scientific (Scientific, floatingOrInteger, fromFloatDigits)
|
||||
import Data.SOP.NS
|
||||
import Data.Scientific (Scientific, floatingOrInteger, fromFloatDigits)
|
||||
import qualified Data.Text as T
|
||||
import GHC.TypeLits
|
||||
import qualified Language.GraphQL.AST as GQL
|
||||
@ -139,13 +139,14 @@ instance
|
||||
KnownName sub, ParseMethod p ('Service sub smethods) smethods
|
||||
) => ParseTypedDoc p ('Just qr) ('Just mut) ('Just sub) where
|
||||
parseTypedDocQuery vmap frmap sset
|
||||
= QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset
|
||||
= QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset
|
||||
parseTypedDocMutation vmap frmap sset
|
||||
= MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset
|
||||
= MutationDoc <$> parseQuery (Proxy @p) (Proxy @mut) vmap frmap sset
|
||||
parseTypedDocSubscription vmap frmap sset
|
||||
= do q <- parseQuery Proxy Proxy vmap frmap sset
|
||||
= do q <- parseQuery (Proxy @p) (Proxy @sub) vmap frmap sset
|
||||
case q of
|
||||
[one] -> pure $ SubscriptionDoc one
|
||||
ServiceQuery [one]
|
||||
-> pure $ SubscriptionDoc one
|
||||
_ -> throwError "subscriptions may only have one field"
|
||||
|
||||
instance
|
||||
@ -156,9 +157,9 @@ instance
|
||||
KnownName mut, ParseMethod p ('Service mut mmethods) mmethods
|
||||
) => ParseTypedDoc p ('Just qr) ('Just mut) 'Nothing where
|
||||
parseTypedDocQuery vmap frmap sset
|
||||
= QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset
|
||||
= QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset
|
||||
parseTypedDocMutation vmap frmap sset
|
||||
= MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset
|
||||
= MutationDoc <$> parseQuery (Proxy @p) (Proxy @mut) vmap frmap sset
|
||||
parseTypedDocSubscription _ _ _
|
||||
= throwError "no subscriptions are defined in the schema"
|
||||
|
||||
@ -170,13 +171,14 @@ instance
|
||||
KnownName sub, ParseMethod p ('Service sub smethods) smethods
|
||||
) => ParseTypedDoc p ('Just qr) 'Nothing ('Just sub) where
|
||||
parseTypedDocQuery vmap frmap sset
|
||||
= QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset
|
||||
= QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset
|
||||
parseTypedDocMutation _ _ _
|
||||
= throwError "no mutations are defined in the schema"
|
||||
parseTypedDocSubscription vmap frmap sset
|
||||
= do q <- parseQuery Proxy Proxy vmap frmap sset
|
||||
= do q <- parseQuery (Proxy @p) (Proxy @sub) vmap frmap sset
|
||||
case q of
|
||||
[one] -> pure $ SubscriptionDoc one
|
||||
ServiceQuery [one]
|
||||
-> pure $ SubscriptionDoc one
|
||||
_ -> throwError "subscriptions may only have one field"
|
||||
|
||||
instance
|
||||
@ -185,7 +187,7 @@ instance
|
||||
KnownName qr, ParseMethod p ('Service qr qmethods) qmethods
|
||||
) => ParseTypedDoc p ('Just qr) 'Nothing 'Nothing where
|
||||
parseTypedDocQuery vmap frmap sset
|
||||
= QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset
|
||||
= QueryDoc <$> parseQuery (Proxy @p) (Proxy @qr) vmap frmap sset
|
||||
parseTypedDocMutation _ _ _
|
||||
= throwError "no mutations are defined in the schema"
|
||||
parseTypedDocSubscription _ _ _
|
||||
@ -201,11 +203,12 @@ instance
|
||||
parseTypedDocQuery _ _ _
|
||||
= throwError "no queries are defined in the schema"
|
||||
parseTypedDocMutation vmap frmap sset
|
||||
= MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset
|
||||
= MutationDoc <$> parseQuery (Proxy @p) (Proxy @mut) vmap frmap sset
|
||||
parseTypedDocSubscription vmap frmap sset
|
||||
= do q <- parseQuery Proxy Proxy vmap frmap sset
|
||||
= do q <- parseQuery (Proxy @p) (Proxy @sub) vmap frmap sset
|
||||
case q of
|
||||
[one] -> pure $ SubscriptionDoc one
|
||||
ServiceQuery [one]
|
||||
-> pure $ SubscriptionDoc one
|
||||
_ -> throwError "subscriptions may only have one field"
|
||||
|
||||
instance
|
||||
@ -216,7 +219,7 @@ instance
|
||||
parseTypedDocQuery _ _ _
|
||||
= throwError "no queries are defined in the schema"
|
||||
parseTypedDocMutation vmap frmap sset
|
||||
= MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset
|
||||
= MutationDoc <$> parseQuery (Proxy @p) (Proxy @mut) vmap frmap sset
|
||||
parseTypedDocSubscription _ _ _
|
||||
= throwError "no subscriptions are defined in the schema"
|
||||
|
||||
@ -230,9 +233,10 @@ instance
|
||||
parseTypedDocMutation _ _ _
|
||||
= throwError "no mutations are defined in the schema"
|
||||
parseTypedDocSubscription vmap frmap sset
|
||||
= do q <- parseQuery Proxy Proxy vmap frmap sset
|
||||
= do q <- parseQuery (Proxy @p) (Proxy @sub) vmap frmap sset
|
||||
case q of
|
||||
[one] -> pure $ SubscriptionDoc one
|
||||
ServiceQuery [one]
|
||||
-> pure $ SubscriptionDoc one
|
||||
_ -> throwError "subscriptions may only have one field"
|
||||
|
||||
instance
|
||||
@ -263,23 +267,65 @@ constToValue (GQL.ConstObject n)
|
||||
[ GQL.ObjectField a (GQL.Node (constToValue v) m) l
|
||||
| GQL.ObjectField a (GQL.Node v m) l <- n ]
|
||||
|
||||
class ParseQuery (p :: Package') (s :: Symbol) where
|
||||
parseQuery
|
||||
:: ( MonadError T.Text f, p ~ 'Package pname ss )
|
||||
=> Proxy p -> Proxy s
|
||||
-> VariableMap -> FragmentMap -> [GQL.Selection]
|
||||
-> f (ServiceQuery p (LookupService ss s))
|
||||
|
||||
parseQuery ::
|
||||
forall (p :: Package') (s :: Symbol) pname ss methods f.
|
||||
( MonadError T.Text f, p ~ 'Package pname ss,
|
||||
LookupService ss s ~ 'Service s methods,
|
||||
KnownName s, ParseMethod p ('Service s methods) methods
|
||||
) =>
|
||||
Proxy p ->
|
||||
Proxy s ->
|
||||
VariableMap -> FragmentMap -> [GQL.Selection] ->
|
||||
f (ServiceQuery p (LookupService ss s))
|
||||
parseQuery _ _ _ _ [] = pure []
|
||||
parseQuery pp ps vmap frmap (GQL.FieldSelection fld : ss)
|
||||
= (++) <$> (maybeToList <$> fieldToMethod fld)
|
||||
<*> parseQuery pp ps vmap frmap ss
|
||||
instance ( p ~ 'Package pname ss
|
||||
, KnownName s
|
||||
, ParseQuery' p s (LookupService ss s) )
|
||||
=> ParseQuery p s where
|
||||
parseQuery pp ps = parseQuery' pp ps (Proxy @(LookupService ss s))
|
||||
|
||||
class ParseQuery' (p :: Package') (s :: Symbol) (svc :: Service') where
|
||||
parseQuery'
|
||||
:: ( MonadError T.Text f, p ~ 'Package pname ss
|
||||
, LookupService ss s ~ svc, KnownName s )
|
||||
=> Proxy p -> Proxy s -> Proxy svc
|
||||
-> VariableMap -> FragmentMap -> [GQL.Selection]
|
||||
-> f (ServiceQuery p svc)
|
||||
|
||||
instance (ParseQueryOneOf p elts)
|
||||
=> ParseQuery' p s ('OneOf s elts) where
|
||||
parseQuery' pp _ps _ vmap frmap fs
|
||||
= OneOfQuery <$> parseQueryOneOf pp (Proxy @elts) vmap frmap fs
|
||||
|
||||
class ParseQueryOneOf (p :: Package') (s :: [Symbol]) where
|
||||
parseQueryOneOf
|
||||
:: ( MonadError T.Text f, p ~ 'Package pname ss )
|
||||
=> Proxy p -> Proxy s
|
||||
-> VariableMap -> FragmentMap -> [GQL.Selection]
|
||||
-> f (NP (ChosenOneOfQuery p) s)
|
||||
|
||||
instance ParseQueryOneOf p '[] where
|
||||
parseQueryOneOf _ _ _ _ _ = pure Nil
|
||||
instance ( ParseQuery p s, KnownSymbol s
|
||||
, ParseQueryOneOf p ss)
|
||||
=> ParseQueryOneOf p (s ': ss) where
|
||||
parseQueryOneOf pp _ps vmap frmap sel
|
||||
= (:*) <$> (ChosenOneOfQuery (Proxy @s) <$> parseQuery pp (Proxy @s) vmap frmap sel)
|
||||
<*> parseQueryOneOf pp (Proxy @ss) vmap frmap sel
|
||||
|
||||
instance ( ParseMethod p ('Service s methods) methods )
|
||||
=> ParseQuery' p s ('Service s methods) where
|
||||
parseQuery' _pp _ps _psvc vmap frmap fs = ServiceQuery <$> go fs
|
||||
where
|
||||
fieldToMethod :: GQL.Field -> f (Maybe (OneMethodQuery p ('Service sname methods)))
|
||||
go [] = pure []
|
||||
go (GQL.FieldSelection fld : ss)
|
||||
= (++) <$> (maybeToList <$> fieldToMethod fld) <*> go ss
|
||||
go (GQL.FragmentSpreadSelection (GQL.FragmentSpread nm dirs _) : ss)
|
||||
| Just fr <- HM.lookup nm frmap
|
||||
= if not (any (shouldSkip vmap) dirs) && not (any (shouldSkip vmap) $ fdDirectives fr)
|
||||
then (++) <$> go (fdSelectionSet fr) <*> go ss
|
||||
else go ss
|
||||
| otherwise -- the fragment definition was not found
|
||||
= throwError $ "fragment '" <> nm <> "' was not found"
|
||||
go (_ : _) -- Inline fragments are not yet supported
|
||||
= throwError "inline fragments are not (yet) supported"
|
||||
-- fieldToMethod :: GQL.Field -> f (Maybe (OneMethodQuery p ('Service sname methods)))
|
||||
fieldToMethod f@(GQL.Field alias name args dirs sels _)
|
||||
| any (shouldSkip vmap) dirs
|
||||
= pure Nothing
|
||||
@ -306,16 +352,6 @@ parseQuery pp ps vmap frmap (GQL.FieldSelection fld : ss)
|
||||
<$> selectMethod (Proxy @('Service s methods))
|
||||
(T.pack $ nameVal (Proxy @s))
|
||||
vmap frmap f
|
||||
parseQuery pp ps vmap frmap (GQL.FragmentSpreadSelection (GQL.FragmentSpread nm dirs _) : ss)
|
||||
| Just fr <- HM.lookup nm frmap
|
||||
= if not (any (shouldSkip vmap) dirs) && not (any (shouldSkip vmap) $ fdDirectives fr)
|
||||
then (++) <$> parseQuery pp ps vmap frmap (fdSelectionSet fr)
|
||||
<*> parseQuery pp ps vmap frmap ss
|
||||
else parseQuery pp ps vmap frmap ss
|
||||
| otherwise -- the fragment definition was not found
|
||||
= throwError $ "fragment '" <> nm <> "' was not found"
|
||||
parseQuery _ _ _ _ (_ : _) -- Inline fragments are not yet supported
|
||||
= throwError "inline fragments are not (yet) supported"
|
||||
|
||||
shouldSkip :: VariableMap -> GQL.Directive -> Bool
|
||||
shouldSkip vmap (GQL.Directive nm [GQL.Argument ifn (GQL.Node v _) _] _)
|
||||
@ -362,7 +398,7 @@ instance ParseMethod p s '[] where
|
||||
selectMethod _ tyName _ _ (fName -> wanted)
|
||||
= throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'"
|
||||
instance
|
||||
( KnownSymbol mname, ParseMethod p s ms
|
||||
( KnownName mname, ParseMethod p s ms
|
||||
, ParseArgs p s ('Method mname args r) args
|
||||
, ParseDifferentReturn p r) =>
|
||||
ParseMethod p s ('Method mname args r ': ms)
|
||||
@ -713,10 +749,8 @@ instance ParseReturn p r
|
||||
=> ParseReturn p ('OptionalRef r) where
|
||||
parseReturn vmap frmap fname s
|
||||
= RetOptional <$> parseReturn vmap frmap fname s
|
||||
instance ( p ~ 'Package pname ss,
|
||||
LookupService ss s ~ 'Service s methods,
|
||||
KnownName s, ParseMethod p ('Service s methods) methods
|
||||
) => ParseReturn p ('ObjectRef s) where
|
||||
instance ( p ~ 'Package pname ss, ParseQuery p s )
|
||||
=> ParseReturn p ('ObjectRef s) where
|
||||
parseReturn vmap frmap _ s
|
||||
= RetObject <$> parseQuery (Proxy @p) (Proxy @s) vmap frmap s
|
||||
|
||||
@ -732,7 +766,7 @@ instance ParseSchema sch ('DEnum name choices) where
|
||||
= pure QueryEnum
|
||||
parseSchema _ _ fname _
|
||||
= throwError $ "field '" <> fname <> "' should not have a selection of subfields"
|
||||
instance (KnownSymbol name, ParseField sch fields)
|
||||
instance (KnownName name, ParseField sch fields)
|
||||
=> ParseSchema sch ('DRecord name fields) where
|
||||
parseSchema vmap frmap _ s
|
||||
= QueryRecord <$> parseSchemaQuery (Proxy @sch) (Proxy @('DRecord name fields)) vmap frmap s
|
||||
@ -741,7 +775,7 @@ parseSchemaQuery ::
|
||||
forall (sch :: Schema') t (rname :: Symbol) fields f.
|
||||
( MonadError T.Text f
|
||||
, t ~ 'DRecord rname fields
|
||||
, KnownSymbol rname
|
||||
, KnownName rname
|
||||
, ParseField sch fields ) =>
|
||||
Proxy sch ->
|
||||
Proxy t ->
|
||||
@ -790,7 +824,7 @@ instance ParseField sch '[] where
|
||||
selectField tyName _ _ wanted _
|
||||
= throwError $ "field '" <> wanted <> "' was not found on type '" <> tyName <> "'"
|
||||
instance
|
||||
(KnownSymbol fname, ParseField sch fs, ParseSchemaReturn sch r) =>
|
||||
(KnownName fname, ParseField sch fs, ParseSchemaReturn sch r) =>
|
||||
ParseField sch ('FieldDef fname r ': fs)
|
||||
where
|
||||
selectField tyName vmap frmap wanted sels
|
||||
|
@ -11,6 +11,7 @@
|
||||
{-# language ScopedTypeVariables #-}
|
||||
{-# language TupleSections #-}
|
||||
{-# language TypeApplications #-}
|
||||
{-# language TypeFamilies #-}
|
||||
{-# language TypeOperators #-}
|
||||
{-# language UndecidableInstances #-}
|
||||
{-# OPTIONS_GHC -fprint-explicit-foralls #-}
|
||||
@ -36,9 +37,11 @@ import Data.Conduit.TQueue
|
||||
import qualified Data.HashMap.Strict as HM
|
||||
import Data.Maybe
|
||||
import qualified Data.Text as T
|
||||
import Data.Typeable
|
||||
import GHC.TypeLits
|
||||
import qualified Language.GraphQL.AST as GQL
|
||||
import Network.HTTP.Types.Header
|
||||
import Unsafe.Coerce (unsafeCoerce)
|
||||
|
||||
import Mu.GraphQL.Query.Definition
|
||||
import qualified Mu.GraphQL.Query.Introspection as Intro
|
||||
@ -233,11 +236,10 @@ yieldDocument f req svr doc sink = do
|
||||
runConduit $ yieldMany ([val] :: [Aeson.Value]) .| sink
|
||||
|
||||
runQuery
|
||||
:: forall m p s pname ss hs sname ms chn inh.
|
||||
:: forall m p s pname ss hs chn inh.
|
||||
( RunQueryFindHandler m p hs chn ss s hs
|
||||
, p ~ 'Package pname ss
|
||||
, s ~ 'Service sname ms
|
||||
, inh ~ MappingRight chn sname )
|
||||
, inh ~ MappingRight chn (ServiceName s) )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> RequestHeaders
|
||||
-> Intro.Schema -> ServerT chn GQL.Field p m hs
|
||||
@ -248,11 +250,10 @@ runQuery
|
||||
runQuery f req sch whole@(Services ss) path = runQueryFindHandler f req sch whole path ss
|
||||
|
||||
runSubscription
|
||||
:: forall m p s pname ss hs sname ms chn inh.
|
||||
:: forall m p s pname ss hs chn inh.
|
||||
( RunQueryFindHandler m p hs chn ss s hs
|
||||
, p ~ 'Package pname ss
|
||||
, s ~ 'Service sname ms
|
||||
, inh ~ MappingRight chn sname )
|
||||
, inh ~ MappingRight chn (ServiceName s) )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> RequestHeaders
|
||||
-> ServerT chn GQL.Field p m hs
|
||||
@ -267,8 +268,7 @@ runSubscription f req whole@(Services ss) path
|
||||
class RunQueryFindHandler m p whole chn ss s hs where
|
||||
runQueryFindHandler
|
||||
:: ( p ~ 'Package pname wholess
|
||||
, s ~ 'Service sname ms
|
||||
, inh ~ MappingRight chn sname )
|
||||
, inh ~ MappingRight chn (ServiceName s) )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> RequestHeaders
|
||||
-> Intro.Schema -> ServerT chn GQL.Field p m whole
|
||||
@ -279,8 +279,7 @@ class RunQueryFindHandler m p whole chn ss s hs where
|
||||
-> WriterT [GraphQLError] IO Aeson.Value
|
||||
runSubscriptionFindHandler
|
||||
:: ( p ~ 'Package pname wholess
|
||||
, s ~ 'Service sname ms
|
||||
, inh ~ MappingRight chn sname )
|
||||
, inh ~ MappingRight chn (ServiceName s) )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> RequestHeaders
|
||||
-> ServerT chn GQL.Field p m whole
|
||||
@ -291,6 +290,32 @@ class RunQueryFindHandler m p whole chn ss s hs where
|
||||
-> ConduitT Aeson.Value Void IO ()
|
||||
-> IO ()
|
||||
|
||||
class RunQueryOnFoundHandler m p whole chn (s :: Service snm mnm anm (TypeRef snm)) hs where
|
||||
type ServiceName s :: snm
|
||||
runQueryOnFoundHandler
|
||||
:: ( p ~ 'Package pname wholess
|
||||
, inh ~ MappingRight chn (ServiceName s) )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> RequestHeaders
|
||||
-> Intro.Schema -> ServerT chn GQL.Field p m whole
|
||||
-> [T.Text]
|
||||
-> ServiceT chn GQL.Field s m hs
|
||||
-> inh
|
||||
-> ServiceQuery p s
|
||||
-> WriterT [GraphQLError] IO Aeson.Value
|
||||
runSubscriptionOnFoundHandler
|
||||
:: ( p ~ 'Package pname wholess
|
||||
, inh ~ MappingRight chn (ServiceName s) )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> RequestHeaders
|
||||
-> ServerT chn GQL.Field p m whole
|
||||
-> [T.Text]
|
||||
-> ServiceT chn GQL.Field s m hs
|
||||
-> inh
|
||||
-> OneMethodQuery p s
|
||||
-> ConduitT Aeson.Value Void IO ()
|
||||
-> IO ()
|
||||
|
||||
instance TypeError ('Text "Could not find handler for " ':<>: 'ShowType s)
|
||||
=> RunQueryFindHandler m p whole chn '[] s '[] where
|
||||
runQueryFindHandler _ = error "this should never be called"
|
||||
@ -302,17 +327,24 @@ instance {-# OVERLAPPABLE #-}
|
||||
= runQueryFindHandler f req sch whole path that
|
||||
runSubscriptionFindHandler f req whole path (_ :<&>: that)
|
||||
= runSubscriptionFindHandler f req whole path that
|
||||
instance {-# OVERLAPS #-}
|
||||
( s ~ 'Service sname ms, KnownName sname
|
||||
, RunMethod m p whole chn s ms h )
|
||||
instance {-# OVERLAPS #-}
|
||||
(RunQueryOnFoundHandler m p whole chn s h)
|
||||
=> RunQueryFindHandler m p whole chn (s ': ss) s (h ': hs) where
|
||||
runQueryFindHandler f req sch whole path (this :<&>: _) inh queries
|
||||
runQueryFindHandler f req sch whole path (s :<&>: _)
|
||||
= runQueryOnFoundHandler f req sch whole path s
|
||||
runSubscriptionFindHandler f req whole path (s :<&>: _)
|
||||
= runSubscriptionOnFoundHandler f req whole path s
|
||||
|
||||
instance ( KnownName sname, RunMethod m p whole chn ('Service sname ms) ms h )
|
||||
=> RunQueryOnFoundHandler m p whole chn ('Service sname ms) h where
|
||||
type ServiceName ('Service sname ms) = sname
|
||||
runQueryOnFoundHandler f req sch whole path (ProperSvc this) inh (ServiceQuery queries)
|
||||
= Aeson.object . catMaybes <$> mapM runOneQuery queries
|
||||
where
|
||||
-- if we include the signature we have to write
|
||||
-- an explicit type signature for 'runQueryFindHandler'
|
||||
runOneQuery (OneMethodQuery nm args)
|
||||
= runMethod f req whole (Proxy @s) path nm inh this args
|
||||
= runMethod f req whole (Proxy @('Service sname ms)) path nm inh this args
|
||||
-- handle __typename
|
||||
runOneQuery (TypeNameQuery nm)
|
||||
= let realName = fromMaybe "__typename" nm
|
||||
@ -333,23 +365,59 @@ instance {-# OVERLAPS #-}
|
||||
path]
|
||||
pure $ Just (realName, Aeson.Null)
|
||||
-- subscriptions should only have one element
|
||||
runSubscriptionFindHandler f req whole path (this :<&>: _) inh (OneMethodQuery nm args) sink
|
||||
= runMethodSubscription f req whole (Proxy @s) path nm inh this args sink
|
||||
runSubscriptionFindHandler _ _ _ _ _ _ (TypeNameQuery nm) sink
|
||||
runSubscriptionOnFoundHandler f req whole path (ProperSvc this) inh (OneMethodQuery nm args) sink
|
||||
= runMethodSubscription f req whole (Proxy @('Service sname ms)) path nm inh this args sink
|
||||
runSubscriptionOnFoundHandler _ _ _ _ _ _ (TypeNameQuery nm) sink
|
||||
= let realName = fromMaybe "__typename" nm
|
||||
o = Aeson.object [(realName, Aeson.String $ T.pack $ nameVal (Proxy @sname))]
|
||||
in runConduit $ yieldMany ([o] :: [Aeson.Value]) .| sink
|
||||
runSubscriptionFindHandler _ _ _ _ _ _ _ sink
|
||||
runSubscriptionOnFoundHandler _ _ _ _ _ _ _ sink
|
||||
= runConduit $ yieldMany
|
||||
([singleErrValue "__schema and __type are not supported in subscriptions"]
|
||||
:: [Aeson.Value])
|
||||
.| sink
|
||||
|
||||
instance ( KnownName sname, RunUnion m p whole chn elts )
|
||||
=> RunQueryOnFoundHandler m p whole chn ('OneOf sname elts) h where
|
||||
type ServiceName ('OneOf sname elts) = sname
|
||||
runQueryOnFoundHandler f req sch whole path (OneOfSvc this) inh (OneOfQuery queries)
|
||||
= do res <- liftIO $ runExceptT $ f $ this inh
|
||||
case res of
|
||||
Left e -> tell [GraphQLError e path] >> pure Aeson.Null
|
||||
Right x -> runUnion f req sch whole path queries x
|
||||
runSubscriptionOnFoundHandler _ _ _ _ (OneOfSvc _) _ _ _
|
||||
= error "this should never happen"
|
||||
|
||||
class RunUnion m p whole chn elts where
|
||||
runUnion
|
||||
:: (forall a. m a -> ServerErrorIO a)
|
||||
-> RequestHeaders
|
||||
-> Intro.Schema -> ServerT chn GQL.Field p m whole
|
||||
-> [T.Text]
|
||||
-> NP (ChosenOneOfQuery p) elts
|
||||
-> UnionChoice chn elts
|
||||
-> WriterT [GraphQLError] IO Aeson.Value
|
||||
|
||||
instance RunUnion m p whole chn '[] where
|
||||
runUnion _ = error "this should never happen"
|
||||
instance forall m p pname s sname whole ss chn elts.
|
||||
( RunQueryFindHandler m p whole chn ss s whole
|
||||
, p ~ 'Package pname ss
|
||||
, s ~ LookupService ss sname
|
||||
, ServiceName s ~ sname
|
||||
, RunUnion m p whole chn elts )
|
||||
=> RunUnion m p whole chn (sname ': elts) where
|
||||
runUnion f req sch whole path
|
||||
(ChosenOneOfQuery (Proxy :: Proxy sname) q :* rest)
|
||||
choice@(UnionChoice (Proxy :: Proxy other) v)
|
||||
= case eqT @sname @other of
|
||||
Nothing -> runUnion f req sch whole path rest (unsafeCoerce choice)
|
||||
Just Refl -> runQuery @m @('Package pname ss) @(LookupService ss sname) @pname @ss @whole f req sch whole path v q
|
||||
|
||||
class RunMethod m p whole chn s ms hs where
|
||||
runMethod
|
||||
:: ( p ~ 'Package pname wholess
|
||||
, s ~ 'Service sname allMs
|
||||
, inh ~ MappingRight chn sname )
|
||||
, inh ~ MappingRight chn (ServiceName s) )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> RequestHeaders
|
||||
-> ServerT chn GQL.Field p m whole
|
||||
@ -359,8 +427,7 @@ class RunMethod m p whole chn s ms hs where
|
||||
-> WriterT [GraphQLError] IO (Maybe (T.Text, Aeson.Value))
|
||||
runMethodSubscription
|
||||
:: ( p ~ 'Package pname wholess
|
||||
, s ~ 'Service sname allMs
|
||||
, inh ~ MappingRight chn sname )
|
||||
, inh ~ MappingRight chn (ServiceName s) )
|
||||
=> (forall a. m a -> ServerErrorIO a)
|
||||
-> RequestHeaders
|
||||
-> ServerT chn GQL.Field p m whole
|
||||
@ -385,6 +452,7 @@ instance ( RunMethod m p whole chn s ms hs
|
||||
rpcInfo = reflectRpcInfo (Proxy @p) (Proxy @s) (Proxy @('Method mname args r)) req fld
|
||||
runMethod f req whole p path nm inh (_ :<||>: r) (S cont)
|
||||
= runMethod f req whole p path nm inh r cont
|
||||
runMethod _ _ _ _ _ _ _ _ _ = error "this should never happen"
|
||||
-- handle subscriptions
|
||||
runMethodSubscription f req whole _ path nm inh (h :<||>: _) (Z (ChosenMethodQuery fld args ret)) sink
|
||||
= runHandlerSubscription f req whole (path ++ [realName]) (h rpcInfo inh) args ret sink
|
||||
@ -392,6 +460,7 @@ instance ( RunMethod m p whole chn s ms hs
|
||||
rpcInfo = reflectRpcInfo (Proxy @p) (Proxy @s) (Proxy @('Method mname args r)) req fld
|
||||
runMethodSubscription f req whole p path nm inh (_ :<||>: r) (S cont) sink
|
||||
= runMethodSubscription f req whole p path nm inh r cont sink
|
||||
runMethodSubscription _ _ _ _ _ _ _ _ _ _ = error "this should never happen"
|
||||
|
||||
class Handles chn args r m h
|
||||
=> RunHandler m p whole chn args r h where
|
||||
@ -518,9 +587,9 @@ instance ( ToSchema sch l r
|
||||
convertResult _ _ _ _ (RetSchema r) t
|
||||
= pure $ Just $ runSchemaQuery (toSchema' @_ @_ @sch @r t) r
|
||||
instance ( MappingRight chn ref ~ t
|
||||
, MappingRight chn sname ~ t
|
||||
, LookupService ss ref ~ 'Service sname ms
|
||||
, RunQueryFindHandler m ('Package pname ss) whole chn ss ('Service sname ms) whole)
|
||||
, MappingRight chn (ServiceName svc) ~ t
|
||||
, LookupService ss ref ~ svc
|
||||
, RunQueryFindHandler m ('Package pname ss) whole chn ss svc whole)
|
||||
=> ResultConversion m ('Package pname ss) whole chn ('ObjectRef ref) t where
|
||||
convertResult f req whole path (RetObject q) h
|
||||
= Just <$> runQuery @m @('Package pname ss) @(LookupService ss ref) f req
|
||||
@ -643,7 +712,7 @@ runIntroType path s@(Intro.Schema _ _ _ ts) (Intro.TypeRef t) ss
|
||||
= case HM.lookup t ts of
|
||||
Nothing -> pure Nothing
|
||||
Just ty -> runIntroType path s ty ss
|
||||
runIntroType path s (Intro.Type k tnm fs vals ofT) ss
|
||||
runIntroType path s (Intro.Type k tnm fs vals posTys ofT) ss
|
||||
= do things <- catMaybes <$> traverse runOne ss
|
||||
pure $ Just $ Aeson.object things
|
||||
where
|
||||
@ -683,7 +752,12 @@ runIntroType path s (Intro.Type k tnm fs vals ofT) ss
|
||||
("interfaces", _)
|
||||
-> pure $ Just $ Aeson.Array []
|
||||
("possibleTypes", _)
|
||||
-> pure $ Just $ Aeson.Array []
|
||||
-> case k of
|
||||
Intro.UNION
|
||||
-> do res <- catMaybes <$>
|
||||
mapM (\o -> runIntroType path' s o innerss) posTys
|
||||
pure $ Just $ Aeson.toJSON res
|
||||
_ -> pure $ Just Aeson.Null
|
||||
|
||||
_ -> do tell [GraphQLError
|
||||
(ServerError Invalid
|
||||
|
@ -41,7 +41,7 @@ library
|
||||
, mu-grpc-common >=0.4 && <0.5
|
||||
, mu-optics >=0.3 && <0.4
|
||||
, mu-protobuf >=0.4 && <0.5
|
||||
, mu-rpc >=0.4 && <0.5
|
||||
, mu-rpc >=0.4 && <0.6
|
||||
, mu-schema >=0.3 && <0.4
|
||||
, optics-core >=0.2 && <0.4
|
||||
, sop-core >=0.5 && <0.6
|
||||
|
@ -33,7 +33,7 @@ library
|
||||
, http2-grpc-types >=0.5 && <0.6
|
||||
, mu-avro >=0.4 && <0.5
|
||||
, mu-protobuf >=0.4 && <0.5
|
||||
, mu-rpc >=0.4 && <0.5
|
||||
, mu-rpc >=0.4 && <0.6
|
||||
, mu-schema >=0.3 && <0.4
|
||||
|
||||
hs-source-dirs: src
|
||||
|
@ -1,5 +1,5 @@
|
||||
name: mu-grpc-server
|
||||
version: 0.4.0.0
|
||||
version: 0.5.0.0
|
||||
synopsis: gRPC servers for Mu definitions
|
||||
description:
|
||||
With @mu-grpc-server@ you can easily build gRPC servers for mu-haskell!
|
||||
@ -33,7 +33,7 @@ library
|
||||
, mtl >=2.2 && <3
|
||||
, mu-grpc-common >=0.4 && <0.5
|
||||
, mu-protobuf >=0.4 && <0.5
|
||||
, mu-rpc >=0.4 && <0.5
|
||||
, mu-rpc >=0.5 && <0.6
|
||||
, mu-schema >=0.3 && <0.4
|
||||
, sop-core >=0.5 && <0.6
|
||||
, stm >=2.5 && <3
|
||||
@ -59,9 +59,9 @@ executable grpc-example-server
|
||||
, http2-grpc-types >=0.5 && <0.6
|
||||
, mtl >=2.2 && <3
|
||||
, mu-grpc-common >=0.4 && <0.5
|
||||
, mu-grpc-server >=0.4 && <0.5
|
||||
, mu-grpc-server
|
||||
, mu-protobuf >=0.4 && <0.5
|
||||
, mu-rpc >=0.4 && <0.5
|
||||
, mu-rpc >=0.5 && <0.6
|
||||
, mu-schema >=0.3 && <0.4
|
||||
, sop-core >=0.5 && <0.6
|
||||
, stm >=2.5 && <3
|
||||
|
@ -47,6 +47,7 @@ import Data.Conduit
|
||||
import Data.Conduit.TMChan
|
||||
import Data.Kind
|
||||
import Data.Proxy
|
||||
import GHC.TypeLits
|
||||
import Network.GRPC.HTTP2.Encoding (GRPCInput, GRPCOutput, gzip, uncompressed)
|
||||
import Network.GRPC.HTTP2.Types (GRPCStatus (..), GRPCStatusCode (..))
|
||||
import Network.GRPC.Server.Handlers.Trans
|
||||
@ -174,12 +175,15 @@ instance ( KnownName name
|
||||
p m chn (MappingRight chn name) methods h
|
||||
, GRpcServiceHandlers fullP p m chn rest hs )
|
||||
=> GRpcServiceHandlers fullP p m chn ('Service name methods ': rest) (h ': hs) where
|
||||
gRpcServiceHandlers f pfullP pr packageName (svr :<&>: rest)
|
||||
gRpcServiceHandlers f pfullP pr packageName (ProperSvc svr :<&>: rest)
|
||||
= gRpcMethodHandlers f pfullP (Proxy @('Service name methods)) pr
|
||||
packageName serviceName svr
|
||||
++ gRpcServiceHandlers f pfullP pr packageName rest
|
||||
where serviceName = BS.pack (nameVal (Proxy @name))
|
||||
|
||||
instance ( GHC.TypeLits.TypeError ('Text "unions are not supported in gRPC") )
|
||||
=> GRpcServiceHandlers fullP p m chn ('OneOf name methods ': rest) hs where
|
||||
gRpcServiceHandlers _ = error "unions are not supported in gRPC"
|
||||
|
||||
class GRpcMethodHandlers (fullP :: Package snm mnm anm (TypeRef snm))
|
||||
(fullS :: Service snm mnm anm (TypeRef snm))
|
||||
|
@ -1,5 +1,5 @@
|
||||
name: mu-prometheus
|
||||
version: 0.4.0.0
|
||||
version: 0.5.0.0
|
||||
synopsis: Metrics support for Mu using Prometheus
|
||||
description: Get metrics of your running Mu servers using Prometheus
|
||||
license: Apache-2.0
|
||||
@ -23,7 +23,7 @@ library
|
||||
base >=4.12 && <5
|
||||
, lifted-base >=0.2 && <0.3
|
||||
, monad-control >1 && <2
|
||||
, mu-rpc >=0.4 && <0.5
|
||||
, mu-rpc >=0.5 && <0.6
|
||||
, prometheus-client >1 && <2
|
||||
, text >=1.2 && <2
|
||||
, wai >=3.2 && <4
|
||||
|
@ -49,17 +49,23 @@ prometheusMetrics :: forall m a info. (MonadBaseControl IO m, MonadMonitor m)
|
||||
prometheusMetrics metrics NoRpcInfo run = do
|
||||
incGauge (activeCalls metrics)
|
||||
run `finally` decGauge (activeCalls metrics)
|
||||
prometheusMetrics metrics (RpcInfo _pkg (Service sname _) (Method mname _ _) _ _) run = do
|
||||
prometheusMetrics metrics (RpcInfo _pkg ss mm _ _) run = do
|
||||
let sname' = case ss of
|
||||
Service sname _ -> sname
|
||||
OneOf sname _ -> sname
|
||||
mname' = case mm of
|
||||
Just (Method mname _ _) -> mname
|
||||
Nothing -> "<noname>"
|
||||
incGauge (activeCalls metrics)
|
||||
withLabel (messagesReceived metrics) (sname, mname) incCounter
|
||||
withLabel (messagesReceived metrics) (sname', mname') incCounter
|
||||
( do -- We are forced to use a MVar because 'withLabel' only allows IO ()
|
||||
r <- liftBaseWith $ \runInIO -> do
|
||||
result :: MVar (StM m a) <- newEmptyMVar
|
||||
withLabel (callsTotal metrics) (sname, mname) $ \h ->
|
||||
withLabel (callsTotal metrics) (sname', mname') $ \h ->
|
||||
h `observeDuration` (runInIO run >>= putMVar result)
|
||||
takeMVar result
|
||||
x <- restoreM r
|
||||
withLabel (messagesSent metrics) (sname, mname) incCounter
|
||||
withLabel (messagesSent metrics) (sname', mname') incCounter
|
||||
pure x )
|
||||
`finally` decGauge (activeCalls metrics)
|
||||
|
||||
|
@ -1,5 +1,5 @@
|
||||
name: mu-servant-server
|
||||
version: 0.4.0.0
|
||||
version: 0.5.0.0
|
||||
synopsis: Servant servers for Mu definitions
|
||||
description:
|
||||
With @mu-servant-server@ you can easily build Servant servers for mu-haskell!
|
||||
@ -30,7 +30,7 @@ library
|
||||
, generic-aeson >=0.2 && <0.3
|
||||
, ghc-prim >=0.5 && <0.7
|
||||
, mtl >=2.2 && <3
|
||||
, mu-rpc >=0.4 && <0.5
|
||||
, mu-rpc >=0.5 && <0.6
|
||||
, mu-schema >=0.3 && <0.4
|
||||
, servant >=0.16 && <0.19
|
||||
, servant-server >=0.16 && <0.19
|
||||
@ -49,7 +49,7 @@ executable servant-example-server
|
||||
aeson >=1.4 && <2
|
||||
, base >=4.12 && <5
|
||||
, conduit >=1.3.2 && <2
|
||||
, mu-rpc >=0.4 && <0.5
|
||||
, mu-rpc >=0.5 && <0.6
|
||||
, mu-schema >=0.3 && <0.4
|
||||
, mu-servant-server
|
||||
, servant-server >=0.16 && <0.19
|
||||
|
@ -47,10 +47,10 @@ import qualified Data.ByteString.Lazy.UTF8 as LB8
|
||||
import Data.Conduit.Internal (ConduitT (..), Pipe (..))
|
||||
import Data.Kind
|
||||
import Data.Swagger (Swagger, ToSchema (..))
|
||||
import Generics.Generic.Aeson
|
||||
import GHC.Generics
|
||||
import GHC.TypeLits
|
||||
import GHC.Types (Any)
|
||||
import Generics.Generic.Aeson
|
||||
import Mu.Rpc
|
||||
import Mu.Rpc.Annotations
|
||||
import Mu.Schema
|
||||
@ -170,10 +170,16 @@ instance
|
||||
type
|
||||
ServicesAPI pkg ('Service sname methods ': rest) (hs ': hss) =
|
||||
MethodsAPI pkg sname methods hs :<|> ServicesAPI pkg rest hss
|
||||
servantServiceHandlers f pkgP (svr :<&>: rest) =
|
||||
servantServiceHandlers f pkgP (ProperSvc svr :<&>: rest) =
|
||||
servantMethodHandlers f pkgP (Proxy @sname) svr
|
||||
:<|> servantServiceHandlers f pkgP rest
|
||||
|
||||
instance (TypeError ('Text "unions are not supported by Servant servers"))
|
||||
=> ServantServiceHandlers pkg m chn ('OneOf sname methods ': rest) hs where
|
||||
type ServicesAPI pkg ('OneOf sname methods ': rest) hs =
|
||||
TypeError ('Text "unions are not supported by Servant servers")
|
||||
servantServiceHandlers _ = error "unions are not supported by Servant servers"
|
||||
|
||||
class
|
||||
ServantMethodHandlers
|
||||
(pkg :: Package Symbol Symbol anm (TypeRef Symbol))
|
||||
|
Loading…
Reference in New Issue
Block a user