mu-protobuf (empty) → 0.1.0.0
raw patch · 10 files changed
+1139/−0 lines, 10 filesdep +basedep +bytestringdep +compendium-client
Dependencies added: base, 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
Files
- LICENSE +202/−0
- mu-protobuf.cabal +56/−0
- src/Mu/Adapter/ProtoBuf.hs +427/−0
- src/Mu/Adapter/ProtoBuf/Via.hs +74/−0
- src/Mu/Quasi/GRpc.hs +109/−0
- src/Mu/Quasi/ProtoBuf.hs +144/−0
- src/Mu/Quasi/ProtoBuf/Example.hs +20/−0
- test/ProtoBuf.hs +75/−0
- test/protobuf/example.proto +20/−0
- test/protobuf/example2.proto +12/−0
+ LICENSE view
@@ -0,0 +1,202 @@++ Apache License+ Version 2.0, January 2004+ http://www.apache.org/licenses/++ TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION++ 1. Definitions.++ "License" shall mean the terms and conditions for use, reproduction,+ and distribution as defined by Sections 1 through 9 of this document.++ "Licensor" shall mean the copyright owner or entity authorized by+ the copyright owner that is granting the License.++ "Legal Entity" shall mean the union of the acting entity and all+ other entities that control, are controlled by, or are under common+ control with that entity. For the purposes of this definition,+ "control" means (i) the power, direct or indirect, to cause the+ direction or management of such entity, whether by contract or+ otherwise, or (ii) ownership of fifty percent (50%) or more of the+ outstanding shares, or (iii) beneficial ownership of such entity.++ "You" (or "Your") shall mean an individual or Legal Entity+ exercising permissions granted by this License.++ "Source" form shall mean the preferred form for making modifications,+ including but not limited to software source code, documentation+ source, and configuration files.++ "Object" form shall mean any form resulting from mechanical+ transformation or translation of a Source form, including but+ not limited to compiled object code, generated documentation,+ and conversions to other media types.++ "Work" shall mean the work of authorship, whether in Source or+ Object form, made available under the License, as indicated by a+ copyright notice that is included in or attached to the work+ (an example is provided in the Appendix below).++ "Derivative Works" shall mean any work, whether in Source or Object+ form, that is based on (or derived from) the Work and for which the+ editorial revisions, annotations, elaborations, or other modifications+ represent, as a whole, an original work of authorship. For the purposes+ of this License, Derivative Works shall not include works that remain+ separable from, or merely link (or bind by name) to the interfaces of,+ the Work and Derivative Works thereof.++ "Contribution" shall mean any work of authorship, including+ the original version of the Work and any modifications or additions+ to that Work or Derivative Works thereof, that is intentionally+ submitted to Licensor for inclusion in the Work by the copyright owner+ or by an individual or Legal Entity authorized to submit on behalf of+ the copyright owner. For the purposes of this definition, "submitted"+ means any form of electronic, verbal, or written communication sent+ to the Licensor or its representatives, including but not limited to+ communication on electronic mailing lists, source code control systems,+ and issue tracking systems that are managed by, or on behalf of, the+ Licensor for the purpose of discussing and improving the Work, but+ excluding communication that is conspicuously marked or otherwise+ designated in writing by the copyright owner as "Not a Contribution."++ "Contributor" shall mean Licensor and any individual or Legal Entity+ on behalf of whom a Contribution has been received by Licensor and+ subsequently incorporated within the Work.++ 2. Grant of Copyright License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ copyright license to reproduce, prepare Derivative Works of,+ publicly display, publicly perform, sublicense, and distribute the+ Work and such Derivative Works in Source or Object form.++ 3. Grant of Patent License. Subject to the terms and conditions of+ this License, each Contributor hereby grants to You a perpetual,+ worldwide, non-exclusive, no-charge, royalty-free, irrevocable+ (except as stated in this section) patent license to make, have made,+ use, offer to sell, sell, import, and otherwise transfer the Work,+ where such license applies only to those patent claims licensable+ by such Contributor that are necessarily infringed by their+ Contribution(s) alone or by combination of their Contribution(s)+ with the Work to which such Contribution(s) was submitted. If You+ institute patent litigation against any entity (including a+ cross-claim or counterclaim in a lawsuit) alleging that the Work+ or a Contribution incorporated within the Work constitutes direct+ or contributory patent infringement, then any patent licenses+ granted to You under this License for that Work shall terminate+ as of the date such litigation is filed.++ 4. Redistribution. You may reproduce and distribute copies of the+ Work or Derivative Works thereof in any medium, with or without+ modifications, and in Source or Object form, provided that You+ meet the following conditions:++ (a) You must give any other recipients of the Work or+ Derivative Works a copy of this License; and++ (b) You must cause any modified files to carry prominent notices+ stating that You changed the files; and++ (c) You must retain, in the Source form of any Derivative Works+ that You distribute, all copyright, patent, trademark, and+ attribution notices from the Source form of the Work,+ excluding those notices that do not pertain to any part of+ the Derivative Works; and++ (d) If the Work includes a "NOTICE" text file as part of its+ distribution, then any Derivative Works that You distribute must+ include a readable copy of the attribution notices contained+ within such NOTICE file, excluding those notices that do not+ pertain to any part of the Derivative Works, in at least one+ of the following places: within a NOTICE text file distributed+ as part of the Derivative Works; within the Source form or+ documentation, if provided along with the Derivative Works; or,+ within a display generated by the Derivative Works, if and+ wherever such third-party notices normally appear. The contents+ of the NOTICE file are for informational purposes only and+ do not modify the License. You may add Your own attribution+ notices within Derivative Works that You distribute, alongside+ or as an addendum to the NOTICE text from the Work, provided+ that such additional attribution notices cannot be construed+ as modifying the License.++ You may add Your own copyright statement to Your modifications and+ may provide additional or different license terms and conditions+ for use, reproduction, or distribution of Your modifications, or+ for any such Derivative Works as a whole, provided Your use,+ reproduction, and distribution of the Work otherwise complies with+ the conditions stated in this License.++ 5. Submission of Contributions. Unless You explicitly state otherwise,+ any Contribution intentionally submitted for inclusion in the Work+ by You to the Licensor shall be under the terms and conditions of+ this License, without any additional terms or conditions.+ Notwithstanding the above, nothing herein shall supersede or modify+ the terms of any separate license agreement you may have executed+ with Licensor regarding such Contributions.++ 6. Trademarks. This License does not grant permission to use the trade+ names, trademarks, service marks, or product names of the Licensor,+ except as required for reasonable and customary use in describing the+ origin of the Work and reproducing the content of the NOTICE file.++ 7. Disclaimer of Warranty. Unless required by applicable law or+ agreed to in writing, Licensor provides the Work (and each+ Contributor provides its Contributions) on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or+ implied, including, without limitation, any warranties or conditions+ of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A+ PARTICULAR PURPOSE. You are solely responsible for determining the+ appropriateness of using or redistributing the Work and assume any+ risks associated with Your exercise of permissions under this License.++ 8. Limitation of Liability. In no event and under no legal theory,+ whether in tort (including negligence), contract, or otherwise,+ unless required by applicable law (such as deliberate and grossly+ negligent acts) or agreed to in writing, shall any Contributor be+ liable to You for damages, including any direct, indirect, special,+ incidental, or consequential damages of any character arising as a+ result of this License or out of the use or inability to use the+ Work (including but not limited to damages for loss of goodwill,+ work stoppage, computer failure or malfunction, or any and all+ other commercial damages or losses), even if such Contributor+ has been advised of the possibility of such damages.++ 9. Accepting Warranty or Additional Liability. While redistributing+ the Work or Derivative Works thereof, You may choose to offer,+ and charge a fee for, acceptance of support, warranty, indemnity,+ or other liability obligations and/or rights consistent with this+ License. However, in accepting such obligations, You may act only+ on Your own behalf and on Your sole responsibility, not on behalf+ of any other Contributor, and only if You agree to indemnify,+ defend, and hold each Contributor harmless for any liability+ incurred by, or claims asserted against, such Contributor by reason+ of your accepting any such warranty or additional liability.++ END OF TERMS AND CONDITIONS++ APPENDIX: How to apply the Apache License to your work.++ To apply the Apache License to your work, attach the following+ boilerplate notice, with the fields enclosed by brackets "[]"+ replaced with your own identifying information. (Don't include+ the brackets!) The text should be enclosed in the appropriate+ comment syntax for the file format. We also recommend that a+ file or class name and description of purpose be included on the+ same "printed page" as the copyright notice for easier+ identification within third-party archives.++ Copyright © 2019-2020 47 Degrees. <http://47deg.com>++ Licensed under the Apache License, Version 2.0 (the "License");+ you may not use this file except in compliance with the License.+ You may obtain a copy of the License at++ http://www.apache.org/licenses/LICENSE-2.0++ Unless required by applicable law or agreed to in writing, software+ distributed under the License is distributed on an "AS IS" BASIS,+ WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.+ See the License for the specific language governing permissions and+ limitations under the License.
+ mu-protobuf.cabal view
@@ -0,0 +1,56 @@+cabal-version: >=1.10+name: mu-protobuf+version: 0.1.0.0+synopsis: Protocol Buffers serialization and gRPC schema import for Mu microservices+description: You can use @mu-protobuf@ to read Protobuf Schema Declarations and services for mu-haskell+license: Apache-2.0+license-file: LICENSE+author: Alejandro Serrano, Flavio Corpa+maintainer: alejandro.serrano@47deg.com+copyright: Copyright © 2019-2020 <http://47deg.com 47 Degrees>+category: Network+build-type: Simple+data-files: test/protobuf/*.proto+homepage: https://higherkindness.io/mu-haskell/+bug-reports: https://github.com/higherkindness/mu-haskell/issues++source-repository head+ type: git+ location: https://github.com/higherkindness/mu-haskell++library+ exposed-modules: Mu.Adapter.ProtoBuf+ , Mu.Adapter.ProtoBuf.Via+ , Mu.Quasi.ProtoBuf+ , Mu.Quasi.GRpc+ , Mu.Quasi.ProtoBuf.Example+ build-depends: base >=4.12 && <5+ , mu-schema+ , mu-rpc+ , text+ , sop-core+ , proto3-wire+ , bytestring+ , template-haskell >= 2.12+ , language-protobuf+ , compendium-client+ , http-client+ , servant-client-core+ , http2-grpc-proto3-wire+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall+ -fprint-potential-instances++executable test-protobuf+ main-is: ProtoBuf.hs+ build-depends: base >=4.12 && <5+ , mu-schema+ , mu-protobuf+ , bytestring+ , text+ , proto3-wire+ hs-source-dirs: test+ default-language: Haskell2010+ ghc-options: -Wall+ -fprint-explicit-foralls
+ src/Mu/Adapter/ProtoBuf.hs view
@@ -0,0 +1,427 @@+{-# language AllowAmbiguousTypes #-}+{-# language CPP #-}+{-# language ConstraintKinds #-}+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language GADTs #-}+{-# language MultiParamTypeClasses #-}+{-# language OverloadedStrings #-}+{-# language PolyKinds #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+{-# language TypeOperators #-}+{-# language UndecidableInstances #-}+{-# language ViewPatterns #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-|+Description : Adapter for Protocol Buffers serialization++Just import the module and you can turn any+value with a 'ToSchema' and 'FromSchema' from+and to Protocol Buffers. Since Protocol Buffers+need information about field identifiers, you+need to annotate your schema using 'ProtoBufAnnotation'.+-}+module Mu.Adapter.ProtoBuf (+ -- * Custom annotations+ ProtoBufAnnotation(..)+ -- * Conversion using schemas+, IsProtoSchema+, toProtoViaSchema+, fromProtoViaSchema+, parseProtoViaSchema+ -- * Conversion using registry+, FromProtoBufRegistry+, fromProtoBufWithRegistry+, parseProtoBufWithRegistry+) where++import Control.Applicative+import qualified Data.ByteString as BS+import Data.Functor.MaybeLike+import Data.Int+import Data.SOP (All)+import qualified Data.Text as T+import qualified Data.Text.Lazy as LT+import GHC.TypeLits+import Proto3.Wire+import qualified Proto3.Wire.Decode as PBDec+import qualified Proto3.Wire.Encode as PBEnc++import Mu.Schema.Annotations+import Mu.Schema.Class+import Mu.Schema.Definition+import Mu.Schema.Interpretation+import qualified Mu.Schema.Registry as R++#if MIN_VERSION_proto3_wire(1,1,0)+instance ProtoEnum Bool+#endif++-- | Annotations for Protocol Buffers fields.+data ProtoBufAnnotation+ = -- | Numeric field identifier for normal fields+ ProtoBufId Nat+ -- | List of identifiers for fields which contain a union+ | ProtoBufOneOfIds [Nat]++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) = n+ FindProtoBufId' t f other+ = TypeError ('Text "protocol buffers id not available for field "+ ':<>: 'ShowType t ':<>: 'Text "/" ':<>: 'ShowType f)++type family FindProtoBufOneOfIds (sch :: Schema tn fn) (t :: tn) (f :: fn) where+ FindProtoBufOneOfIds sch t f+ = FindProtoBufOneOfIds' t f (GetFieldAnnotation (AnnotatedSchema ProtoBufAnnotation sch) t f)++type family FindProtoBufOneOfIds' (t :: tn) (f :: fn) (p :: ProtoBufAnnotation) :: [Nat] where+ FindProtoBufOneOfIds' t f ('ProtoBufOneOfIds ns) = ns+ FindProtoBufOneOfIds' t f other+ = TypeError ('Text "protocol buffers id not available for oneof field "+ ':<>: 'ShowType t ':<>: 'Text "/" ':<>: 'ShowType f)++-- CONVERSION USING SCHEMAS++-- | Represents those 'Schema's which are supported by Protocol Buffers.+-- Some values which can be represented as 'Term's cannot be so in+-- Protocol Buffers. For example, you cannot have a list within an option.+class ProtoBridgeTerm w sch (sch :/: sty) => IsProtoSchema w sch sty+instance ProtoBridgeTerm w sch (sch :/: sty) => IsProtoSchema w sch sty++-- type HasProtoSchema w sch sty a = (HasSchema w sch sty a, IsProtoSchema w sch sty)++-- | Conversion to Protocol Buffers mediated by a schema.+toProtoViaSchema :: forall t f (sch :: Schema t f) a sty.+ (IsProtoSchema Maybe sch sty, ToSchema Maybe sch sty a)+ => a -> PBEnc.MessageBuilder+toProtoViaSchema = termToProto . toSchema' @_ @_ @sch @Maybe++-- | Conversion from Protocol Buffers mediated by a schema.+-- This function requires a 'PBDec.RawMessage', which means+-- that we already know that the Protocol Buffers message+-- is well-formed. Use 'parseProtoViaSchema' to parse directly+-- from a 'BS.ByteString'.+fromProtoViaSchema :: forall t f (sch :: Schema t f) a sty.+ (IsProtoSchema Maybe sch sty, FromSchema Maybe sch sty a)+ => PBDec.Parser PBDec.RawMessage a+fromProtoViaSchema = fromSchema' @_ @_ @sch @Maybe <$> protoToTerm++-- | Conversion from Protocol Buffers mediated by a schema.+-- This function receives the 'BS.ByteString' directly,+-- and parses it as part of its duty.+parseProtoViaSchema :: forall sch a sty.+ (IsProtoSchema Maybe sch sty, FromSchema Maybe sch sty a)+ => BS.ByteString -> Either PBDec.ParseError a+parseProtoViaSchema = PBDec.parse (fromProtoViaSchema @_ @_ @sch)++-- CONVERSION USING REGISTRY++-- | Conversion from Protocol Buffers by checking+-- all the 'Schema's in a 'R.Registry'.+--+-- As 'fromProtoViaSchema', this version requires+-- an already well-formed Protocol Buffers message.+fromProtoBufWithRegistry+ :: forall (r :: R.Registry) t.+ FromProtoBufRegistry r t+ => PBDec.Parser PBDec.RawMessage t+fromProtoBufWithRegistry = fromProtoBufRegistry' (Proxy @r)++-- | Conversion from Protocol Buffers by checking+-- all the 'Schema's in a 'R.Registry'.+--+-- As 'parseProtoViaSchema', this version receives+-- a 'BS.ByteString' and parses it as part of its duty.+parseProtoBufWithRegistry+ :: forall (r :: R.Registry) t.+ FromProtoBufRegistry r t+ => BS.ByteString -> Either PBDec.ParseError t+parseProtoBufWithRegistry = PBDec.parse (fromProtoBufWithRegistry @r)++-- | Represents 'R.Registry's for which every 'Schema'+-- is supported by the Protocol Buffers format.+class FromProtoBufRegistry (ms :: Mappings Nat Schema') t where+ fromProtoBufRegistry' :: Proxy ms -> PBDec.Parser PBDec.RawMessage t++instance FromProtoBufRegistry '[] t where+ fromProtoBufRegistry' _ = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "no schema found in registry"))+instance (IsProtoSchema Maybe s sty, FromSchema Maybe s sty t, FromProtoBufRegistry ms t)+ => FromProtoBufRegistry ( (n ':-> s) ': ms) t where+ fromProtoBufRegistry' _ = fromProtoViaSchema @_ @_ @s <|> fromProtoBufRegistry' (Proxy @ms)+++-- =======================================+-- IMPLEMENTATION OF GENERIC SERIALIZATION+-- =======================================++instance Alternative (PBDec.Parser i) where+ empty = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "cannot parse"))+ PBDec.Parser x <|> PBDec.Parser y+ = PBDec.Parser $ \i -> case x i of+ Left _ -> y i+ r@(Right _) -> r++-- Top-level terms+class ProtoBridgeTerm (w :: * -> *) (sch :: Schema tn fn) (t :: TypeDef tn fn) where+ termToProto :: Term w sch t -> PBEnc.MessageBuilder+ protoToTerm :: PBDec.Parser PBDec.RawMessage (Term w sch t)++-- Embedded terms+class ProtoBridgeEmbedTerm (w :: * -> *) (sch :: Schema tn fn) (t :: TypeDef tn fn) where+ termToEmbedProto :: FieldNumber -> Term w sch t -> PBEnc.MessageBuilder+ embedProtoToFieldValue :: PBDec.Parser PBDec.RawField (Term w sch t)+ embedProtoToOneFieldValue :: PBDec.Parser PBDec.RawPrimitive (Term w sch t)++class ProtoBridgeField (w :: * -> *) (sch :: Schema tn fn) (ty :: tn) (f :: FieldDef tn fn) where+ fieldToProto :: Field w sch f -> PBEnc.MessageBuilder+ protoToField :: PBDec.Parser PBDec.RawMessage (Field w sch f)++class ProtoBridgeFieldValue (w :: * -> *) (sch :: Schema tn fn) (t :: FieldType tn) where+ fieldValueToProto :: FieldNumber -> FieldValue w sch t -> PBEnc.MessageBuilder+ protoToFieldValue :: PBDec.Parser PBDec.RawField (FieldValue w sch t)++class ProtoBridgeOneFieldValue (w :: * -> *) (sch :: Schema tn fn) (t :: FieldType tn) where+ protoToOneFieldValue :: PBDec.Parser PBDec.RawPrimitive (FieldValue w sch t)++class ProtoBridgeUnionFieldValue (w :: * -> *) (ids :: [Nat]) (sch :: Schema tn fn) (ts :: [FieldType tn]) where+ unionFieldValueToProto :: NS (FieldValue w sch) ts -> PBEnc.MessageBuilder+ protoToUnionFieldValue :: PBDec.Parser PBDec.RawMessage (NS (FieldValue w sch) ts)++-- --------+-- TERMS --+-- --------++-- RECORDS+-- -------++instance (All (ProtoBridgeField w sch name) args, ProtoBridgeFields w sch name args)+ => ProtoBridgeTerm w sch ('DRecord name args) where+ termToProto (TRecord fields) = go fields+ where go :: forall fs. All (ProtoBridgeField w sch name) fs+ => NP (Field w sch) fs -> PBEnc.MessageBuilder+ go Nil = mempty+ go (f :* fs) = fieldToProto @_ @_ @w @sch @name f <> go fs+ protoToTerm = TRecord <$> protoToFields @_ @_ @w @sch @name++class ProtoBridgeFields (w :: * -> *) (sch :: Schema tn fn) (ty :: tn) (fields :: [FieldDef tn fn]) where+ protoToFields :: PBDec.Parser PBDec.RawMessage (NP (Field w sch) fields)+instance ProtoBridgeFields w sch ty '[] where+ protoToFields = pure Nil+instance (ProtoBridgeField w sch ty f, ProtoBridgeFields w sch ty fs)+ => ProtoBridgeFields w sch ty (f ': fs) where+ protoToFields = (:*) <$> protoToField @_ @_ @w @sch @ty <*> protoToFields @_ @_ @w @sch @ty++instance ProtoBridgeTerm w sch ('DRecord name args)+ => ProtoBridgeEmbedTerm w sch ('DRecord name args) where+ termToEmbedProto fid v = PBEnc.embedded fid (termToProto v)+ embedProtoToFieldValue = do+ t <- PBDec.embedded (protoToTerm @_ @_ @w @sch @('DRecord name args))+ case t of+ Nothing -> PBDec.Parser (\_ -> Left (PBDec.WireTypeError "expected message"))+ Just v -> return v+ embedProtoToOneFieldValue = PBDec.embedded' (protoToTerm @_ @_ @w @sch @('DRecord name args))++-- ENUMERATIONS+-- ------------++instance TypeError ('Text "protobuf requires wrapping enums in a message")+ => ProtoBridgeTerm w sch ('DEnum name choices) where+ termToProto = error "protobuf requires wrapping enums in a message"+ protoToTerm = error "protobuf requires wrapping enums in a message"++instance ProtoBridgeEnum sch name choices+ => ProtoBridgeEmbedTerm w sch ('DEnum name choices) where+ termToEmbedProto fid (TEnum v) = enumToProto @_ @_ @sch @name fid v+ embedProtoToFieldValue = do n <- PBDec.one PBDec.int32 0+ TEnum <$> protoToEnum @_ @_ @sch @name n+ embedProtoToOneFieldValue = do n <- PBDec.int32+ TEnum <$> protoToEnum @_ @_ @sch @name n++class ProtoBridgeEnum (sch :: Schema tn fn) (ty :: tn) (choices :: [ChoiceDef fn]) where+ enumToProto :: FieldNumber -> NS Proxy choices -> PBEnc.MessageBuilder+ protoToEnum :: Int32 -> PBDec.Parser a (NS Proxy choices)+instance ProtoBridgeEnum sch ty '[] where+ enumToProto = error "empty enum"+ protoToEnum _ = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "unknown enum type"))+instance (KnownNat (FindProtoBufId sch ty c), ProtoBridgeEnum sch ty cs)+ => ProtoBridgeEnum sch ty ('ChoiceDef c ': cs) where+ enumToProto fid (Z _) = PBEnc.int32 fid enumValue+ 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)+ | otherwise = S <$> protoToEnum @_ @_ @sch @ty n+ where enumValue = fromIntegral (natVal (Proxy @(FindProtoBufId sch ty c)))++-- SIMPLE+-- ------++instance TypeError ('Text "protobuf requires wrapping primitives in a message")+ => ProtoBridgeTerm w sch ('DSimple t) where+ termToProto = error "protobuf requires wrapping primitives in a message"+ protoToTerm = error "protobuf requires wrapping primitives in a message"++-- ---------+-- FIELDS --+-- ---------++instance {-# OVERLAPPABLE #-}+ (MaybeLike w, Alternative w, ProtoBridgeFieldValue w sch t, KnownNat (FindProtoBufId sch ty name))+ => ProtoBridgeField w sch ty ('FieldDef name t) where+ fieldToProto (Field (likeMaybe -> Just v)) = fieldValueToProto fieldId v+ where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name))+ fieldToProto (Field _) = mempty+ protoToField = Field <$> ((pure <$> protoToFieldValue `at` fieldId) <|> pure empty)+ where fieldId = fromInteger $ natVal (Proxy @(FindProtoBufId sch ty name))++instance {-# OVERLAPS #-}+ (MaybeLike w, Alternative w, ProtoBridgeUnionFieldValue w (FindProtoBufOneOfIds sch ty name) sch ts)+ => ProtoBridgeField w sch ty ('FieldDef name ('TUnion ts)) where+ fieldToProto (Field (likeMaybe -> Just (FUnion v)))+ = unionFieldValueToProto @_ @_ @w @(FindProtoBufOneOfIds sch ty name) v+ fieldToProto (Field _) = mempty+ protoToField+ = Field . pure . FUnion <$> protoToUnionFieldValue @_ @_ @w @(FindProtoBufOneOfIds sch ty name)+ <|> pure (Field empty)++-- ------------------+-- TYPES OF FIELDS --+-- ------------------++-- SCHEMATIC+-- ---------++instance ProtoBridgeEmbedTerm w sch (sch :/: t)+ => ProtoBridgeFieldValue w sch ('TSchematic t) where+ fieldValueToProto fid (FSchematic v) = termToEmbedProto fid v+ protoToFieldValue = FSchematic <$> embedProtoToFieldValue+instance ProtoBridgeEmbedTerm w sch (sch :/: t)+ => ProtoBridgeOneFieldValue w sch ('TSchematic t) where+ protoToOneFieldValue = FSchematic <$> embedProtoToOneFieldValue++-- PRIMITIVE TYPES+-- ---------------++instance TypeError ('Text "null cannot be converted to protobuf")+ => ProtoBridgeFieldValue w sch 'TNull where+ fieldValueToProto = error "null cannot be converted to protobuf"+ protoToFieldValue = error "null cannot be converted to protobuf"+instance TypeError ('Text "null cannot be converted to protobuf")+ => ProtoBridgeOneFieldValue w sch 'TNull where+ protoToOneFieldValue = error "null cannot be converted to protobuf"++instance ProtoBridgeFieldValue w sch ('TPrimitive Int) where+ fieldValueToProto fid (FPrimitive n) = PBEnc.int32 fid (fromIntegral n)+ protoToFieldValue = FPrimitive . fromIntegral <$> PBDec.one PBDec.int32 0+instance ProtoBridgeOneFieldValue w sch ('TPrimitive Int) where+ protoToOneFieldValue = FPrimitive . fromIntegral <$> PBDec.int32++instance ProtoBridgeFieldValue w sch ('TPrimitive Int32) where+ fieldValueToProto fid (FPrimitive n) = PBEnc.int32 fid n+ protoToFieldValue = FPrimitive <$> PBDec.one PBDec.int32 0+instance ProtoBridgeOneFieldValue w sch ('TPrimitive Int32) where+ protoToOneFieldValue = FPrimitive <$> PBDec.int32++instance ProtoBridgeFieldValue w sch ('TPrimitive Int64) where+ fieldValueToProto fid (FPrimitive n) = PBEnc.int64 fid n+ protoToFieldValue = FPrimitive <$> PBDec.one PBDec.int64 0+instance ProtoBridgeOneFieldValue w sch ('TPrimitive Int64) where+ protoToOneFieldValue = FPrimitive <$> PBDec.int64++-- WARNING! These instances may go out of bounds+instance ProtoBridgeFieldValue w sch ('TPrimitive Integer) where+ fieldValueToProto fid (FPrimitive n) = PBEnc.int64 fid (fromInteger n)+ protoToFieldValue = FPrimitive . fromIntegral <$> PBDec.one PBDec.int64 0+instance ProtoBridgeOneFieldValue w sch ('TPrimitive Integer) where+ protoToOneFieldValue = FPrimitive . fromIntegral <$> PBDec.int64++instance ProtoBridgeFieldValue w sch ('TPrimitive Float) where+ fieldValueToProto fid (FPrimitive n) = PBEnc.float fid n+ protoToFieldValue = FPrimitive <$> PBDec.one PBDec.float 0+instance ProtoBridgeOneFieldValue w sch ('TPrimitive Float) where+ protoToOneFieldValue = FPrimitive <$> PBDec.float++instance ProtoBridgeFieldValue w sch ('TPrimitive Double) where+ fieldValueToProto fid (FPrimitive n) = PBEnc.double fid n+ protoToFieldValue = FPrimitive <$> PBDec.one PBDec.double 0+instance ProtoBridgeOneFieldValue w sch ('TPrimitive Double) where+ protoToOneFieldValue = FPrimitive <$> PBDec.double++instance ProtoBridgeFieldValue w sch ('TPrimitive Bool) where+ fieldValueToProto fid (FPrimitive n) = PBEnc.enum fid n+ protoToFieldValue = FPrimitive <$> PBDec.one PBDec.bool False+instance ProtoBridgeOneFieldValue w sch ('TPrimitive Bool) where+ protoToOneFieldValue = FPrimitive <$> PBDec.bool++instance ProtoBridgeFieldValue w sch ('TPrimitive T.Text) where+ fieldValueToProto fid (FPrimitive n) = PBEnc.text fid (LT.fromStrict n)+ protoToFieldValue = FPrimitive . LT.toStrict <$> PBDec.one PBDec.text ""+instance ProtoBridgeOneFieldValue w sch ('TPrimitive T.Text) where+ protoToOneFieldValue = FPrimitive . LT.toStrict <$> PBDec.text++instance ProtoBridgeFieldValue w sch ('TPrimitive LT.Text) where+ fieldValueToProto fid (FPrimitive n) = PBEnc.text fid n+ protoToFieldValue = FPrimitive <$> PBDec.one PBDec.text ""+instance ProtoBridgeOneFieldValue w sch ('TPrimitive LT.Text) where+ protoToOneFieldValue = FPrimitive <$> PBDec.text++instance ProtoBridgeFieldValue w sch ('TPrimitive BS.ByteString) where+ fieldValueToProto fid (FPrimitive n) = PBEnc.byteString fid n+ protoToFieldValue = FPrimitive <$> PBDec.one PBDec.byteString ""+instance ProtoBridgeOneFieldValue w sch ('TPrimitive BS.ByteString) where+ protoToOneFieldValue = FPrimitive <$> PBDec.byteString++-- Note that Maybes and Lists require that we recur on the OneFieldValue class++instance (ProtoBridgeFieldValue w sch t, ProtoBridgeOneFieldValue w sch t)+ => ProtoBridgeFieldValue w sch ('TOption t) where+ fieldValueToProto _ (FOption Nothing) = mempty+ fieldValueToProto fid (FOption (Just v)) = fieldValueToProto fid v+ protoToFieldValue = FOption <$> PBDec.one (Just <$> protoToOneFieldValue) Nothing++instance TypeError ('Text "optionals cannot be nested in protobuf")+ => ProtoBridgeOneFieldValue w sch ('TOption t) where+ protoToOneFieldValue = error "optionals cannot be nested in protobuf"++instance (ProtoBridgeFieldValue w sch t, ProtoBridgeOneFieldValue w sch t)+ => ProtoBridgeFieldValue w sch ('TList t) where+ fieldValueToProto fid (FList xs) = foldMap (fieldValueToProto fid) xs+ protoToFieldValue = FList <$> PBDec.repeated protoToOneFieldValue++instance TypeError ('Text "lists cannot be nested in protobuf")+ => ProtoBridgeOneFieldValue w sch ('TList t) where+ protoToOneFieldValue = error "lists cannot be nested in protobuf"++instance TypeError ('Text "maps are not currently supported")+ => ProtoBridgeFieldValue w sch ('TMap k v) where+ fieldValueToProto = error "maps are not currently supported"+ protoToFieldValue = error "maps are not currently supported"++instance TypeError ('Text "nested unions are not currently supported")+ => ProtoBridgeFieldValue w sch ('TUnion choices) where+ fieldValueToProto = error "nested unions are not currently supported"+ protoToFieldValue = error "nested unions are not currently supported"++-- UNIONS+-- ------++instance ProtoBridgeUnionFieldValue w ids sch '[] where+ unionFieldValueToProto = error "empty list of unions"+ protoToUnionFieldValue = PBDec.Parser (\_ -> Left (PBDec.WireTypeError "unknown type in an union"))++instance ( ProtoBridgeFieldValue w sch t, KnownNat thisId+ , ProtoBridgeUnionFieldValue w restIds sch ts )+ => ProtoBridgeUnionFieldValue w (thisId ': restIds) sch (t ': ts) where+ unionFieldValueToProto (Z v) = fieldValueToProto fieldId v+ where fieldId = fromInteger $ natVal (Proxy @thisId)+ unionFieldValueToProto (S v) = unionFieldValueToProto @_ @_ @w @restIds v+ protoToUnionFieldValue+ = Z <$> protoToFieldValue `at` fieldId <|> S <$> protoToUnionFieldValue @_ @_ @w @restIds+ where fieldId = fromInteger $ natVal (Proxy @thisId)
+ src/Mu/Adapter/ProtoBuf/Via.hs view
@@ -0,0 +1,74 @@+{-# language DataKinds #-}+{-# language FlexibleContexts #-}+{-# language FlexibleInstances #-}+{-# language MultiParamTypeClasses #-}+{-# language PolyKinds #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}+{-# language UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-simplifiable-class-constraints -fno-warn-orphans #-}+{-|+Description : Wrappers to customize Protocol Buffers serialization++In order to interoperate with the @proto3-wire@ library,+we sometimes need an instance of 'Proto3WireEncoder'.+By using the wrappers in this module, such instances can+be obtained automatically if the type can be turned+into a 'Schema'.+-}+module Mu.Adapter.ProtoBuf.Via where++import Network.GRPC.HTTP2.Proto3Wire+import qualified Proto3.Wire.Decode as PBDec+import qualified Proto3.Wire.Encode as PBEnc++import Mu.Adapter.ProtoBuf+import Mu.Rpc+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+ = 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+ = ViaFromProtoBufTypeRef { unViaFromProtoBufTypeRef :: t }++instance ToProtoBufTypeRef ref t+ => Proto3WireEncoder (ViaToProtoBufTypeRef ref t) where+ proto3WireEncode = toProtoBufTypeRef (Proxy @ref) . unViaToProtoBufTypeRef+ proto3WireDecode = error "this should never be called, use FromProtoBufTypeRef"+instance FromProtoBufTypeRef ref t+ => Proto3WireEncoder (ViaFromProtoBufTypeRef ref t) where+ proto3WireEncode = error "this should never be called, use ToProtoBufTypeRef"+ proto3WireDecode = ViaFromProtoBufTypeRef <$> fromProtoBufTypeRef (Proxy @ref)++instance Proto3WireEncoder () where+ proto3WireEncode _ = mempty+ proto3WireDecode = return ()++-- | Types which can be parsed from a Protocol Buffers message.+class FromProtoBufTypeRef (ref :: TypeRef) 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+ toProtoBufTypeRef :: Proxy ref -> t -> PBEnc.MessageBuilder++instance (IsProtoSchema Maybe sch sty, FromSchema Maybe sch sty t)+ => FromProtoBufTypeRef ('ViaSchema sch sty) t where+ fromProtoBufTypeRef _ = fromProtoViaSchema @_ @_ @sch+instance (IsProtoSchema Maybe sch sty, ToSchema Maybe sch sty t)+ => ToProtoBufTypeRef ('ViaSchema 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 _ = 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 _ = toProtoViaSchema @_ @_ @(MappingRight r last)
+ src/Mu/Quasi/GRpc.hs view
@@ -0,0 +1,109 @@+{-# language DataKinds #-}+{-# language OverloadedStrings #-}+{-# language TemplateHaskell #-}+{-|+Description : Quasi-quoters for gRPC files++Read @.proto@ files as a 'Mu.Schema.Definition.Schema'+and a set of 'Service's. The origin of those @.proto@+files can be local (if using 'grpc') or come+from a Compendium Registry (if using 'compendium').+-}+module Mu.Quasi.GRpc (+ grpc+, compendium+) where++import Control.Monad.IO.Class+import qualified Data.Text as T+import Language.Haskell.TH+import Language.ProtocolBuffers.Parser+import qualified Language.ProtocolBuffers.Types as P+import Network.HTTP.Client+import Servant.Client.Core.BaseUrl++import Compendium.Client+import Mu.Quasi.ProtoBuf+import Mu.Rpc++-- | Reads a @.proto@ file and generates:+-- * A 'Mu.Schema.Definition.Schema' with all the message+-- types, using the name given as first argument.+-- * A 'Service' declaration for each service in the file,+-- where the name is obtained by applying the function+-- given as second argument to the name in the file.+grpc :: String -> (String -> String) -> FilePath -> Q [Dec]+grpc schemaName servicePrefix fp+ = do r <- liftIO $ parseProtoBufFile fp+ case r of+ Left e+ -> fail ("could not parse protocol buffers spec: " ++ show e)+ Right p+ -> grpcToDecls schemaName servicePrefix p++-- | Obtains a schema and service definition from Compendium,+-- and generates the declarations from 'grpc'.+compendium :: String -> (String -> String)+ -> String -> String -> Q [Dec]+compendium schemaTypeName servicePrefix baseUrl identifier+ = do m <- liftIO $ newManager defaultManagerSettings+ u <- liftIO $ parseBaseUrl baseUrl+ r <- liftIO $ obtainProtoBuf m u (T.pack identifier)+ case r of+ Left e+ -> fail ("could not parse protocol buffers spec: " ++ show e)+ Right p+ -> grpcToDecls schemaTypeName servicePrefix p++grpcToDecls :: String -> (String -> String) -> P.ProtoBuf -> Q [Dec]+grpcToDecls schemaName servicePrefix p@P.ProtoBuf { P.package = pkg, P.services = srvs }+ = do let schemaName' = mkName schemaName+ schemaDec <- protobufToDecls schemaName p+ serviceTy <- mapM (pbServiceDeclToDec servicePrefix pkg schemaName') srvs+ return (schemaDec ++ serviceTy)++pbServiceDeclToDec :: (String -> String) -> Maybe [T.Text] -> Name -> P.ServiceDeclaration -> Q Dec+pbServiceDeclToDec servicePrefix pkg schema srv@(P.Service nm _ _)+ = tySynD (mkName $ servicePrefix $ T.unpack nm) []+ (pbServiceDeclToType pkg schema srv)++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) |]+ where+ pkgType Nothing = [t| '[] |]+ pkgType (Just p) = [t| '[ Package $(textToStrLit (T.intercalate "." p)) ] |]++pbMethodToType :: Name -> P.Method -> Q Type+pbMethodToType s (P.Method nm vr v rr r _)+ = [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 ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) ] |]+ argToType P.Stream (P.TOther a)+ = [t| '[ 'ArgStream ('ViaSchema $(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))) |]+ retToType P.Stream (P.TOther a)+ = [t| 'RetStream ('ViaSchema $(schemaTy s) $(textToStrLit (last a))) |]+ retToType _ _+ = fail "only message types may be used as results"++schemaTy :: Name -> Q Type+schemaTy schema = return $ 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
+ src/Mu/Quasi/ProtoBuf.hs view
@@ -0,0 +1,144 @@+{-# language CPP #-}+{-# language DataKinds #-}+{-# language LambdaCase #-}+{-# language NamedFieldPuns #-}+{-# language TemplateHaskell #-}+{-|+Description : Quasi-quoters for Protocol Buffers schemas++Read @.proto@ files as a 'Mu.Schema.Definition.Schema'.+If you want to get the service definitions too,+you should use 'Mu.Quasi.GRpc' instead.+-}+module Mu.Quasi.ProtoBuf (+ -- * Quasi-quoters for @.proto@ files+ protobuf+ -- * Only for internal use+ , protobufToDecls+ ) where++import Control.Monad.IO.Class+import qualified Data.ByteString as B+import Data.Int+import qualified Data.Text as T+import Language.Haskell.TH+import Language.ProtocolBuffers.Parser+import qualified Language.ProtocolBuffers.Types as P++import Mu.Adapter.ProtoBuf+import Mu.Schema.Definition+import Mu.Schema.Annotations++-- | Reads a @.proto@ file and generates a 'Mu.Schema.Definition.Schema'+-- with all the message types, using the name given+-- as first argument.+protobuf :: String -> FilePath -> Q [Dec]+protobuf schemaName fp+ = do r <- liftIO $ parseProtoBufFile fp+ case r of+ Left e+ -> fail ("could not parse protocol buffers spec: " ++ show e)+ Right p+ -> protobufToDecls schemaName p++-- | Shared portion of Protocol Buffers and gRPC quasi-quoters.+protobufToDecls :: String -> P.ProtoBuf -> Q [Dec]+protobufToDecls schemaName p+ = do let schemaName' = mkName schemaName+ (schTy, annTy) <- schemaFromProtoBuf p+ schemaDec <- tySynD schemaName' [] (return schTy)+#if MIN_VERSION_template_haskell(2,15,0)+ annDec <- tySynInstD (tySynEqn Nothing+ [t| AnnotatedSchema ProtoBufAnnotation $(conT schemaName') |]+ (return annTy))+#else+ annDec <- tySynInstD ''AnnotatedSchema+ (tySynEqn [ [t| ProtoBufAnnotation |], conT schemaName' ] (return annTy))+#endif+ return [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))++flattenDecls :: [P.TypeDeclaration] -> [P.TypeDeclaration]+flattenDecls = concatMap flattenDecl+ where+ flattenDecl d@P.DEnum {} = [d]+ flattenDecl (P.DMessage name o r fs decls) =+ P.DMessage name o r fs [] : flattenDecls decls++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+ where+ pbChoiceToType :: P.EnumField -> Q (Type, Type)+ pbChoiceToType (P.EnumField nm number _)+ = (,) <$> [t|'ChoiceDef $(textToStrLit nm) |]+ <*> [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+ where+ pbMsgFieldToType :: P.MessageField -> Q (Type, Type)+ pbMsgFieldToType (P.NormalField P.Single ty nm n _)+ = (,) <$> [t| 'FieldDef $(textToStrLit nm) $(pbFieldTypeToType ty) |]+ <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n)) |]+ pbMsgFieldToType (P.NormalField P.Repeated ty nm n _)+ = (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TList $(pbFieldTypeToType ty)) |]+ <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n)) |]+ pbMsgFieldToType (P.MapField k v nm n _)+ = (,) <$> [t| 'FieldDef $(textToStrLit nm) ('TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v)) |]+ <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm) ('ProtoBufId $(intToLit n)) |]+ pbMsgFieldToType (P.OneOfField nm vs)+ | any (not . hasFieldNumber) vs+ = fail "nested oneof fields are not supported"+ | otherwise+ = (,) <$> [t| 'FieldDef $(textToStrLit nm) $(typesToList <$> mapM pbOneOfFieldToType vs ) |]+ <*> [t| 'AnnField $(textToStrLit name) $(textToStrLit nm)+ ('ProtoBufOneOfIds $(typesToList <$> mapM (intToLit . getFieldNumber) vs )) |]++ pbFieldTypeToType :: P.FieldType -> Q Type+ pbFieldTypeToType P.TInt32 = [t|'TPrimitive Int32|]+ pbFieldTypeToType P.TUInt32 = fail "unsigned integers are not currently supported"+ pbFieldTypeToType P.TSInt32 = [t|'TPrimitive Int32|]+ pbFieldTypeToType P.TInt64 = [t|'TPrimitive Int64|]+ pbFieldTypeToType P.TUInt64 = fail "unsigned integers are not currently supported"+ pbFieldTypeToType P.TSInt64 = [t|'TPrimitive Int64|]+ pbFieldTypeToType P.TFixed32 = fail "fixed integers are not currently supported"+ pbFieldTypeToType P.TFixed64 = fail "fixed integers are not currently supported"+ pbFieldTypeToType P.TSFixed32 = fail "fixed integers are not currently supported"+ pbFieldTypeToType P.TSFixed64 = fail "fixed integers are not currently supported"+ pbFieldTypeToType P.TDouble = [t|'TPrimitive Double|]+ 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))|]++ hasFieldNumber P.NormalField {} = True+ hasFieldNumber P.MapField {} = True+ hasFieldNumber _ = False++ getFieldNumber (P.NormalField _ _ _ n _) = n+ getFieldNumber (P.MapField _ _ _ n _) = n+ getFieldNumber _ = error "this should never happen"++ pbOneOfFieldToType (P.NormalField P.Single ty _ _ _)+ = pbFieldTypeToType ty+ pbOneOfFieldToType (P.NormalField P.Repeated ty _ _ _)+ = [t| 'TList $(pbFieldTypeToType ty) |]+ pbOneOfFieldToType (P.MapField k v _ _ _)+ = [t| 'TMap $(pbFieldTypeToType k) $(pbFieldTypeToType v) |]+ pbOneOfFieldToType _ = error "this should never happen"++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++intToLit :: Int -> Q Type+intToLit n = return $ LitT $ NumTyLit $ toInteger n
+ src/Mu/Quasi/ProtoBuf/Example.hs view
@@ -0,0 +1,20 @@+{-# language CPP #-}+{-# language DataKinds #-}+{-# language TemplateHaskell #-}+{-# language TypeFamilies #-}+{-|+Description : Examples for Protocol Buffers quasi-quoters++Look at the source code of this module.+-}+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"+#else+protobuf "ExampleProtoBufSchema" "test/protobuf/example.proto"+protobuf "Example2ProtoBufSchema" "test/protobuf/example2.proto"+#endif
+ test/ProtoBuf.hs view
@@ -0,0 +1,75 @@+{-# language DataKinds #-}+{-# language DeriveAnyClass #-}+{-# language DeriveGeneric #-}+{-# language DerivingStrategies #-}+{-# language OverloadedStrings #-}+{-# language ScopedTypeVariables #-}+{-# language TypeApplications #-}+{-# language TypeFamilies #-}+module Main where++import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as LBS+import qualified Data.Text as T+import GHC.Generics+import qualified Proto3.Wire.Decode as PBDec+import qualified Proto3.Wire.Encode as PBEnc+import System.Environment++import Mu.Adapter.ProtoBuf+import Mu.Schema+import Mu.Schema.Examples++data MPerson+ = MPerson { firstName :: Maybe T.Text+ , lastName :: Maybe T.Text+ , age :: Maybe (Maybe Int)+ , gender :: Maybe (Maybe Gender)+ , address :: Maybe MAddress }+ deriving (Eq, Show, Generic)+ deriving (ToSchema Maybe ExampleSchema "person")+ deriving (FromSchema Maybe ExampleSchema "person")++data MAddress+ = MAddress { postcode :: Maybe T.Text+ , country :: Maybe T.Text }+ deriving (Eq, Show, Generic)+ deriving (ToSchema Maybe ExampleSchema "address")+ deriving (FromSchema Maybe ExampleSchema "address")++type instance AnnotatedSchema ProtoBufAnnotation ExampleSchema+ = '[ '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) ]++exampleAddress :: MAddress+exampleAddress = MAddress (Just "1111BB") (Just "Spain")++examplePerson1, examplePerson2 :: MPerson+examplePerson1 = MPerson (Just "Haskellio") (Just "Gómez")+ (Just $ Just 30) (Just $ Just Male)+ (Just exampleAddress)+examplePerson2 = MPerson (Just "Cuarenta") (Just "Siete")+ (Just Nothing) (Just Nothing)+ (Just exampleAddress)++main :: IO ()+main = do -- Obtain the filenames+ [genFile, conFile] <- getArgs+ -- Read the file produced by Python+ putStrLn "haskell/consume"+ cbs <- BS.readFile conFile+ let Right people = PBDec.parse (fromProtoViaSchema @_ @_ @ExampleSchema) cbs+ print (people :: MPerson)+ -- Encode a couple of values+ putStrLn "haskell/generate"+ print examplePerson1+ let gbs = PBEnc.toLazyByteString (toProtoViaSchema @_ @_ @ExampleSchema examplePerson1)+ LBS.writeFile genFile gbs
+ test/protobuf/example.proto view
@@ -0,0 +1,20 @@+syntax = "proto3";++message person {+ string firstName = 1;+ string lastName = 2;+ int32 age = 3;+ gender gender = 4;+ address address = 5;+}++message address {+ string postcode = 1;+ string country = 2;+}++enum gender {+ nb = 0;+ male = 1;+ female = 2;+}
+ test/protobuf/example2.proto view
@@ -0,0 +1,12 @@+syntax = "proto3";++enum gender {+ male = 1;+ female = 2;+ nonbinary = 3;+}+message person {+ repeated string names = 1;+ int32 age = 2;+ gender gender = 3;+}