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