Skip to content
This repository was archived by the owner on Oct 19, 2024. It is now read-only.

Commit b763d4f

Browse files
serrasserras
authored
Unions in GraphQL (#270)
1 parent 4cd6560 commit b763d4f

File tree

23 files changed

+456
-198
lines changed

23 files changed

+456
-198
lines changed

‎adapter/avro/mu-avro.cabal

+1-1
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,7 @@ library
3838
, containers >=0.6 && <0.7
3939
, deepseq >=1.4 && <2
4040
, language-avro >=0.1.3 && <0.2
41-
, mu-rpc >=0.4 && <0.5
41+
, mu-rpc >=0.4 && <0.6
4242
, mu-schema >=0.3 && <0.4
4343
, sop-core >=0.5.0 && <0.6
4444
, tagged >=0.8.6 && <0.9

‎adapter/protobuf/mu-protobuf.cabal

+1-1
Original file line numberDiff line numberDiff line change
@@ -38,7 +38,7 @@ library
3838
, http-client >=0.6 && <0.7
3939
, http2-grpc-proto3-wire >=0.1 && <0.2
4040
, language-protobuf >=1.0.1 && <2
41-
, mu-rpc >=0.4 && <0.5
41+
, mu-rpc >=0.4 && <0.6
4242
, mu-schema >=0.3 && <0.4
4343
, proto3-wire >=1.1 && <2
4444
, servant-client-core >=0.16 && <0.19

‎core/rpc/mu-rpc.cabal

+1-1
Original file line numberDiff line numberDiff line change
@@ -1,5 +1,5 @@
11
name: mu-rpc
2-
version: 0.4.0.1
2+
version: 0.5.0.0
33
synopsis: Protocol-independent declaration of services and servers.
44
description:
55
Protocol-independent declaration of services and servers for mu-haskell.

‎core/rpc/src/Mu/Rpc.hs

+29-7
Original file line numberDiff line numberDiff line change
@@ -20,7 +20,7 @@ and protocol.
2020
-}
2121
module Mu.Rpc (
2222
Package', Package(..)
23-
, Service', Service(..), Object
23+
, Service', Service(..), Object, Union
2424
, Method', Method(..), ObjectField
2525
, LookupService, LookupMethod
2626
, TypeRef(..), Argument', Argument(..), Return(..)
@@ -56,6 +56,7 @@ data Package serviceName methodName argName tyRef
5656
data Service serviceName methodName argName tyRef
5757
= Service serviceName
5858
[Method serviceName methodName argName tyRef]
59+
| OneOf serviceName [serviceName]
5960

6061
-- | A method is defined by its name, arguments, and return type.
6162
data Method serviceName methodName argName tyRef
@@ -66,6 +67,8 @@ data Method serviceName methodName argName tyRef
6667
-- Synonyms for GraphQL
6768
-- | An object is a set of fields, in GraphQL lingo.
6869
type Object = 'Service
70+
-- | A union is one of the objects.
71+
type Union = 'OneOf
6972
-- | A field in an object takes some input objects,
7073
-- and returns a value or some other object,
7174
-- in GraphQL lingo.
@@ -76,6 +79,7 @@ type family LookupService (ss :: [Service snm mnm anm tr]) (s :: snm)
7679
:: Service snm mnm anm tr where
7780
LookupService '[] s = TypeError ('Text "could not find method " ':<>: 'ShowType s)
7881
LookupService ('Service s ms ': ss) s = 'Service s ms
82+
LookupService ('OneOf s ms ': ss) s = 'OneOf s ms
7983
LookupService (other ': ss) s = LookupService ss s
8084

8185
-- | Look up a method in a service definition using its name.
@@ -136,7 +140,7 @@ data RpcInfo i
136140
= NoRpcInfo
137141
| RpcInfo { packageInfo :: Package Text Text Text TyInfo
138142
, serviceInfo :: Service Text Text Text TyInfo
139-
, methodInfo :: Method Text Text Text TyInfo
143+
, methodInfo :: Maybe (Method Text Text Text TyInfo)
140144
, headers :: RequestHeaders
141145
, extraInfo :: i
142146
}
@@ -150,10 +154,15 @@ data TyInfo
150154
instance Show (RpcInfo i) where
151155
show NoRpcInfo
152156
= "<no info>"
153-
show (RpcInfo (Package Nothing _) (Service s _) (Method m _ _) _ _)
154-
= T.unpack (s <> ":" <> m)
155-
show (RpcInfo (Package (Just p) _) (Service s _) (Method m _ _) _ _)
156-
= T.unpack (p <> ":" <> s <> ":" <> m)
157+
show (RpcInfo (Package p _) s m _ _)
158+
= T.unpack $ showPkg p (showMth m (showSvc s))
159+
where
160+
showPkg Nothing = id
161+
showPkg (Just pkg) = ((pkg <> ":") <>)
162+
showMth Nothing = id
163+
showMth (Just (Method mt _ _)) = (<> (":" <> mt))
164+
showSvc (Service sv _) = sv
165+
showSvc (OneOf sv _) = sv
157166

158167
class ReflectRpcInfo (p :: Package') (s :: Service') (m :: Method') where
159168
reflectRpcInfo :: Proxy p -> Proxy s -> Proxy m -> RequestHeaders -> i -> RpcInfo i
@@ -175,6 +184,13 @@ instance KnownMaySymbol 'Nothing where
175184
instance (KnownSymbol s) => KnownMaySymbol ('Just s) where
176185
maySymbolVal _ = Just $ T.pack $ symbolVal (Proxy @s)
177186

187+
class KnownSymbols (m :: [Symbol]) where
188+
symbolsVal :: Proxy m -> [Text]
189+
instance KnownSymbols '[] where
190+
symbolsVal _ = []
191+
instance (KnownSymbol s, KnownSymbols ss) => KnownSymbols (s ': ss) where
192+
symbolsVal _ = T.pack (symbolVal (Proxy @s)) : symbolsVal (Proxy @ss)
193+
178194
class ReflectServices (ss :: [Service']) where
179195
reflectServices :: Proxy ss -> [Service Text Text Text TyInfo]
180196
instance ReflectServices '[] where
@@ -204,14 +220,20 @@ instance (KnownMaySymbol pname, ReflectServices ss, ReflectService s, ReflectMet
204220
reflectRpcInfo _ ps pm req extra
205221
= RpcInfo (Package (maySymbolVal (Proxy @pname))
206222
(reflectServices (Proxy @ss)))
207-
(reflectService ps) (reflectMethod pm) req extra
223+
(reflectService ps) (Just (reflectMethod pm)) req extra
208224

209225
instance (KnownSymbol sname, ReflectMethods ms)
210226
=> ReflectService ('Service sname ms) where
211227
reflectService _
212228
= Service (T.pack $ symbolVal (Proxy @sname))
213229
(reflectMethods (Proxy @ms))
214230

231+
instance (KnownSymbol sname, KnownSymbols elts)
232+
=> ReflectService ('OneOf sname elts) where
233+
reflectService _
234+
= OneOf (T.pack $ symbolVal (Proxy @sname))
235+
(symbolsVal (Proxy @elts))
236+
215237
instance (KnownSymbol mname, ReflectArgs args, ReflectReturn r)
216238
=> ReflectMethod ('Method mname args r) where
217239
reflectMethod _

‎core/rpc/src/Mu/Rpc/Examples.hs

+27-14
Original file line numberDiff line numberDiff line change
@@ -105,30 +105,43 @@ quickstartServer
105105
type ApolloService
106106
= 'Package ('Just "apollo")
107107
'[ Object "Book"
108-
'[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))
109-
, ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))
110-
]
111-
, Object "Author"
112-
'[ ObjectField "name" '[] ('RetSingle ('PrimitiveRef String))
113-
, ObjectField "books" '[] ('RetSingle ('ListRef ('ObjectRef "Book")))
114-
]
108+
'[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))
109+
, ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))
110+
]
111+
, Object "Paper"
112+
'[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))
113+
, ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))
114+
]
115+
, Union "Writing" ["Book", "Paper"]
116+
, Object "Author"
117+
'[ ObjectField "name" '[] ('RetSingle ('PrimitiveRef String))
118+
, ObjectField "writings" '[] ('RetSingle ('ListRef ('ObjectRef "Writing")))
119+
]
115120
]
116121

117122
type ApolloBookAuthor = '[
118-
"Book" ':-> (String, Integer)
119-
, "Author" ':-> Integer
123+
"Book" ':-> (String, Integer)
124+
, "Paper" ':-> (String, Integer)
125+
, "Writing" ':-> Either (String, Integer) (String, Integer)
126+
, "Author" ':-> Integer
120127
]
121128

122129
apolloServer :: forall m i. (MonadServer m)
123130
=> ServerT ApolloBookAuthor i ApolloService m _
124131
apolloServer
125132
= resolver
126-
( object @"Author" ( field @"name" authorName
127-
, field @"books" authorBooks )
133+
( object @"Author" ( field @"name" authorName
134+
, field @"writings" authorWrs )
128135
, object @"Book" ( field @"author" (pure . snd)
129-
, field @"title" (pure . fst) ) )
136+
, field @"title" (pure . fst) )
137+
, object @"Paper" ( field @"author" (pure . snd)
138+
, field @"title" (pure . fst) )
139+
, union @"Writing" writing )
130140
where
131141
authorName :: Integer -> m String
132142
authorName _ = pure "alex" -- this would run in the DB
133-
authorBooks :: Integer -> m [(String, Integer)]
134-
authorBooks _ = pure []
143+
authorWrs :: Integer -> m [Either (String, Integer) (String, Integer)]
144+
authorWrs _ = pure []
145+
146+
writing (Left c) = pure $ unionChoice @"Book" c
147+
writing (Right c) = pure $ unionChoice @"Paper" c

‎core/rpc/src/Mu/Server.hs

+41-6
Original file line numberDiff line numberDiff line change
@@ -1,3 +1,4 @@
1+
{-# language AllowAmbiguousTypes #-}
12
{-# language CPP #-}
23
{-# language ConstraintKinds #-}
34
{-# language DataKinds #-}
@@ -54,12 +55,13 @@ module Mu.Server (
5455
-- ** Definitions by name
5556
, singleService
5657
, method, methodWithInfo
57-
, resolver, object
58+
, resolver, object, union
5859
, field, fieldWithInfo
60+
, UnionChoice(..), unionChoice
5961
, NamedList(..)
6062
-- ** Definitions by position
6163
, SingleServerT, pattern Server
62-
, ServerT(..), ServicesT(..), HandlersT(.., (:<||>:), (:<|>:))
64+
, ServerT(..), ServicesT(..), ServiceT(..), HandlersT(.., (:<||>:), (:<|>:))
6365
-- ** Simple servers using only IO
6466
, ServerErrorIO, ServerIO
6567
-- * Errors which might be raised
@@ -74,6 +76,7 @@ import Control.Exception (Exception)
7476
import Control.Monad.Except
7577
import Data.Conduit
7678
import Data.Kind
79+
import Data.Typeable
7780
import GHC.TypeLits
7881

7982
import Mu.Rpc
@@ -151,17 +154,39 @@ data ServerT (chn :: ServiceChain snm) (info :: Type)
151154
pattern Server :: (MappingRight chn sname ~ ())
152155
=> HandlersT chn info () methods m hs
153156
-> ServerT chn info ('Package pname '[ 'Service sname methods ]) m '[hs]
154-
pattern Server svr = Services (svr :<&>: S0)
157+
pattern Server svr = Services (ProperSvc svr :<&>: S0)
155158

156159
infixr 3 :<&>:
157160
-- | Definition of a complete server for a service.
158161
data ServicesT (chn :: ServiceChain snm) (info :: Type)
159162
(s :: [Service snm mnm anm (TypeRef snm)])
160163
(m :: Type -> Type) (hs :: [[Type]]) where
161164
S0 :: ServicesT chn info '[] m '[]
162-
(:<&>:) :: HandlersT chn info (MappingRight chn sname) methods m hs
165+
(:<&>:) :: ServiceT chn info svc m hs
163166
-> ServicesT chn info rest m hss
164-
-> ServicesT chn info ('Service sname methods ': rest) m (hs ': hss)
167+
-> ServicesT chn info (svc ': rest) m (hs ': hss)
168+
169+
type family InUnion (x :: k) (xs :: [k]) :: Constraint where
170+
InUnion x '[] = TypeError ('ShowType x ':<>: 'Text " is not part of the union")
171+
InUnion x (x ': xs) = ()
172+
InUnion x (y ': xs) = InUnion x xs
173+
174+
data UnionChoice chn elts where
175+
UnionChoice :: (InUnion elt elts, Typeable elt)
176+
=> Proxy elt -> MappingRight chn elt
177+
-> UnionChoice chn elts
178+
179+
unionChoice :: forall elt elts chn.
180+
(InUnion elt elts, Typeable elt)
181+
=> MappingRight chn elt -> UnionChoice chn elts
182+
unionChoice = UnionChoice (Proxy @elt)
183+
184+
-- | Definition of different kinds of services.
185+
data ServiceT chn info svc m hs where
186+
ProperSvc :: HandlersT chn info (MappingRight chn sname) methods m hs
187+
-> ServiceT chn info ('Service sname methods) m hs
188+
OneOfSvc :: (MappingRight chn sname -> m (UnionChoice chn elts))
189+
-> ServiceT chn info ('OneOf sname elts) m '[]
165190

166191
-- | 'HandlersT' is a sequence of handlers.
167192
-- Note that the handlers for your service
@@ -322,6 +347,11 @@ object
322347
=> p -> Named sname (HandlersT chn info (MappingRight chn sname) ms m hs)
323348
object nl = Named $ toHandlers $ toNamedList nl
324349

350+
union :: forall sname chn m elts.
351+
(MappingRight chn sname -> m (UnionChoice chn elts))
352+
-> Named sname (MappingRight chn sname -> m (UnionChoice chn elts))
353+
union = Named
354+
325355
-- | Combines the implementation of several GraphQL objects,
326356
-- which means a whole Mu service for a GraphQL server.
327357
-- Intented to be used with a tuple of 'objects':
@@ -412,7 +442,12 @@ instance ToServices chn info '[] m '[] nl where
412442
instance ( FindService name (HandlersT chn info (MappingRight chn name) methods m h) nl
413443
, ToServices chn info ss m hs nl)
414444
=> ToServices chn info ('Service name methods ': ss) m (h ': hs) nl where
415-
toServices nl = findService (Proxy @name) nl :<&>: toServices nl
445+
toServices nl = ProperSvc (findService (Proxy @name) nl) :<&>: toServices nl
446+
instance ( FindService name (MappingRight chn name -> m (UnionChoice chn elts)) nl
447+
, ToServices chn info ss m hs nl)
448+
=> ToServices chn info ('OneOf name elts ': ss) m ('[] ': hs) nl where
449+
toServices nl = OneOfSvc (findService (Proxy @name) nl) :<&>: toServices nl
450+
416451

417452
class FindService name h nl | name nl -> h where
418453
findService :: Proxy name -> NamedList nl -> h

‎examples/library

‎graphql/exe/Main.hs

+29-8
Original file line numberDiff line numberDiff line change
@@ -1,6 +1,7 @@
11
{-# language CPP #-}
22
{-# language DataKinds #-}
33
{-# language FlexibleContexts #-}
4+
{-# language LambdaCase #-}
45
{-# language OverloadedStrings #-}
56
{-# language PartialTypeSignatures #-}
67
{-# language PolyKinds #-}
@@ -52,9 +53,14 @@ main = do
5253
(Proxy @'Nothing)
5354
(Proxy @('Just "Subscription"))
5455

56+
data WritingMapping
57+
= ABook (Integer, Integer) | AnArticle (Integer, Integer)
58+
5559
type ServiceMapping = '[
56-
"Book" ':-> (Integer, Integer)
57-
, "Author" ':-> Integer
60+
"Book" ':-> (Integer, Integer)
61+
, "Article" ':-> (Integer, Integer)
62+
, "Author" ':-> Integer
63+
, "Writing" ':-> WritingMapping
5864
]
5965

6066
library :: [(Integer, T.Text, [(Integer, (T.Text, Integer))])]
@@ -64,39 +70,54 @@ library
6470
, (3, "Michael Ende", [(4, ("The Neverending Story", 5)), (5, ("Momo", 3))])
6571
]
6672

73+
articles :: [(Integer, T.Text, [(Integer, (T.Text, Integer))])]
74+
articles
75+
= [ (1, "Fuencislo Robles", [(6, ("On Warm Chocolate", 4)), (2, ("On Cold Chocolate", 4))]) ]
76+
6777
libraryServer :: forall m i. (MonadServer m)
6878
=> ServerT ServiceMapping i ServiceDefinition m _
6979
libraryServer
70-
= resolver ( object @"Book" ( field @"id" bookId
80+
= resolver ( object @"Book" ( field @"id" bookOrArticleId
7181
, field @"title" bookTitle
72-
, field @"author" bookAuthor
82+
, field @"author" bookOrArticleAuthor
7383
, field @"info" bookInfo )
84+
, object @"Article" ( field @"id" bookOrArticleId
85+
, field @"title" articleTitle
86+
, field @"author" bookOrArticleAuthor )
7487
, object @"Author" ( field @"id" authorId
7588
, field @"name" authorName
76-
, field @"books" authorBooks )
89+
, field @"writings" authorBooks )
7790
, object @"Query" ( method @"author" findAuthor
7891
, method @"book" findBookTitle
7992
, method @"authors" allAuthors
8093
, method @"books" allBooks' )
8194
, object @"Subscription" ( method @"books" allBooksConduit )
95+
, union @"Writing" (\case (ABook x) -> pure $ unionChoice @"Book" x
96+
(AnArticle x) -> pure $ unionChoice @"Article" x)
8297
)
8398
where
8499
findBook i = find ((==i) . fst3) library
100+
findArticle i = find ((==i) . fst3) articles
85101

86-
bookId (_, bid) = pure bid
102+
bookOrArticleId (_, bid) = pure bid
103+
bookOrArticleAuthor (aid, _) = pure aid
87104
bookTitle (aid, bid) = pure $ fromMaybe "" $ do
88105
bk <- findBook aid
89106
ev <- lookup bid (thd3 bk)
90107
pure (fst ev)
91-
bookAuthor (aid, _) = pure aid
92108
bookInfo (aid, bid) = pure $ do
93109
bk <- findBook aid
94110
ev <- lookup bid (thd3 bk)
95111
pure $ JSON.object ["score" JSON..= snd ev]
112+
articleTitle (aid, bid) = pure $ fromMaybe "" $ do
113+
bk <- findArticle aid
114+
ev <- lookup bid (thd3 bk)
115+
pure (fst ev)
96116

97117
authorId = pure
98118
authorName aid = pure $ maybe "" snd3 (findBook aid)
99-
authorBooks aid = pure $ maybe [] (map ((aid,) . fst) . thd3) (findBook aid)
119+
authorBooks aid = pure $ maybe [] (map (ABook . (aid,) . fst) . thd3) (findBook aid)
120+
<> maybe [] (map (AnArticle . (aid,) . fst) . thd3) (findArticle aid)
100121

101122
findAuthor rx = pure $ listToMaybe
102123
[aid | (aid, name, _) <- library, name =~ rx]

‎graphql/exe/schema.graphql

+9-1
Original file line numberDiff line numberDiff line change
@@ -5,10 +5,18 @@ type Book {
55
info: JSON
66
}
77

8+
type Article {
9+
id: Int!
10+
title: String!
11+
author: Author!
12+
}
13+
14+
union Writing = Book | Article
15+
816
type Author {
917
id: Int!
1018
name: String!
11-
books: [Book!]!
19+
writings: [Writing!]!
1220
}
1321

1422
type Query {

0 commit comments

Comments
 (0)