New API to support GraphQL resolvers as services (#111)

Co-authored-by: Flavio Corpa <[email protected]>

Author: serras

adapter/avro/src/Mu/Adapter/Avro.hs

@@ -197,7 +197,7 @@ instance (HasAvroSchema' (FieldValue f sch t), A.FromAvro (FieldValue f sch t))
   fromAvro v = TSimple <$> A.fromAvro v
 
 instance A.FromAvro (FieldValue f sch 'TNull) where
-  fromAvro AVal.Null = return FNull
+  fromAvro AVal.Null = pure FNull
   fromAvro v         = A.badValue v "null"
 instance A.FromAvro t => A.FromAvro (FieldValue f sch ('TPrimitive t)) where
   fromAvro v = FPrimitive <$> A.fromAvro v
@@ -228,7 +228,7 @@ class FromAvroEnum (vs :: [ChoiceDef fn]) where
 instance FromAvroEnum '[] where
   fromAvroEnum v _ = A.badValue v "element not found"
 instance FromAvroEnum vs => FromAvroEnum (v ': vs) where
-  fromAvroEnum _ 0 = return (Z Proxy)
+  fromAvroEnum _ 0 = pure (Z Proxy)
   fromAvroEnum v n = S <$> fromAvroEnum v (n-1)
 
 class FromAvroUnion f sch choices where
@@ -246,7 +246,7 @@ instance (A.FromAvro (FieldValue f sch u), FromAvroUnion f sch us)
 class FromAvroFields f sch (fs :: [FieldDef Symbol Symbol]) where
   fromAvroF :: HM.HashMap T.Text (AVal.Value ASch.Schema) -> A.Result (NP (Field f sch) fs)
 instance FromAvroFields f sch '[] where
-  fromAvroF _ = return Nil
+  fromAvroF _ = pure Nil
 instance (Applicative f, KnownName name, A.FromAvro (FieldValue f sch t), FromAvroFields f sch fs)
          => FromAvroFields f sch ('FieldDef name t ': fs) where
   fromAvroF v = case HM.lookup fieldName v of

adapter/avro/src/Mu/Quasi/Avro.hs

@@ -88,13 +88,15 @@ avdlToDecls schemaName serviceName protocol
            serviceName' = mkName serviceName
        schemaDec <- tySynD schemaName' [] (schemaFromAvro $ S.toList (A.types protocol))
        serviceDec <- tySynD serviceName' []
-         [t| 'Service $(textToStrLit (A.pname protocol)) $(pkgType (A.ns protocol))
-                      $(typesToList <$> mapM (avroMethodToType schemaName') (S.toList $ A.messages protocol)) |]
-       return [schemaDec, serviceDec]
+         [t| 'Package $(pkgType (A.ns protocol))
+                '[ 'Service $(textToStrLit (A.pname protocol)) '[]
+                            $(typesToList <$> mapM (avroMethodToType schemaName')
+                            (S.toList $ A.messages protocol)) ] |]
+       pure [schemaDec, serviceDec]
   where
-    pkgType Nothing = [t| '[] |]
+    pkgType Nothing = [t| 'Nothing |]
     pkgType (Just (A.Namespace p))
-                    = [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |]
+                    = [t| 'Just $(textToStrLit (T.intercalate "." p)) |]
 
 schemaFromAvro :: [A.Schema] -> Q Type
 schemaFromAvro =
@@ -181,20 +183,20 @@ avroMethodToType schemaName m
   where
     argToType :: A.Argument -> Q Type
     argToType (A.Argument (A.NamedType a) _)
-      = [t| 'ArgSingle ('ViaSchema $(conT schemaName) $(textToStrLit (A.baseName a))) |]
+      = [t| 'ArgSingle ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |]
     argToType (A.Argument _ _)
       = fail "only named types may be used as arguments"
 
     retToType :: A.Schema -> Q Type
     retToType A.Null
       = [t| 'RetNothing |]
     retToType (A.NamedType a)
-      = [t| 'RetSingle ('ViaSchema $(conT schemaName) $(textToStrLit (A.baseName a))) |]
+      = [t| 'RetSingle ('SchemaRef $(conT schemaName) $(textToStrLit (A.baseName a))) |]
     retToType _
       = fail "only named types may be used as results"
 
 typesToList :: [Type] -> Type
 typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT
 
 textToStrLit :: T.Text -> Q Type
-textToStrLit s = return $ LitT $ StrTyLit $ T.unpack s
+textToStrLit s = litT $ strTyLit $ T.unpack s

adapter/protobuf/src/Mu/Adapter/ProtoBuf.hs

@@ -225,7 +225,7 @@ instance ProtoBridgeTerm w sch ('DRecord name args)
     t <- PBDec.embedded (protoToTerm @_ @_ @w @sch @('DRecord name args))
     case t of
       Nothing -> PBDec.Parser (\_ -> Left (PBDec.WireTypeError "expected message"))
-      Just v  -> return v
+      Just v  -> pure v
   embedProtoToOneFieldValue = PBDec.embedded' (protoToTerm @_ @_ @w @sch @('DRecord name args))
 
 -- ENUMERATIONS
@@ -256,7 +256,7 @@ instance (KnownNat (FindProtoBufId sch ty c), ProtoBridgeEnum sch ty cs)
     where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c)))
   enumToProto fid (S v) = enumToProto @_ @_ @sch @ty fid v
   protoToEnum n
-    | n == enumValue = return (Z Proxy)
+    | n == enumValue = pure (Z Proxy)
     | otherwise      = S <$> protoToEnum @_ @_ @sch @ty n
     where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c)))
 

adapter/protobuf/src/Mu/Adapter/ProtoBuf/Via.hs

@@ -28,11 +28,11 @@ import           Mu.Schema
 
 -- | Specifies that a type is turned into a Protocol Buffers
 --   message by using the schema as intermediate representation.
-newtype ViaToProtoBufTypeRef (ref :: TypeRef) t
+newtype ViaToProtoBufTypeRef (ref :: TypeRef snm) t
   = ViaToProtoBufTypeRef { unViaToProtoBufTypeRef :: t }
 -- | Specifies that a type can be parsed from a Protocol Buffers
 --   message by using the schema as intermediate representation.
-newtype ViaFromProtoBufTypeRef (ref :: TypeRef) t
+newtype ViaFromProtoBufTypeRef (ref :: TypeRef snm) t
   = ViaFromProtoBufTypeRef { unViaFromProtoBufTypeRef :: t }
 
 instance ToProtoBufTypeRef ref t
@@ -46,29 +46,29 @@ instance FromProtoBufTypeRef ref t
 
 instance Proto3WireEncoder () where
   proto3WireEncode _ = mempty
-  proto3WireDecode = return ()
+  proto3WireDecode = pure ()
 
 -- | Types which can be parsed from a Protocol Buffers message.
-class FromProtoBufTypeRef (ref :: TypeRef) t where
+class FromProtoBufTypeRef (ref :: TypeRef snm) t where
   fromProtoBufTypeRef :: Proxy ref -> PBDec.Parser PBDec.RawMessage t
 -- | Types which can be turned into a Protocol Buffers message.
-class ToProtoBufTypeRef (ref :: TypeRef) t where
+class ToProtoBufTypeRef (ref :: TypeRef snm) t where
   toProtoBufTypeRef   :: Proxy ref -> t -> PBEnc.MessageBuilder
 
 instance (IsProtoSchema Maybe sch sty, FromSchema Maybe sch sty t)
-         => FromProtoBufTypeRef ('ViaSchema sch sty) t where
+         => FromProtoBufTypeRef ('SchemaRef sch sty) t where
   fromProtoBufTypeRef _ = fromProtoViaSchema @_ @_ @sch
 instance (IsProtoSchema Maybe sch sty, ToSchema Maybe sch sty t)
-         => ToProtoBufTypeRef ('ViaSchema sch sty) t where
+         => ToProtoBufTypeRef ('SchemaRef sch sty) t where
   toProtoBufTypeRef   _ = toProtoViaSchema @_ @_ @sch
 
 instance ( FromProtoBufRegistry r t
          , IsProtoSchema Maybe (MappingRight r last) sty
          , FromSchema Maybe (MappingRight r last) sty t )
-         => FromProtoBufTypeRef ('ViaRegistry r t last) t where
+         => FromProtoBufTypeRef ('RegistryRef r t last) t where
   fromProtoBufTypeRef _ = fromProtoBufWithRegistry @r
 instance ( FromProtoBufRegistry r t
          , IsProtoSchema Maybe (MappingRight r last) sty
          , ToSchema Maybe (MappingRight r last) sty t )
-         => ToProtoBufTypeRef ('ViaRegistry r t last) t where
+         => ToProtoBufTypeRef ('RegistryRef r t last) t where
   toProtoBufTypeRef   _ = toProtoViaSchema @_ @_ @(MappingRight r last)

adapter/protobuf/src/Mu/Quasi/GRpc.hs

@@ -60,7 +60,7 @@ grpcToDecls schemaName servicePrefix [email protected] { P.package = pkg, P.services
   = do let schemaName' = mkName schemaName
        schemaDec <- protobufToDecls schemaName p
        serviceTy <- mapM (pbServiceDeclToDec servicePrefix pkg schemaName') srvs
-       return (schemaDec ++ serviceTy)
+       pure (schemaDec ++ serviceTy)
 
 pbServiceDeclToDec :: (String -> String) -> Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Dec
 pbServiceDeclToDec servicePrefix pkg schema srv@(P.Service nm _ _)
@@ -69,11 +69,12 @@ pbServiceDeclToDec servicePrefix pkg schema srv@(P.Service nm _ _)
 
 pbServiceDeclToType :: Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Type
 pbServiceDeclToType pkg schema (P.Service nm _ methods)
-  = [t| 'Service $(textToStrLit nm) $(pkgType pkg)
-                 $(typesToList <$> mapM (pbMethodToType schema) methods) |]
+  = [t| 'Package $(pkgType pkg)
+          '[ 'Service $(textToStrLit nm) '[]
+                      $(typesToList <$> mapM (pbMethodToType schema) methods) ] |]
   where
-    pkgType Nothing  = [t| '[] |]
-    pkgType (Just p) = [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |]
+    pkgType Nothing  = [t| 'Nothing |]
+    pkgType (Just p) = [t| 'Just $(textToStrLit (T.intercalate "." p)) |]
 
 pbMethodToType :: Name -> P.Method -> Q Type
 pbMethodToType s (P.Method nm vr v rr r _)
@@ -83,27 +84,27 @@ pbMethodToType s (P.Method nm vr v rr r _)
     argToType P.Single (P.TOther ["google","protobuf","Empty"])
       = [t| '[ ] |]
     argToType P.Single (P.TOther a)
-      = [t| '[ 'ArgSingle ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) ] |]
+      = [t| '[ 'ArgSingle ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]
     argToType P.Stream (P.TOther a)
-      = [t| '[ 'ArgStream ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) ] |]
+      = [t| '[ 'ArgStream ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]
     argToType _ _
       = fail "only message types may be used as arguments"
 
     retToType P.Single (P.TOther ["google","protobuf","Empty"])
       = [t| 'RetNothing |]
     retToType P.Single (P.TOther a)
-      = [t| 'RetSingle ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) |]
+      = [t| 'RetSingle ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) |]
     retToType P.Stream (P.TOther a)
-      = [t| 'RetStream ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) |]
+      = [t| 'RetStream ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) |]
     retToType _ _
       = fail "only message types may be used as results"
 
 schemaTy :: Name -> Q Type
-schemaTy schema = return $ ConT schema
+schemaTy schema = pure $ ConT schema
 
 typesToList :: [Type] -> Type
 typesToList
   = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT
 textToStrLit :: T.Text -> Q Type
 textToStrLit s
-  = return $ LitT $ StrTyLit $ T.unpack s
+  = pure $ LitT $ StrTyLit $ T.unpack s

adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs

@@ -26,8 +26,8 @@ import           Language.ProtocolBuffers.Parser
 import qualified Language.ProtocolBuffers.Types  as P
 
 import           Mu.Adapter.ProtoBuf
-import           Mu.Schema.Definition
 import           Mu.Schema.Annotations
+import           Mu.Schema.Definition
 
 -- | Reads a @.proto@ file and generates a 'Mu.Schema.Definition.Schema'
 --   with all the message types, using the name given
@@ -46,22 +46,22 @@ protobufToDecls :: String -> P.ProtoBuf -> Q [Dec]
 protobufToDecls schemaName p
   = do let schemaName' = mkName schemaName
        (schTy, annTy) <- schemaFromProtoBuf p
-       schemaDec <- tySynD schemaName' [] (return schTy)
+       schemaDec <- tySynD schemaName' [] (pure schTy)
 #if MIN_VERSION_template_haskell(2,15,0)
        annDec <- tySynInstD (tySynEqn Nothing
                                [t| AnnotatedSchema ProtoBufAnnotation $(conT schemaName') |]
-                               (return annTy))
+                               (pure annTy))
 #else
        annDec <- tySynInstD ''AnnotatedSchema
-                   (tySynEqn [ [t| ProtoBufAnnotation |], conT schemaName' ] (return annTy))
+                   (tySynEqn [ [t| ProtoBufAnnotation |], conT schemaName' ] (pure annTy))
 #endif
-       return [schemaDec, annDec]
+       pure [schemaDec, annDec]
 
 schemaFromProtoBuf :: P.ProtoBuf -> Q (Type, Type)
 schemaFromProtoBuf P.ProtoBuf {P.types = tys} = do
   let decls = flattenDecls tys
   (schTys, anns) <- unzip <$> mapM pbTypeDeclToType decls
-  return (typesToList schTys, typesToList (concat anns))
+  pure (typesToList schTys, typesToList (concat anns))
 
 flattenDecls :: [P.TypeDeclaration] -> [P.TypeDeclaration]
 flattenDecls = concatMap flattenDecl
@@ -73,7 +73,7 @@ flattenDecls = concatMap flattenDecl
 pbTypeDeclToType :: P.TypeDeclaration -> Q (Type, [Type])
 pbTypeDeclToType (P.DEnum name _ fields) = do
   (tys, anns) <- unzip <$> mapM pbChoiceToType fields
-  (,) <$> [t|'DEnum $(textToStrLit name) $(return $ typesToList tys)|] <*> pure anns
+  (,) <$> [t|'DEnum $(textToStrLit name) $(pure $ typesToList tys)|] <*> pure anns
   where
     pbChoiceToType :: P.EnumField -> Q (Type, Type)
     pbChoiceToType (P.EnumField nm number _)
@@ -138,7 +138,7 @@ typesToList :: [Type] -> Type
 typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT
 
 textToStrLit :: T.Text -> Q Type
-textToStrLit s = return $ LitT $ StrTyLit $ T.unpack s
+textToStrLit s = pure $ LitT $ StrTyLit $ T.unpack s
 
 intToLit :: Int -> Q Type
-intToLit n = return $ LitT $ NumTyLit $ toInteger n
+intToLit n = pure $ LitT $ NumTyLit $ toInteger n

cabal-fmt.sh

@@ -1 +1 @@
-find . -name '*.cabal' -exec sh -c 'cabal-fmt $0 > output.tmp; mv output.tmp $0' {} ';'
+find . -name '*.cabal' -exec sh -c 'cabal-fmt -i $0' {} ';'

cabal.project

@@ -16,3 +16,4 @@ packages: compendium-client/
           grpc/common/
           grpc/client/
           grpc/server/
+          graphql/

compendium-client/src/Compendium/Client.hs

@@ -79,8 +79,8 @@ obtainProtoBuf m url ident = do
   r <- transformation m url ident Protobuf
   case r of
     Left e
-      -> return $ Left (OPEClient e)
+      -> pure $ Left (OPEClient e)
     Right p
       -> case parseProtoBuf p of
-          Left e   -> return $ Left (OPEParse e)
-          Right pb -> return $ Right pb
+          Left e   -> pure $ Left (OPEParse e)
+          Right pb -> pure $ Right pb