Support unions in GraphQL

adapter/avro/mu-avro.cabal

@@ -38,7 +38,7 @@ library
     , containers            >=0.6   && <0.7
     , deepseq               >=1.4   && <2
     , language-avro         >=0.1.3 && <0.2
-    , mu-rpc                >=0.4   && <0.5
+    , mu-rpc                >=0.4   && <0.6
     , mu-schema             >=0.3   && <0.4
     , sop-core              >=0.5.0 && <0.6
     , tagged                >=0.8.6 && <0.9

adapter/protobuf/mu-protobuf.cabal

@@ -38,7 +38,7 @@ library
     , http-client             >=0.6   && <0.7
     , http2-grpc-proto3-wire  >=0.1   && <0.2
     , language-protobuf       >=1.0.1 && <2
-    , mu-rpc                  >=0.4   && <0.5
+    , mu-rpc                  >=0.4   && <0.6
     , mu-schema               >=0.3   && <0.4
     , proto3-wire             >=1.1   && <2
     , servant-client-core     >=0.16  && <0.19

core/rpc/mu-rpc.cabal

@@ -1,5 +1,5 @@
 name:               mu-rpc
-version:            0.4.0.1
+version:            0.5.0.0
 synopsis:           Protocol-independent declaration of services and servers.
 description:
   Protocol-independent declaration of services and servers for mu-haskell.

core/rpc/src/Mu/Rpc.hs

@@ -20,7 +20,7 @@ and protocol.
 -}
 module Mu.Rpc (
   Package', Package(..)
-, Service', Service(..), Object
+, Service', Service(..), Object, Union
 , Method', Method(..), ObjectField
 , LookupService, LookupMethod
 , TypeRef(..), Argument', Argument(..), Return(..)
@@ -56,6 +56,7 @@ data Package serviceName methodName argName tyRef
 data Service serviceName methodName argName tyRef
   = Service serviceName
             [Method serviceName methodName argName tyRef]
+  | OneOf serviceName [serviceName]
 
 -- | A method is defined by its name, arguments, and return type.
 data Method serviceName methodName argName tyRef
@@ -66,6 +67,8 @@ data Method serviceName methodName argName tyRef
 -- Synonyms for GraphQL
 -- | An object is a set of fields, in GraphQL lingo.
 type Object = 'Service
+-- | A union is one of the objects.
+type Union = 'OneOf
 -- | A field in an object takes some input objects,
 --   and returns a value or some other object,
 --   in GraphQL lingo.
@@ -76,6 +79,7 @@ type family LookupService (ss :: [Service snm mnm anm tr]) (s :: snm)
               :: Service snm mnm anm tr where
   LookupService '[] s = TypeError ('Text "could not find method " ':<>: 'ShowType s)
   LookupService ('Service s ms ': ss) s = 'Service s ms
+  LookupService ('OneOf   s ms ': ss) s = 'OneOf   s ms
   LookupService (other         ': ss) s = LookupService ss s
 
 -- | Look up a method in a service definition using its name.
@@ -136,7 +140,7 @@ data RpcInfo i
   = NoRpcInfo
   | RpcInfo { packageInfo :: Package Text Text Text TyInfo
             , serviceInfo :: Service Text Text Text TyInfo
-            , methodInfo  :: Method  Text Text Text TyInfo
+            , methodInfo  :: Maybe (Method Text Text Text TyInfo)
             , headers     :: RequestHeaders
             , extraInfo   :: i
             }
@@ -150,10 +154,15 @@ data TyInfo
 instance Show (RpcInfo i) where
   show NoRpcInfo
     = "<no info>"
-  show (RpcInfo (Package Nothing _) (Service s _) (Method m _ _) _ _)
-    = T.unpack (s <> ":" <> m)
-  show (RpcInfo (Package (Just p) _) (Service s _) (Method m _ _) _ _)
-    = T.unpack (p <> ":" <> s <> ":" <> m)
+  show (RpcInfo (Package p _) s m _ _)
+    = T.unpack $ showPkg p (showMth m (showSvc s))
+    where
+      showPkg Nothing    = id
+      showPkg (Just pkg) = ((pkg <> ":") <>)
+      showMth Nothing                = id
+      showMth (Just (Method mt _ _)) = (<> (":" <> mt))
+      showSvc (Service sv _) = sv
+      showSvc (OneOf   sv _) = sv
 
 class ReflectRpcInfo (p :: Package') (s :: Service') (m :: Method') where
   reflectRpcInfo :: Proxy p -> Proxy s -> Proxy m -> RequestHeaders -> i -> RpcInfo i
@@ -175,6 +184,13 @@ instance KnownMaySymbol 'Nothing where
 instance (KnownSymbol s) => KnownMaySymbol ('Just s) where
   maySymbolVal _ = Just $ T.pack $ symbolVal (Proxy @s)
 
+class KnownSymbols (m :: [Symbol]) where
+  symbolsVal :: Proxy m -> [Text]
+instance KnownSymbols '[] where
+  symbolsVal _ = []
+instance (KnownSymbol s, KnownSymbols ss) => KnownSymbols (s ': ss) where
+  symbolsVal _ = T.pack (symbolVal (Proxy @s)) : symbolsVal (Proxy @ss)
+
 class ReflectServices (ss :: [Service']) where
   reflectServices :: Proxy ss -> [Service Text Text Text TyInfo]
 instance ReflectServices '[] where
@@ -204,14 +220,20 @@ instance (KnownMaySymbol pname, ReflectServices ss, ReflectService s, ReflectMet
   reflectRpcInfo _ ps pm req extra
     = RpcInfo (Package (maySymbolVal (Proxy @pname))
                        (reflectServices (Proxy @ss)))
-              (reflectService ps) (reflectMethod pm) req extra
+              (reflectService ps) (Just (reflectMethod pm)) req extra
 
 instance (KnownSymbol sname, ReflectMethods ms)
          => ReflectService ('Service sname ms) where
   reflectService _
     = Service (T.pack $ symbolVal (Proxy @sname))
               (reflectMethods (Proxy @ms))
 
+instance (KnownSymbol sname, KnownSymbols elts)
+         => ReflectService ('OneOf sname elts) where
+  reflectService _
+    = OneOf (T.pack $ symbolVal (Proxy @sname))
+            (symbolsVal (Proxy @elts))
+
 instance (KnownSymbol mname, ReflectArgs args, ReflectReturn r)
          => ReflectMethod ('Method mname args r) where
   reflectMethod _

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

@@ -105,30 +105,43 @@ quickstartServer
 type ApolloService
   = 'Package ('Just "apollo")
       '[ Object "Book"
-        '[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))
-        , ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))
-        ]
-      , Object "Author"
-        '[ ObjectField "name" '[] ('RetSingle ('PrimitiveRef String))
-        , ObjectField "books" '[] ('RetSingle ('ListRef ('ObjectRef "Book")))
-        ]
+         '[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))
+          , ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))
+          ]
+      ,  Object "Paper"
+         '[ ObjectField "title" '[] ('RetSingle ('PrimitiveRef String))
+          , ObjectField "author" '[] ('RetSingle ('ObjectRef "Author"))
+          ]
+      ,  Union "Writing" ["Book", "Paper"]
+      ,  Object "Author"
+         '[ ObjectField "name" '[] ('RetSingle ('PrimitiveRef String))
+          , ObjectField "writings" '[] ('RetSingle ('ListRef ('ObjectRef "Writing")))
+          ]
       ]
 
 type ApolloBookAuthor = '[
-    "Book"   ':-> (String, Integer)
-  , "Author" ':-> Integer
+    "Book"    ':-> (String, Integer)
+  , "Paper"   ':-> (String, Integer)
+  , "Writing" ':-> Either (String, Integer) (String, Integer)
+  , "Author"  ':-> Integer
   ]
 
 apolloServer :: forall m i. (MonadServer m)
              => ServerT ApolloBookAuthor i ApolloService m _
 apolloServer
   = resolver
-      ( object @"Author" ( field @"name"   authorName
-                         , field @"books"  authorBooks )
+      ( object @"Author" ( field @"name"     authorName
+                         , field @"writings" authorWrs )
       , object @"Book"   ( field @"author" (pure . snd)
-                         , field @"title"  (pure . fst) ) )
+                         , field @"title"  (pure . fst) )
+      , object @"Paper"  ( field @"author" (pure . snd)
+                         , field @"title"  (pure . fst) )
+      , union @"Writing" writing )
   where
     authorName :: Integer -> m String
     authorName _ = pure "alex"  -- this would run in the DB
-    authorBooks :: Integer -> m [(String, Integer)]
-    authorBooks _ = pure []
+    authorWrs :: Integer -> m [Either (String, Integer) (String, Integer)]
+    authorWrs _ = pure []
+
+    writing (Left  c) = pure $ unionChoice @"Book" c
+    writing (Right c) = pure $ unionChoice @"Paper" c

core/rpc/src/Mu/Server.hs

@@ -1,3 +1,4 @@
+{-# language AllowAmbiguousTypes       #-}
 {-# language CPP                       #-}
 {-# language ConstraintKinds           #-}
 {-# language DataKinds                 #-}
@@ -54,12 +55,13 @@ module Mu.Server (
   -- ** Definitions by name
 , singleService
 , method, methodWithInfo
-, resolver, object
+, resolver, object, union
 , field, fieldWithInfo
+, UnionChoice(..), unionChoice
 , NamedList(..)
   -- ** Definitions by position
 , SingleServerT, pattern Server
-, ServerT(..), ServicesT(..), HandlersT(.., (:<||>:), (:<|>:))
+, ServerT(..), ServicesT(..), ServiceT(..), HandlersT(.., (:<||>:), (:<|>:))
   -- ** Simple servers using only IO
 , ServerErrorIO, ServerIO
   -- * Errors which might be raised
@@ -74,6 +76,7 @@ import           Control.Exception    (Exception)
 import           Control.Monad.Except
 import           Data.Conduit
 import           Data.Kind
+import           Data.Typeable
 import           GHC.TypeLits
 
 import           Mu.Rpc
@@ -151,17 +154,39 @@ data ServerT (chn :: ServiceChain snm) (info :: Type)
 pattern Server :: (MappingRight chn sname ~ ())
                => HandlersT chn info () methods m hs
                -> ServerT chn info ('Package pname '[ 'Service sname methods ]) m '[hs]
-pattern Server svr = Services (svr :<&>: S0)
+pattern Server svr = Services (ProperSvc svr :<&>: S0)
 
 infixr 3 :<&>:
 -- | Definition of a complete server for a service.
 data ServicesT (chn :: ServiceChain snm) (info :: Type)
                (s :: [Service snm mnm anm (TypeRef snm)])
                (m :: Type -> Type) (hs :: [[Type]]) where
   S0 :: ServicesT chn info '[] m '[]
-  (:<&>:) :: HandlersT chn info (MappingRight chn sname) methods m hs
+  (:<&>:) :: ServiceT chn info svc m hs
           -> ServicesT chn info rest m hss
-          -> ServicesT chn info ('Service sname methods ': rest) m (hs ': hss)
+          -> ServicesT chn info (svc ': rest) m (hs ': hss)
+
+type family InUnion (x :: k) (xs :: [k]) :: Constraint where
+  InUnion x '[] = TypeError ('ShowType x ':<>: 'Text " is not part of the union")
+  InUnion x (x ': xs) = ()
+  InUnion x (y ': xs) = InUnion x xs
+
+data UnionChoice chn elts where
+  UnionChoice :: (InUnion elt elts, Typeable elt)
+              => Proxy elt -> MappingRight chn elt
+              -> UnionChoice chn elts
+
+unionChoice :: forall elt elts chn.
+               (InUnion elt elts, Typeable elt)
+            => MappingRight chn elt -> UnionChoice chn elts
+unionChoice = UnionChoice (Proxy @elt)
+
+-- | Definition of different kinds of services.
+data ServiceT chn info svc m hs where
+  ProperSvc :: HandlersT chn info (MappingRight chn sname) methods m hs
+            -> ServiceT chn info ('Service sname methods) m hs
+  OneOfSvc  :: (MappingRight chn sname -> m (UnionChoice chn elts))
+            -> ServiceT chn info ('OneOf sname elts) m '[]
 
 -- | 'HandlersT' is a sequence of handlers.
 --   Note that the handlers for your service
@@ -322,6 +347,11 @@ object
   => p -> Named sname (HandlersT chn info (MappingRight chn sname) ms m hs)
 object nl = Named $ toHandlers $ toNamedList nl
 
+union :: forall sname chn m elts.
+         (MappingRight chn sname -> m (UnionChoice chn elts))
+      -> Named sname (MappingRight chn sname -> m (UnionChoice chn elts))
+union = Named
+
 -- | Combines the implementation of several GraphQL objects,
 --   which means a whole Mu service for a GraphQL server.
 --   Intented to be used with a tuple of 'objects':
@@ -412,7 +442,12 @@ instance ToServices chn info '[] m '[] nl where
 instance ( FindService name (HandlersT chn info (MappingRight chn name) methods m h) nl
          , ToServices chn info ss m hs nl)
          => ToServices chn info ('Service name methods ': ss) m (h ': hs) nl where
-  toServices nl = findService (Proxy @name) nl :<&>: toServices nl
+  toServices nl = ProperSvc (findService (Proxy @name) nl) :<&>: toServices nl
+instance ( FindService name (MappingRight chn name -> m (UnionChoice chn elts)) nl
+         , ToServices chn info ss m hs nl)
+         => ToServices chn info ('OneOf name elts ': ss) m ('[] ': hs) nl where
+  toServices nl = OneOfSvc (findService (Proxy @name) nl) :<&>: toServices nl
+
 
 class FindService name h nl | name nl -> h where
   findService :: Proxy name -> NamedList nl -> h

graphql/exe/Main.hs

@@ -1,6 +1,7 @@
 {-# language CPP                   #-}
 {-# language DataKinds             #-}
 {-# language FlexibleContexts      #-}
+{-# language LambdaCase            #-}
 {-# language OverloadedStrings     #-}
 {-# language PartialTypeSignatures #-}
 {-# language PolyKinds             #-}
@@ -52,9 +53,14 @@ main = do
     (Proxy @'Nothing)
     (Proxy @('Just "Subscription"))
 
+data WritingMapping
+  = ABook (Integer, Integer) | AnArticle (Integer, Integer)
+
 type ServiceMapping = '[
-    "Book"   ':-> (Integer, Integer)
-  , "Author" ':-> Integer
+    "Book"    ':-> (Integer, Integer)
+  , "Article" ':-> (Integer, Integer)
+  , "Author"  ':-> Integer
+  , "Writing" ':-> WritingMapping
   ]
 
 library :: [(Integer, T.Text, [(Integer, (T.Text, Integer))])]
@@ -64,39 +70,54 @@ library
     , (3, "Michael Ende", [(4, ("The Neverending Story", 5)), (5, ("Momo", 3))])
     ]
 
+articles :: [(Integer, T.Text, [(Integer, (T.Text, Integer))])]
+articles
+  = [ (1, "Fuencislo Robles", [(6, ("On Warm Chocolate", 4)), (2, ("On Cold Chocolate", 4))]) ]
+
 libraryServer :: forall m i. (MonadServer m)
               => ServerT ServiceMapping i ServiceDefinition m _
 libraryServer
-  = resolver ( object @"Book"   ( field  @"id"      bookId
+  = resolver ( object @"Book"   ( field  @"id"      bookOrArticleId
                                 , field  @"title"   bookTitle
-                                , field  @"author"  bookAuthor
+                                , field  @"author"  bookOrArticleAuthor
                                 , field  @"info"    bookInfo )
+             , object @"Article" ( field @"id"      bookOrArticleId
+                                , field  @"title"   articleTitle
+                                , field  @"author"  bookOrArticleAuthor )
              , object @"Author" ( field  @"id"      authorId
                                 , field  @"name"    authorName
-                                , field  @"books"   authorBooks )
+                                , field  @"writings" authorBooks )
              , object @"Query"  ( method @"author"  findAuthor
                                 , method @"book"    findBookTitle
                                 , method @"authors" allAuthors
                                 , method @"books"   allBooks' )
              , object @"Subscription" ( method @"books" allBooksConduit )
+             , union @"Writing" (\case (ABook     x) -> pure $ unionChoice @"Book"    x
+                                       (AnArticle x) -> pure $ unionChoice @"Article" x)
              )
   where
     findBook i = find ((==i) . fst3) library
+    findArticle i = find ((==i) . fst3) articles
 
-    bookId (_, bid) = pure bid
+    bookOrArticleId (_, bid) = pure bid
+    bookOrArticleAuthor (aid, _) = pure aid
     bookTitle (aid, bid) = pure $ fromMaybe "" $ do
       bk <- findBook aid
       ev <- lookup bid (thd3 bk)
       pure (fst ev)
-    bookAuthor (aid, _) = pure aid
     bookInfo (aid, bid) = pure $ do
       bk <- findBook aid
       ev <- lookup bid (thd3 bk)
       pure $ JSON.object ["score" JSON..= snd ev]
+    articleTitle (aid, bid) = pure $ fromMaybe "" $ do
+      bk <- findArticle aid
+      ev <- lookup bid (thd3 bk)
+      pure (fst ev)
 
     authorId = pure
     authorName aid = pure $ maybe "" snd3 (findBook aid)
-    authorBooks aid = pure $ maybe [] (map ((aid,) . fst) . thd3) (findBook aid)
+    authorBooks aid = pure $ maybe [] (map (ABook . (aid,) . fst) . thd3) (findBook aid)
+                           <> maybe [] (map (AnArticle . (aid,) . fst) . thd3) (findArticle aid)
 
     findAuthor rx = pure $ listToMaybe
       [aid | (aid, name, _) <- library, name =~ rx]

graphql/exe/schema.graphql

@@ -5,10 +5,18 @@ type Book {
   info: JSON
 }
 
+type Article {
+  id: Int!
+  title: String!
+  author: Author!
+}
+
+union Writing = Book | Article
+
 type Author {
   id: Int!
   name: String!
-  books: [Book!]!
+  writings: [Writing!]!
 }
 
 type Query {