Subscriptions for GraphQL (#146)

Co-authored-by: Flavio Corpa <flavio.corpa@47deg.com>

graphql/exe/Main.hs

@@ -11,6 +11,8 @@
 
 module Main where
 
+import           Data.Conduit
+import           Data.Conduit.Combinators          (yieldMany)
 import           Data.List                         (find)
 import           Data.Maybe                        (fromMaybe, listToMaybe)
 import           Data.Proxy
@@ -37,7 +39,8 @@ main = do
              ("Access-Control-Allow-Origin", "*")
            , ("Access-Control-Allow-Headers", "Content-Type")
            ]
-  run 8000 $ hm $ graphQLAppQuery libraryServer (Proxy @"Query")
+  run 8000 $ hm $ graphQLApp libraryServer
+    (Proxy @('Just "Query")) (Proxy @'Nothing) (Proxy @('Just "Subscription"))
 
 type ServiceDefinition
   = 'Package ('Just "library")
@@ -63,7 +66,10 @@ type ServiceDefinition
           , ObjectField "books" '[]
               '[] ('RetSingle ('ListRef ('ObjectRef "Book")))
           ]
-      , Object "Mutation" '[] '[]
+      , Object "Subscription" '[]
+         '[ ObjectField "books" '[]
+              '[] ('RetStream ('ObjectRef "Book"))
+          ]
       ]
 
 type ServiceMapping = '[
@@ -85,9 +91,10 @@ libraryServer
                :<&>: (noContext findAuthor
                       :<||>: noContext findBookTitle
                       :<||>: noContext allAuthors
-                      :<||>: noContext allBooks
+                      :<||>: noContext allBooks'
                       :<||>: H0)
-               :<&>: H0 :<&>: S0
+               :<&>: (noContext allBooksConduit :<||>: H0)
+               :<&>: S0
   where
     findBook i = find ((==i) . fst3) library
 
@@ -108,7 +115,12 @@ libraryServer
                   , title =~ rx]
 
     allAuthors = pure $ fst3 <$> library
-    allBooks = pure [(aid, bid) | (aid, _, books) <- library, (bid, _) <- books]
+    allBooks = [(aid, bid) | (aid, _, books) <- library, (bid, _) <- books]
+    allBooks' = pure allBooks
+
+    allBooksConduit :: ConduitM (Integer, Integer) Void m () -> m ()
+    allBooksConduit sink
+      = runConduit $ yieldMany allBooks .| sink
 
 -- helpers
 

graphql/mu-graphql.cabal

@@ -22,27 +22,34 @@ library
     Mu.GraphQL.Query.Definition
     Mu.GraphQL.Query.Parse
     Mu.GraphQL.Query.Run
+    Mu.GraphQL.Subscription.Protocol
 
   -- other-extensions:
   build-depends:
       aeson
+    , async
     , base                  >=4.12 && <5
     , bytestring
     , conduit
     , graphql-parser
     , http-types
+    , list-t
     , mtl
     , mu-rpc
     , mu-schema
     , scientific
     , sop-core
+    , stm
     , stm-chans
     , stm-conduit
+    , stm-containers
     , text
     , unordered-containers
     , wai
+    , wai-websockets
     , warp
     , warp-tls
+    , websockets
 
   hs-source-dirs:   src
   default-language: Haskell2010
@@ -55,6 +62,7 @@ executable library-graphql
   ghc-options:      -Wall
   build-depends:
       base             >=4.12   && <5
+    , conduit
     , mu-graphql
     , mu-rpc
     , mu-schema

graphql/src/Mu/GraphQL/Query/Definition.hs

@@ -11,13 +11,20 @@ import           Data.Text
 import           Mu.Rpc
 import           Mu.Schema
 
-data Document (p :: Package snm mnm anm) (qr :: Maybe snm) (mut :: Maybe snm) where
-  QueryDoc    :: LookupService ss qr ~ 'Service qr qanns qms
-              => ServiceQuery ('Package pname ss) (LookupService ss qr)
-              -> Document ('Package pname ss) ('Just qr) mut
-  MutationDoc :: LookupService ss mut ~ 'Service mut manns mms
-              => ServiceQuery ('Package pname ss) (LookupService ss mut)
-              -> Document ('Package pname ss) qr ('Just mut)
+data Document (p :: Package snm mnm anm)
+              (qr :: Maybe snm) (mut :: Maybe snm) (sub :: Maybe snm) where
+  QueryDoc
+    :: LookupService ss qr ~ 'Service qr qanns qms
+    => ServiceQuery ('Package pname ss) (LookupService ss qr)
+    -> Document ('Package pname ss) ('Just qr) mut sub
+  MutationDoc
+    :: LookupService ss mut ~ 'Service mut manns mms
+    => ServiceQuery ('Package pname ss) (LookupService ss mut)
+    -> Document ('Package pname ss) qr ('Just mut) sub
+  SubscriptionDoc
+    :: LookupService ss sub ~ 'Service sub manns mms
+    => OneMethodQuery ('Package pname ss) (LookupService ss sub)
+    -> Document ('Package pname ss) qr mut ('Just sub)
 
 type ServiceQuery (p :: Package snm mnm anm) (s :: Service snm mnm anm)
   = [OneMethodQuery p s]

graphql/src/Mu/GraphQL/Query/Parse.hs

@@ -10,17 +10,21 @@
 {-# language TypeOperators         #-}
 {-# language UndecidableInstances  #-}
 {-# language ViewPatterns          #-}
-{-# OPTIONS_GHC -Wincomplete-patterns #-}
+{-# OPTIONS_GHC -Wincomplete-patterns -fno-warn-orphans #-}
 
 module Mu.GraphQL.Query.Parse where
 
 import           Control.Monad.Except
+import qualified Data.Aeson                    as A
+import           Data.Coerce                   (coerce)
+import qualified Data.Foldable                 as F
 import qualified Data.HashMap.Strict           as HM
 import           Data.Int                      (Int32)
 import           Data.Kind
 import           Data.List                     (find)
 import           Data.Maybe
 import           Data.Proxy
+import           Data.Scientific               (floatingOrInteger)
 import           Data.SOP.NS
 import qualified Data.Text                     as T
 import           GHC.TypeLits
@@ -32,15 +36,26 @@ import           Mu.Rpc
 import           Mu.Schema
 
 type VariableMapC = HM.HashMap T.Text GQL.ValueConst
-type VariableMap = HM.HashMap T.Text GQL.Value
-type FragmentMap = HM.HashMap T.Text GQL.FragmentDefinition
+type VariableMap  = HM.HashMap T.Text GQL.Value
+type FragmentMap  = HM.HashMap T.Text GQL.FragmentDefinition
+
+instance A.FromJSON GQL.ValueConst where
+  parseJSON A.Null       = pure GQL.VCNull
+  parseJSON (A.Bool b)   = pure $ GQL.VCBoolean b
+  parseJSON (A.String s) = pure $ GQL.VCString $ coerce s
+  parseJSON (A.Number n) = pure $ either GQL.VCFloat GQL.VCInt $ floatingOrInteger n
+  parseJSON (A.Array xs) = GQL.VCList . GQL.ListValueG . F.toList <$> traverse A.parseJSON xs
+  parseJSON (A.Object o) = GQL.VCObject . GQL.ObjectValueG . fmap toObjFld . HM.toList <$> traverse A.parseJSON o
+    where
+      toObjFld :: (T.Text, GQL.ValueConst) -> GQL.ObjectFieldG GQL.ValueConst
+      toObjFld (k, v) = GQL.ObjectFieldG (coerce k) v
 
 parseDoc ::
-  forall qr mut p f.
-  ( MonadError T.Text f, ParseTypedDoc p qr mut ) =>
+  forall qr mut sub p f.
+  ( MonadError T.Text f, ParseTypedDoc p qr mut sub ) =>
   Maybe T.Text -> VariableMapC ->
   GQL.ExecutableDocument ->
-  f (Document p qr mut)
+  f (Document p qr mut sub)
 -- If there's no operation name, there must be only one query
 parseDoc Nothing vmap (GQL.ExecutableDocument defns)
   = case GQL.partitionExDefs defns of
@@ -68,10 +83,10 @@ fragmentsToMap = HM.fromList . map fragmentToThingy
         fragmentToThingy f = (GQL.unName $ GQL._fdName f, f)
 
 parseTypedDoc ::
-  (MonadError T.Text f, ParseTypedDoc p qr mut) =>
+  (MonadError T.Text f, ParseTypedDoc p qr mut sub) =>
   VariableMapC -> FragmentMap ->
   GQL.TypedOperationDefinition ->
-  f (Document p qr mut)
+  f (Document p qr mut sub)
 parseTypedDoc vmap frmap tod
   = let defVmap = parseVariableMap (GQL._todVariableDefinitions tod)
         finalVmap = constToValue <$> HM.union vmap defVmap  -- first one takes precedence
@@ -81,58 +96,140 @@ parseTypedDoc vmap frmap tod
         GQL.OperationTypeMutation
           -> parseTypedDocMutation finalVmap frmap (GQL._todSelectionSet tod)
         GQL.OperationTypeSubscription
-          -> throwError "subscriptions are not (yet) supported"
+          -> parseTypedDocSubscription finalVmap frmap (GQL._todSelectionSet tod)
 
-class ParseTypedDoc (p :: Package') (qr :: Maybe Symbol) (mut :: Maybe Symbol) where
+class ParseTypedDoc (p :: Package')
+                    (qr :: Maybe Symbol) (mut :: Maybe Symbol) (sub :: Maybe Symbol) where
   parseTypedDocQuery ::
     MonadError T.Text f =>
     VariableMap -> FragmentMap ->
     GQL.SelectionSet ->
-    f (Document p qr mut)
+    f (Document p qr mut sub)
   parseTypedDocMutation ::
     MonadError T.Text f =>
     VariableMap -> FragmentMap ->
     GQL.SelectionSet ->
-    f (Document p qr mut)
+    f (Document p qr mut sub)
+  parseTypedDocSubscription ::
+    MonadError T.Text f =>
+    VariableMap -> FragmentMap ->
+    GQL.SelectionSet ->
+    f (Document p qr mut sub)
+
+instance
+  ( p ~ 'Package pname ss,
+    LookupService ss qr ~ 'Service qr qanns qmethods,
+    KnownName qr, ParseMethod p qmethods,
+    LookupService ss mut ~ 'Service mut manns mmethods,
+    KnownName mut, ParseMethod p mmethods,
+    LookupService ss sub ~ 'Service sub sanns smethods,
+    KnownName sub, ParseMethod p smethods
+  ) => ParseTypedDoc p ('Just qr) ('Just mut) ('Just sub) where
+  parseTypedDocQuery vmap frmap sset
+    = QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset
+  parseTypedDocMutation vmap frmap sset
+    = MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset
+  parseTypedDocSubscription vmap frmap sset
+    = do q <- parseQuery Proxy Proxy vmap frmap sset
+         case q of
+           [one] -> pure $ SubscriptionDoc one
+           _     -> throwError "subscriptions may only have one field"
 
 instance
   ( p ~ 'Package pname ss,
     LookupService ss qr ~ 'Service qr qanns qmethods,
     KnownName qr, ParseMethod p qmethods,
     LookupService ss mut ~ 'Service mut manns mmethods,
     KnownName mut, ParseMethod p mmethods
-  ) => ParseTypedDoc p ('Just qr) ('Just mut) where
+  ) => ParseTypedDoc p ('Just qr) ('Just mut) 'Nothing where
   parseTypedDocQuery vmap frmap sset
     = QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset
   parseTypedDocMutation vmap frmap sset
     = MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset
+  parseTypedDocSubscription _ _ _
+    = throwError "no subscriptions are defined in the schema"
+
+instance
+  ( p ~ 'Package pname ss,
+    LookupService ss qr ~ 'Service qr qanns qmethods,
+    KnownName qr, ParseMethod p qmethods,
+    LookupService ss sub ~ 'Service sub sanns smethods,
+    KnownName sub, ParseMethod p smethods
+  ) => ParseTypedDoc p ('Just qr) 'Nothing ('Just sub) where
+  parseTypedDocQuery vmap frmap sset
+    = QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset
+  parseTypedDocMutation _ _ _
+    = throwError "no mutations are defined in the schema"
+  parseTypedDocSubscription vmap frmap sset
+    = do q <- parseQuery Proxy Proxy vmap frmap sset
+         case q of
+           [one] -> pure $ SubscriptionDoc one
+           _     -> throwError "subscriptions may only have one field"
 
 instance
   ( p ~ 'Package pname ss,
     LookupService ss qr ~ 'Service qr qanns qmethods,
     KnownName qr, ParseMethod p qmethods
-  ) => ParseTypedDoc p ('Just qr) 'Nothing where
+  ) => ParseTypedDoc p ('Just qr) 'Nothing 'Nothing where
   parseTypedDocQuery vmap frmap sset
     = QueryDoc <$> parseQuery Proxy Proxy vmap frmap sset
   parseTypedDocMutation _ _ _
     = throwError "no mutations are defined in the schema"
+  parseTypedDocSubscription _ _ _
+    = throwError "no subscriptions are defined in the schema"
+
+instance
+  ( p ~ 'Package pname ss,
+    LookupService ss mut ~ 'Service mut manns mmethods,
+    KnownName mut, ParseMethod p mmethods,
+    LookupService ss sub ~ 'Service sub sanns smethods,
+    KnownName sub, ParseMethod p smethods
+  ) => ParseTypedDoc p 'Nothing ('Just mut) ('Just sub) where
+  parseTypedDocQuery _ _ _
+    = throwError "no queries are defined in the schema"
+  parseTypedDocMutation vmap frmap sset
+    = MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset
+  parseTypedDocSubscription vmap frmap sset
+    = do q <- parseQuery Proxy Proxy vmap frmap sset
+         case q of
+           [one] -> pure $ SubscriptionDoc one
+           _     -> throwError "subscriptions may only have one field"
 
 instance
   ( p ~ 'Package pname ss,
     LookupService ss mut ~ 'Service mut manns mmethods,
     KnownName mut, ParseMethod p mmethods
-  ) => ParseTypedDoc p 'Nothing ('Just mut) where
+  ) => ParseTypedDoc p 'Nothing ('Just mut) 'Nothing where
   parseTypedDocQuery _ _ _
     = throwError "no queries are defined in the schema"
   parseTypedDocMutation vmap frmap sset
     = MutationDoc <$> parseQuery Proxy Proxy vmap frmap sset
+  parseTypedDocSubscription _ _ _
+    = throwError "no subscriptions are defined in the schema"
+
+instance
+  ( p ~ 'Package pname ss,
+    LookupService ss sub ~ 'Service sub sanns smethods,
+    KnownName sub, ParseMethod p smethods
+  ) => ParseTypedDoc p 'Nothing 'Nothing ('Just sub) where
+  parseTypedDocQuery _ _ _
+    = throwError "no queries are defined in the schema"
+  parseTypedDocMutation _ _ _
+    = throwError "no mutations are defined in the schema"
+  parseTypedDocSubscription vmap frmap sset
+    = do q <- parseQuery Proxy Proxy vmap frmap sset
+         case q of
+           [one] -> pure $ SubscriptionDoc one
+           _     -> throwError "subscriptions may only have one field"
 
 instance
-  ParseTypedDoc p 'Nothing 'Nothing where
+  ParseTypedDoc p 'Nothing 'Nothing 'Nothing where
   parseTypedDocQuery _ _ _
     = throwError "no queries are defined in the schema"
   parseTypedDocMutation _ _ _
     = throwError "no mutations are defined in the schema"
+  parseTypedDocSubscription _ _ _
+    = throwError "no subscriptions are defined in the schema"
 
 parseVariableMap :: [GQL.VariableDefinition] -> VariableMapC
 parseVariableMap vmap