From 0a9020a0d80d825611fee6861d87d5aadcc4cf69 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Reto=20K=C3=BChni?= Date: Sat, 3 Feb 2024 01:42:38 +0100 Subject: [PATCH] #257 --- adapter/protobuf/mu-protobuf.cabal | 1 + adapter/protobuf/src/Mu/Quasi/GRpc.hs | 10 +-- adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs | 75 +++++++++++++------ .../protobuf/src/Mu/Quasi/ProtoBuf/Example.hs | 10 ++- .../test/protobuf/exampleWithImports.proto | 7 ++ adapter/protobuf/test/protobuf/import.proto | 34 +++++++++ 6 files changed, 105 insertions(+), 32 deletions(-) create mode 100644 adapter/protobuf/test/protobuf/exampleWithImports.proto create mode 100644 adapter/protobuf/test/protobuf/import.proto diff --git a/adapter/protobuf/mu-protobuf.cabal b/adapter/protobuf/mu-protobuf.cabal index 5a7113c2..cc91577d 100644 --- a/adapter/protobuf/mu-protobuf.cabal +++ b/adapter/protobuf/mu-protobuf.cabal @@ -44,6 +44,7 @@ library , sop-core >=0.5 && <0.6 , template-haskell >=2.14 && <2.19 , text >=1.2 && <2 + , filepath >=1.4 && <2 hs-source-dirs: src default-language: Haskell2010 diff --git a/adapter/protobuf/src/Mu/Quasi/GRpc.hs b/adapter/protobuf/src/Mu/Quasi/GRpc.hs index 15e76bcc..851d8f4d 100644 --- a/adapter/protobuf/src/Mu/Quasi/GRpc.hs +++ b/adapter/protobuf/src/Mu/Quasi/GRpc.hs @@ -10,7 +10,7 @@ and a set of 'Service's. -} module Mu.Quasi.GRpc ( grpc -) where + ) where import Control.Monad.IO.Class import qualified Data.Text as T @@ -35,12 +35,12 @@ grpc schemaName servicePrefix fp Left e -> fail ("could not parse protocol buffers spec: " ++ show e) Right p - -> grpcToDecls schemaName servicePrefix p + -> grpcToDecls schemaName servicePrefix p =<< loadImports fp p -grpcToDecls :: String -> (String -> String) -> P.ProtoBuf -> Q [Dec] -grpcToDecls schemaName servicePrefix p@P.ProtoBuf { P.package = pkg, P.services = srvs } +grpcToDecls :: String -> (String -> String) -> P.ProtoBuf -> [P.ProtoBuf] -> Q [Dec] +grpcToDecls schemaName servicePrefix p@P.ProtoBuf { P.package = pkg, P.services = srvs } imps = do let schemaName' = mkName schemaName - schemaDec <- protobufToDecls schemaName p + schemaDec <- protobufToDecls schemaName p imps serviceTy <- mapM (pbServiceDeclToDec servicePrefix pkg schemaName') srvs pure (schemaDec ++ serviceTy) diff --git a/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs b/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs index 7360e6b7..70e54c9b 100644 --- a/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs +++ b/adapter/protobuf/src/Mu/Quasi/ProtoBuf.hs @@ -4,6 +4,7 @@ {-# language NamedFieldPuns #-} {-# language OverloadedStrings #-} {-# language TemplateHaskell #-} +{-# language ViewPatterns #-} {-| Description : Quasi-quoters for Protocol Buffers schemas @@ -16,19 +17,22 @@ module Mu.Quasi.ProtoBuf ( protobuf -- * Only for internal use , protobufToDecls + , loadImports ) where -import Control.Monad (when) +import Control.Monad (foldM, when) import Control.Monad.IO.Class import qualified Data.ByteString as B import Data.Int import qualified Data.List as L -import Data.List.NonEmpty (NonEmpty (..)) +import Data.List.NonEmpty (NonEmpty (..), toList) +import qualified Data.Map.Strict as M import qualified Data.Text as T import Data.Word import Language.Haskell.TH import Language.ProtocolBuffers.Parser import qualified Language.ProtocolBuffers.Types as P +import System.FilePath (takeDirectory, ()) import Mu.Adapter.ProtoBuf import Mu.Schema.Annotations @@ -44,13 +48,31 @@ protobuf schemaName fp Left e -> fail ("could not parse protocol buffers spec: " ++ show e) Right p - -> protobufToDecls schemaName p + -> protobufToDecls schemaName p =<< loadImports fp p + +loadImports :: FilePath -> P.ProtoBuf -> Q [P.ProtoBuf] +loadImports rootFp p = M.elems <$> loadImports' M.empty rootFp p + where + loadImports' :: M.Map FilePath P.ProtoBuf -> FilePath -> P.ProtoBuf -> Q (M.Map FilePath P.ProtoBuf) + loadImports' m fp p' = foldM (loadImport fp) m $ P.imports p' + loadImport :: FilePath -> M.Map FilePath P.ProtoBuf -> (P.ImportType, T.Text) -> Q (M.Map FilePath P.ProtoBuf) + loadImport parentFp m (_, relFP) = do + let fp = takeDirectory parentFp T.unpack relFP + if fp `M.member` m + then pure m + else do + r <- liftIO $ parseProtoBufFile fp + case r of + Left e -> do + reportError $ "Include " <> fp <> " of " <> parentFp <> " not found: " <> show e + pure m + Right proto -> loadImports' (M.insert fp proto m) fp proto -- | Shared portion of Protocol Buffers and gRPC quasi-quoters. -protobufToDecls :: String -> P.ProtoBuf -> Q [Dec] -protobufToDecls schemaName p +protobufToDecls :: String -> P.ProtoBuf -> [P.ProtoBuf] -> Q [Dec] +protobufToDecls schemaName p imps = do let schemaName' = mkName schemaName - (schTy, annTy) <- schemaFromProtoBuf p + (schTy, annTy) <- schemaFromProtoBuf p imps schemaDec <- tySynD schemaName' [] (pure schTy) #if MIN_VERSION_template_haskell(2,15,0) annDec <- tySynInstD (tySynEqn Nothing @@ -62,14 +84,14 @@ protobufToDecls schemaName p #endif pure [schemaDec, annDec] -schemaFromProtoBuf :: P.ProtoBuf -> Q (Type, Type) -schemaFromProtoBuf P.ProtoBuf {P.types = tys} = do - let decls = flattenDecls (("", tys) :| []) tys +schemaFromProtoBuf :: P.ProtoBuf -> [P.ProtoBuf] -> Q (Type, Type) +schemaFromProtoBuf P.ProtoBuf {P.types = tys} imps = do + let decls = flattenDecls (("", tys) :| []) tys <> flattenImportDecls imps (schTys, anns) <- unzip <$> mapM (pbTypeDeclToType $ shouldOptional decls) decls pure (typesToList schTys, typesToList (concat anns)) where shouldOptional :: [P.TypeDeclaration] -> P.TypeName -> Bool - shouldOptional [] _ = error "this should never happen" + shouldOptional [] this = error $ T.unpack $ "no declaration for type " <> T.intercalate "." this shouldOptional (P.DMessage nm _ _ _ _ : _) this | nm == last this = True shouldOptional (P.DEnum nm _ _ : _) this @@ -77,6 +99,15 @@ schemaFromProtoBuf P.ProtoBuf {P.types = tys} = do shouldOptional (_ : rest) this = shouldOptional rest this +flattenImportDecls :: [P.ProtoBuf] -> [P.TypeDeclaration] +flattenImportDecls = concatMap flattenImportDecls' + where + flattenImportDecls' :: P.ProtoBuf -> [P.TypeDeclaration] + flattenImportDecls' P.ProtoBuf { P.types = tys, P.package = getPackageName -> pkg } = + flattenDecls ((pkg, tys) :| []) tys + getPackageName :: Maybe P.FullIdentifier -> T.Text + getPackageName = maybe "" (T.intercalate ".") + flattenDecls :: NonEmpty (P.Identifier, [P.TypeDeclaration]) -> [P.TypeDeclaration] -> [P.TypeDeclaration] flattenDecls (currentScope :| higherScopes) = concatMap flattenDecl where @@ -84,7 +115,7 @@ flattenDecls (currentScope :| higherScopes) = concatMap flattenDecl flattenDecl (P.DMessage name o r fs decls) = let newScopeName = prependCurrentScope name newScopes = (newScopeName, decls) :| (currentScope : higherScopes) - in P.DMessage newScopeName o r (scopeFieldType newScopes <$> fs) [] : flattenDecls newScopes decls + in P.DMessage newScopeName o r (scopeFieldType (toList newScopes) <$> fs) [] : flattenDecls newScopes decls scopeFieldType scopes (P.NormalField frep ftype fname fnum fopts) = P.NormalField frep (qualifyType scopes ftype) fname fnum fopts @@ -95,17 +126,15 @@ flattenDecls (currentScope :| higherScopes) = concatMap flattenDecl qualifyType scopes (P.TOther ts) = P.TOther (qualifyTOther scopes ts) qualifyType _scopes t = t - qualifyTOther _scopes [] = error "This shouldn't be possible" - qualifyTOther ((_, _) :| []) ts = - [T.intercalate "." ts] -- Top level scope, no need to search anything, use - -- the name as is. Maybe we should search and fail - -- if a type is not found even from top level, but - -- that could be a lot of work as this function is - -- pure right now. - qualifyTOther ((scopeName, decls) :| (restFirst : restTail)) ts = + qualifyTOther _ [] = error "This shouldn't be possible" + qualifyTOther [] ts = [T.intercalate "." ts] + qualifyTOther ((scopeName, decls) : rest) ts = if L.any (hasDeclFor ts) decls - then [T.intercalate "." (scopeName:ts)] - else qualifyTOther (restFirst :| restTail) ts + then [qualifyName scopeName ts] + else qualifyTOther rest ts + where + qualifyName "" ts' = T.intercalate "." ts' + qualifyName sn ts'=qualifyName "" (sn:ts') hasDeclFor [] _ = True hasDeclFor [t] (P.DEnum enumName _ _) = t == enumName @@ -120,7 +149,7 @@ flattenDecls (currentScope :| higherScopes) = concatMap flattenDecl prependCurrentScope x = case fst currentScope of "" -> x - _ -> fst currentScope <> "." <> x + sn -> sn <> "." <> x pbTypeDeclToType :: (P.TypeName -> Bool) -> P.TypeDeclaration -> Q (Type, [Type]) pbTypeDeclToType _ (P.DEnum name _ fields) = do @@ -179,7 +208,7 @@ pbTypeDeclToType shouldOptional (P.DMessage name _ _ fields _) = do pbFieldTypeToType P.TBool = [t|'TPrimitive Bool|] pbFieldTypeToType P.TString = [t|'TPrimitive T.Text|] pbFieldTypeToType P.TBytes = [t|'TPrimitive B.ByteString|] - pbFieldTypeToType (P.TOther t) = [t|'TSchematic $(textToStrLit (last t))|] + pbFieldTypeToType (P.TOther t) = [t|'TSchematic $(textToStrLit (T.intercalate "." t))|] hasFieldNumber P.NormalField {} = True hasFieldNumber P.MapField {} = True diff --git a/adapter/protobuf/src/Mu/Quasi/ProtoBuf/Example.hs b/adapter/protobuf/src/Mu/Quasi/ProtoBuf/Example.hs index 9f7cb08a..b655fdd2 100644 --- a/adapter/protobuf/src/Mu/Quasi/ProtoBuf/Example.hs +++ b/adapter/protobuf/src/Mu/Quasi/ProtoBuf/Example.hs @@ -12,9 +12,11 @@ module Mu.Quasi.ProtoBuf.Example where import Mu.Quasi.ProtoBuf #if __GHCIDE__ -protobuf "ExampleProtoBufSchema" "adapter/protobuf/test/protobuf/example.proto" -protobuf "Example2ProtoBufSchema" "adapter/protobuf/test/protobuf/example2.proto" +protobuf "ExampleProtoBufSchema" "adapter/protobuf/test/protobuf/example.proto" +protobuf "Example2ProtoBufSchema" "adapter/protobuf/test/protobuf/example2.proto" +protobuf "ExampleWithImportsProtoBufSchema" "adapter/protobuf/test/protobuf/exampleWithImports.proto" #else -protobuf "ExampleProtoBufSchema" "test/protobuf/example.proto" -protobuf "Example2ProtoBufSchema" "test/protobuf/example2.proto" +protobuf "ExampleProtoBufSchema" "test/protobuf/example.proto" +protobuf "Example2ProtoBufSchema" "test/protobuf/example2.proto" +protobuf "ExampleWithImportsProtoBufSchema" "test/protobuf/exampleWithImports.proto" #endif diff --git a/adapter/protobuf/test/protobuf/exampleWithImports.proto b/adapter/protobuf/test/protobuf/exampleWithImports.proto new file mode 100644 index 00000000..60d483ab --- /dev/null +++ b/adapter/protobuf/test/protobuf/exampleWithImports.proto @@ -0,0 +1,7 @@ +syntax = "proto3"; + +import "import.proto"; + +message messageWithImports { + imports.Message message = 1; +} diff --git a/adapter/protobuf/test/protobuf/import.proto b/adapter/protobuf/test/protobuf/import.proto new file mode 100644 index 00000000..d7bbf0b1 --- /dev/null +++ b/adapter/protobuf/test/protobuf/import.proto @@ -0,0 +1,34 @@ +syntax = "proto3"; + +package imports; + +message Message { + MessageA a = 1; + oneof union { + MessageB b = 2; + MessageC c = 3; + } + Enum e = 4; + Nested nested = 5; + + message Nested { + string value = 1; + } +} + +message MessageA { + string text = 1; +} + +message MessageB { + string text = 1; +} + +message MessageC { + string text = 1; +} + +enum Enum { + Value1 = 0; + Value2 = 1; +}