mu-protobuf 0.3.0.0 → 0.4.0.0

raw patch · 5 files changed

+93/−58 lines, 5 filesdep ~bytestringdep ~compendium-clientdep ~http-clientPVP ok

version bump matches the API change (PVP)

Dependency ranges changed: bytestring, compendium-client, http-client, http2-grpc-proto3-wire, language-protobuf, mu-protobuf, mu-rpc, mu-schema, proto3-wire, servant-client-core, sop-core, template-haskell, text

API changes (from Hackage documentation)

Files

• mu-protobuf.cabal +14/−14
• src/Mu/Adapter/ProtoBuf.hs +22/−3
• src/Mu/Quasi/GRpc.hs +8/−6
• src/Mu/Quasi/ProtoBuf.hs +38/−24
• test/ProtoBuf.hs +11/−11

@@ -1,5 +1,5 @@ name:          mu-protobuf-version:       0.3.0.0+version:       0.4.0.0 synopsis:   Protocol Buffers serialization and gRPC schema import for Mu microservices @@ -32,18 +32,18 @@    build-depends:       base                    >=4.12  && <5-    , bytestring-    , compendium-client       >=0.3.0-    , http-client-    , http2-grpc-proto3-wire-    , language-protobuf-    , mu-rpc                  >=0.3.0-    , mu-schema               >=0.3.0-    , proto3-wire-    , servant-client-core-    , sop-core-    , template-haskell        >=2.12-    , text+    , bytestring              >=0.10  && <0.11+    , compendium-client       ==0.2.*+    , http-client             >=0.6   && <0.7+    , http2-grpc-proto3-wire  >=0.1   && <0.2+    , language-protobuf       >=1.0.1 && <2+    , mu-rpc                  ==0.4.*+    , mu-schema               ==0.3.*+    , proto3-wire             >=1.1   && < 2+    , servant-client-core     >=0.16  && <0.19+    , sop-core                >=0.5   && <0.6+    , template-haskell        >=2.14  && <2.16+    , text                    >=1.2   && <2    hs-source-dirs:   src   default-language: Haskell2010@@ -54,7 +54,7 @@   build-depends:       base         >=4.12  && <5     , bytestring-    , mu-protobuf  >=0.3.0+    , mu-protobuf     , mu-schema    >=0.3.0     , proto3-wire     , text

@@ -26,6 +26,7 @@ module Mu.Adapter.ProtoBuf (   -- * Custom annotations   ProtoBufAnnotation(..)+, ProtoBufOptionConstant(..)   -- * Conversion using schemas , IsProtoSchema , toProtoViaSchema@@ -62,16 +63,23 @@ data ProtoBufAnnotation   = -- | Numeric field identifier for normal fields     --   and whether it should be packed (only used for lists of number-like values)-    ProtoBufId Nat Bool+    ProtoBufId Nat [(Symbol, ProtoBufOptionConstant)]     -- | List of identifiers for fields which contain a union   | ProtoBufOneOfIds [Nat] +-- Values for constants+data ProtoBufOptionConstant+  = ProtoBufOptionConstantInt    Nat+  | ProtoBufOptionConstantBool   Bool+  | ProtoBufOptionConstantObject [(Symbol, ProtoBufOptionConstant)]+  | ProtoBufOptionConstantOther  Symbol+ type family FindProtoBufId (sch :: Schema tn fn) (t :: tn) (f :: fn) where   FindProtoBufId sch t f     = FindProtoBufId' t f (GetFieldAnnotation (AnnotatedSchema ProtoBufAnnotation sch) t f)  type family FindProtoBufId' (t :: tn) (f :: fn) (p :: ProtoBufAnnotation) :: Nat where-  FindProtoBufId' t f ('ProtoBufId n b) = n+  FindProtoBufId' t f ('ProtoBufId n opts) = n   FindProtoBufId' t f other     = TypeError ('Text "protocol buffers id not available for field "                  ':<>: 'ShowType t ':<>: 'Text "/" ':<>: 'ShowType f)@@ -81,10 +89,21 @@     = FindProtoBufPacked' t f (GetFieldAnnotation (AnnotatedSchema ProtoBufAnnotation sch) t f)  type family FindProtoBufPacked' (t :: tn) (f :: fn) (p :: ProtoBufAnnotation) :: Bool where-  FindProtoBufPacked' t f ('ProtoBufId n b) = b+  FindProtoBufPacked' t f ('ProtoBufId n opts)+    = FindProtoBufPacked'' t f opts   FindProtoBufPacked' t f other     = TypeError ('Text "protocol buffers id not available for field "                  ':<>: 'ShowType t ':<>: 'Text "/" ':<>: 'ShowType f)++type family FindProtoBufPacked'' (t :: tn) (f :: fn) (opts :: [(Symbol, ProtoBufOptionConstant)]) :: Bool where+  FindProtoBufPacked'' t f '[] = 'True  -- by default we are packed+  FindProtoBufPacked'' t f ( '("packed", 'ProtoBufOptionConstantBool b) ': rest )+    = b  -- found!+  FindProtoBufPacked'' t f ( '("packed", other) ': rest )+    = TypeError ('Text "non-boolean value for 'packed' for field "+                 ':<>: 'ShowType t ':<>: 'Text "/" ':<>: 'ShowType f)+  FindProtoBufPacked'' t f ( other ': rest)+    = FindProtoBufPacked'' t f rest  type family FindProtoBufOneOfIds (sch :: Schema tn fn) (t :: tn) (f :: fn) where   FindProtoBufOneOfIds sch t f

@@ -1,4 +1,5 @@ {-# language DataKinds         #-}+{-# language KindSignatures    #-} {-# language OverloadedStrings #-} {-# language TemplateHaskell   #-} {-|@@ -16,6 +17,7 @@  import           Control.Monad.IO.Class import qualified Data.Text                       as T+import           GHC.TypeLits import           Language.Haskell.TH import           Language.ProtocolBuffers.Parser import qualified Language.ProtocolBuffers.Types  as P@@ -70,23 +72,23 @@ pbServiceDeclToType :: Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Type pbServiceDeclToType pkg schema (P.Service nm _ methods)   = [t| 'Package $(pkgType pkg)-          '[ 'Service $(textToStrLit nm) '[]+          '[ 'Service $(textToStrLit nm)                       $(typesToList <$> mapM (pbMethodToType schema) methods) ] |]   where-    pkgType Nothing  = [t| 'Nothing |]+    pkgType Nothing  = [t| ('Nothing :: Maybe Symbol) |]     pkgType (Just p) = [t| 'Just $(textToStrLit (T.intercalate "." p)) |]  pbMethodToType :: Name -> P.Method -> Q Type pbMethodToType s (P.Method nm vr v rr r _)-  = [t| 'Method $(textToStrLit nm) '[]+  = [t| 'Method $(textToStrLit nm)                 $(argToType vr v) $(retToType rr r) |]   where     argToType P.Single (P.TOther ["google","protobuf","Empty"])       = [t| '[ ] |]     argToType P.Single (P.TOther a)-      = [t| '[ 'ArgSingle 'Nothing '[] ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]+      = [t| '[ 'ArgSingle ('Nothing :: Maybe Symbol) ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]     argToType P.Stream (P.TOther a)-      = [t| '[ 'ArgStream 'Nothing '[] ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]+      = [t| '[ 'ArgStream ('Nothing :: Maybe Symbol) ('SchemaRef $(schemaTy s) $(textToStrLit (last a))) ] |]     argToType _ _       = fail "only message types may be used as arguments" @@ -104,7 +106,7 @@  typesToList :: [Type] -> Type typesToList-  = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT+  = foldr (AppT . AppT PromotedConsT) PromotedNilT textToStrLit :: T.Text -> Q Type textToStrLit s   = pure $ LitT $ StrTyLit $ T.unpack s

@@ -18,6 +18,7 @@   , protobufToDecls   ) where +import           Control.Monad                   (when) import           Control.Monad.IO.Class import qualified Data.ByteString                 as B import           Data.Int@@ -79,7 +80,7 @@     pbChoiceToType :: P.EnumField -> Q (Type, Type)     pbChoiceToType (P.EnumField nm number _)       = (,) <$> [t|'ChoiceDef $(textToStrLit nm) |]-            <*> [t|'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit number) 'True) |]+            <*> [t|'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit number) '[]) |] pbTypeDeclToType (P.DMessage name _ _ fields _) = do   (tys, anns) <- unzip <$> mapM pbMsgFieldToType fields   (,) <$> [t|'DRecord $(textToStrLit name) $(pure $ typesToList tys)|] <*> pure anns@@ -89,23 +90,23 @@     -- it's possible to distinguish whether it's missing on wire     -- or should be set to the default, so use Option     -- +info -> https://github.com/higherkindness/mu-haskell/pull/130#issuecomment-596433307-    pbMsgFieldToType (P.NormalField P.Single ty@(P.TOther _) nm n opts)-      = (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TOption $(pbFieldTypeToType ty)) |]-            <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(pbOptionsToPacked opts)) |]-    pbMsgFieldToType (P.NormalField P.Single ty nm n opts)-      = (,) <$> [t| 'FieldDef $(textToStrLit nm) $(pbFieldTypeToType ty) |]-            <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(pbOptionsToPacked opts)) |]-    pbMsgFieldToType (P.NormalField P.Repeated ty nm n opts)-      = (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TList $(pbFieldTypeToType ty)) |]-            <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(pbOptionsToPacked opts)) |]-    pbMsgFieldToType (P.MapField k v nm n opts)-      = (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v)) |]-            <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(pbOptionsToPacked opts)) |]+    pbMsgFieldToType (P.NormalField P.Single ty@(P.TOther _) nm n opts) =+        (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TOption $(pbFieldTypeToType ty)) |]+            <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption opts)) |]+    pbMsgFieldToType (P.NormalField P.Single ty nm n opts) =+        (,) <$> [t| 'FieldDef $(textToStrLit nm) $(pbFieldTypeToType ty) |]+            <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption opts)) |]+    pbMsgFieldToType (P.NormalField P.Repeated ty nm n opts) =+        (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TList $(pbFieldTypeToType ty)) |]+            <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption opts)) |]+    pbMsgFieldToType (P.MapField k v nm n opts) =+        (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v)) |]+            <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n) $(typesToList <$> mapM pbOption opts)) |]     pbMsgFieldToType (P.OneOfField nm vs)-      | any (not . hasFieldNumber) vs+      | not (all hasFieldNumber vs)       = fail "nested oneof fields are not supported"       | otherwise-      = (,) <$> [t| 'FieldDef $(textToStrLit nm) $(typesToList <$> mapM pbOneOfFieldToType vs ) |]+      = (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TUnion $(typesToList <$> mapM pbOneOfFieldToType vs )) |]             <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm)                        ('ProtoBufOneOfIds $(typesToList <$> mapM (intToLit . getFieldNumber) vs )) |] @@ -142,17 +143,30 @@       = [t| 'TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v) |]     pbOneOfFieldToType _ = error "this should never happen" -    pbOptionsToPacked []-      = [t| 'True |]-    pbOptionsToPacked (P.Option ["packed"] val : _)-      | P.KBool True  <- val = [t| 'True  |]-      | P.KBool False <- val = [t| 'False |]-      | otherwise = fail "'packed' with a non-boolean value"-    pbOptionsToPacked (_ : rest)-      = pbOptionsToPacked rest+    pbOption (P.Option oname val)+      = do when (oname == ["default"])+                (reportError "mu-protobuf does not (yet) support default values")+           [t| '( $(textToStrLit (T.intercalate "." oname))+                , $(pbConstantToOption val) ) |] +    pbConstantToOption (P.KIdentifier names)+      = [t| 'ProtoBufOptionConstantOther $(textToStrLit (T.intercalate "." names)) |]+    pbConstantToOption (P.KInt n)+      = [t| 'ProtoBufOptionConstantInt $(intToLit (fromInteger n)) |]+    pbConstantToOption (P.KBool True)+      = [t| 'ProtoBufOptionConstantBool 'True |]+    pbConstantToOption (P.KBool False)+      = [t| 'ProtoBufOptionConstantBool 'False |]+    pbConstantToOption (P.KString s)+      = [t| 'ProtoBufOptionConstantOther $(textToStrLit s) |]+    pbConstantToOption (P.KFloat s)+      = [t| 'ProtoBufOptionConstantOther $(textToStrLit (T.pack (show s))) |]+    pbConstantToOption (P.KObject s)+      = [t| 'ProtoBufOptionConstantObject+            $(typesToList <$> mapM (\(n, o) -> [t| '( $(textToStrLit n), $(pbConstantToOption o) ) |] ) s ) |]+ typesToList :: [Type] -> Type-typesToList = foldr (\y ys -> AppT (AppT PromotedConsT y) ys) PromotedNilT+typesToList = foldr (AppT . AppT PromotedConsT) PromotedNilT  textToStrLit :: T.Text -> Q Type textToStrLit s = pure $ LitT $ StrTyLit $ T.unpack s

@@ -39,17 +39,17 @@   deriving (FromSchema ExampleSchema "address")  type instance AnnotatedSchema ProtoBufAnnotation ExampleSchema-  = '[ 'AnnField "gender" "male"   ('ProtoBufId 1 'True)-     , 'AnnField "gender" "female" ('ProtoBufId 2 'True)-     , 'AnnField "gender" "nb"     ('ProtoBufId 3 'True)-     , 'AnnField "address" "postcode" ('ProtoBufId 1 'True)-     , 'AnnField "address" "country"  ('ProtoBufId 2 'True)-     , 'AnnField "person" "firstName" ('ProtoBufId 1 'True)-     , 'AnnField "person" "lastName"  ('ProtoBufId 2 'True)-     , 'AnnField "person" "age"       ('ProtoBufId 3 'True)-     , 'AnnField "person" "gender"    ('ProtoBufId 4 'True)-     , 'AnnField "person" "address"   ('ProtoBufId 5 'True)-     , 'AnnField "person" "lucky_numbers" ('ProtoBufId 6 'True) ]+  = '[ 'AnnField "gender" "male"   ('ProtoBufId 1 '[])+     , 'AnnField "gender" "female" ('ProtoBufId 2 '[])+     , 'AnnField "gender" "nb"     ('ProtoBufId 3 '[])+     , 'AnnField "address" "postcode" ('ProtoBufId 1 '[])+     , 'AnnField "address" "country"  ('ProtoBufId 2 '[])+     , 'AnnField "person" "firstName" ('ProtoBufId 1 '[])+     , 'AnnField "person" "lastName"  ('ProtoBufId 2 '[])+     , 'AnnField "person" "age"       ('ProtoBufId 3 '[])+     , 'AnnField "person" "gender"    ('ProtoBufId 4 '[])+     , 'AnnField "person" "address"   ('ProtoBufId 5 '[])+     , 'AnnField "person" "lucky_numbers" ('ProtoBufId 6 '[ '("packed", 'ProtoBufOptionConstantBool 'True) ]) ]  exampleAddress :: MAddress exampleAddress = MAddress "1111BB" "Spain"