signable-haskell-protoc 0.1 → 0.2
raw patch · 4 files changed
+157/−56 lines, 4 filesdep +containers
Dependencies added: containers
Files
- Changelog.md +10/−0
- README.md +2/−1
- signable-haskell-protoc.cabal +3/−2
- src/Main.hs +142/−53
Changelog.md view
@@ -1,3 +1,13 @@+# Version 0.2++- Field indexes of any unset field (message/repeated/oneof) are ignored in serialized payload to make possible rolling upgrades **BREAKING CHANGE**++- Fully qualified names are used in generated Signable class instances source code to prevent possible shadowing issues (bugfix)++- Signable class instances source code is generated in eta-reduced form to prevent possible shadowing issues (bugfix)++- Provided code for special cases where protobuf field is named as Haskell keyword like `data`, `class`, `instance` etc (bugfix)+ # Version 0.1 - Initial version.
README.md view
@@ -1,6 +1,7 @@ # signable-haskell-protoc -Signable instances protoc compiler plugin:+Deterministic serialisation and signatures with proto-lens support.+Generate Signable class instances with command: ``` protoc \
signable-haskell-protoc.cabal view
@@ -5,8 +5,8 @@ -- see: https://github.com/sol/hpack name: signable-haskell-protoc-version: 0.1-synopsis: Signable instances protoc compiler plugin.+version: 0.2+synopsis: Deterministic serialisation and signatures with proto-lens support description: You can find documentation at <https://hackage.haskell.org/package/signable-haskell-protoc hackage> category: Data, Cryptography homepage: https://github.com/coingaming/signable#readme@@ -40,6 +40,7 @@ base >=4.7 && <5 , bytestring ==0.10.* , casing >=0.1 && <0.2+ , containers >=0.5 && <0.7 , ghc >=8.2 && <8.11 , ghc-paths ==0.1.* , ghc-source-gen >=0.4 && <0.5
src/Main.hs view
@@ -13,6 +13,7 @@ import Data.ProtoLens (decodeMessage, defMessage, encodeMessage) import Data.ProtoLens.Compiler.ModuleName (protoModuleName) import Data.ProtoLens.Labels ()+import qualified Data.Set as Set import Data.String (fromString) import qualified Data.Text as T import Data.Text (Text, intercalate, pack, unpack)@@ -31,6 +32,7 @@ ( DescriptorProto, EnumDescriptorProto, FieldDescriptorProto,+ FieldDescriptorProto'Label (FieldDescriptorProto'LABEL_REPEATED), FieldDescriptorProto'Type (FieldDescriptorProto'TYPE_MESSAGE), FileDescriptorProto, )@@ -77,15 +79,18 @@ <$> req ^. #protoFile imports :: [ImportDecl'] imports =- [ import' "Universum",- import' "Data.Signable"- ]- <> ( protoMods- >>= ( \x ->- let n = modName x- in import' . fromString <$> [n, n <> "_Fields"]+ qualified'+ <$> ( [ import' "Universum",+ import' "Data.Signable",+ import' "GHC.List"+ ]+ <> ( protoMods+ >>= ( \x ->+ let n = modName x+ in import' . fromString <$> [n, n <> "_Fields"]+ ) )- )+ ) body :: Text body = pack . showPpr dflags $@@ -100,7 +105,8 @@ [ "{- This file was auto-generated by the " <> pack prog <> " program. -}",- "{-# OPTIONS_GHC -fno-warn-orphans #-}"+ "{-# OPTIONS_GHC -fno-warn-orphans #-}",+ "{-# LANGUAGE NoImplicitPrelude #-}" ] parseModName :: FileDescriptorProto -> String@@ -134,72 +140,155 @@ mkMsgImpl :: String -> String -> DescriptorProto -> HsDecl' mkMsgImpl m t d = instance'- (var "Signable" @@ var (fromString $ m <> "." <> t))+ (var "Data.Signable.Signable" @@ var (fromString $ m <> "." <> t)) [ funBind "toBinary" $ match- [bvar "x"]- ( var "mconcat"- @@ ( list- . (mkMsgChunk m <$>)- . sortBy (\x y -> compare (x ^. #number) (y ^. #number))- $ d ^. #field- )+ []+ ( op+ (var "Universum.mconcat")+ compose+ ( op+ ( var "Universum.<&>"+ @@ ( list+ . (mkMsgChunk m <$>)+ . sortBy+ ( \x y ->+ compare+ (x ^. #number)+ (y ^. #number)+ )+ $ d ^. #field+ )+ )+ compose+ (var "Universum.&")+ ) ) ] mkMsgChunk :: String -> FieldDescriptorProto -> HsExpr'-mkMsgChunk m d =- if (d ^. #type' == FieldDescriptorProto'TYPE_MESSAGE)- || (isJust $ d ^. #maybe'oneofIndex)- then mExpr- else expr+mkMsgChunk m d+ | d ^. #label == FieldDescriptorProto'LABEL_REPEATED =+ rExpr+ | (d ^. #type' == FieldDescriptorProto'TYPE_MESSAGE)+ || (isJust $ d ^. #maybe'oneofIndex) =+ mExpr+ | otherwise =+ expr where- n0 = camel . unpack $ d ^. #name+ n0 = unReserve . camel . unpack $ d ^. #name tag = case safeFromIntegral $ d ^. #number :: Maybe Int32 of Just v ->- var "toBinary"- @@ int (fromIntegral v :: Integer) @::@ var "Int32"+ var "Data.Signable.toBinary"+ @@ int (fromIntegral v :: Integer) @::@ var "Universum.Int32" Nothing -> error "TAG_OVERFLOW"- expr =+ rExpr = op- tag- "<>"- ( var- "toBinary"- @@ par- (var "view" @@ var (fromString $ m <> "_Fields." <> n0) @@ var "x")+ ( var "Data.Signable.ifThenElse"+ @@ (var "GHC.List.null")+ @@ (var "Universum.const" @@ var "Universum.mempty")+ @@ ( op+ (var "Universum.<>" @@ tag)+ compose+ (var "Data.Signable.toBinary")+ ) )+ compose+ (var "Universum.view" @@ var (fromString $ m <> "_Fields." <> n0)) mExpr =- case'- (var "view" @@ var (fromString $ m <> "_Fields.maybe'" <> n0) @@ var "x")- [ match- [conP "Just" [bvar "v"]]- (op tag "<>" (var "toBinary" @@ var "v")),- match- [conP_ "Nothing"]- tag- ]+ op+ ( var "Universum.maybe"+ @@ (var "Universum.mempty")+ @@ ( op+ (var "Universum.<>" @@ tag)+ compose+ (var "Data.Signable.toBinary")+ )+ )+ compose+ (var "Universum.view" @@ var (fromString $ m <> "_Fields.maybe'" <> n0))+ expr =+ op+ (var "Universum.<>" @@ tag)+ compose+ ( op+ (var "Data.Signable.toBinary")+ compose+ (var "Universum.view" @@ var (fromString $ m <> "_Fields." <> n0))+ ) mkEnumImpl :: String -> String -> HsDecl' mkEnumImpl m t = instance'- (var "Signable" @@ var (fromString $ m <> "." <> t))+ (var "Data.Signable.Signable" @@ var (fromString $ m <> "." <> t)) [ funBind "toBinary" $ match- [bvar "x"]- ( case'- ( (var "safeFromIntegral" @@ par (var "fromEnum" @@ var "x"))- @::@ par (var "Maybe" @@ var "Int32")+ []+ ( op+ ( (var "Universum.maybe")+ @@ (var "Universum.error" @@ string "ENUM_OVERFLOW")+ @@ (var "Data.Signable.toBinary") )- [ match- [conP "Just" [bvar "v"]]- (var "toBinary" @@ var "v"),- match- [conP_ "Nothing"]- (var "error" @@ string "ENUM_OVERFLOW")- ]+ compose+ ( op+ ( (var "Data.Signable.safeFromIntegral")+ @::@ ( var "Universum.Int"+ --> var "Universum.Maybe"+ @@ var "Universum.Int32"+ )+ )+ compose+ (var "Universum.fromEnum")+ ) ) ]++compose :: RdrNameStr+compose = "Universum.."++unReserve :: String -> String+unReserve x =+ if x `Set.member` reservedKeywords+ then x <> "'"+ else x++-- | A list of reserved keywords that aren't valid as variable names.+reservedKeywords :: Set.Set String+reservedKeywords =+ Set.fromList $+ -- Haskell2010 keywords:+ -- https://www.haskell.org/onlinereport/haskell2010/haskellch2.html#x7-180002.4+ -- We don't include keywords that are allowed to be variable names,+ -- in particular: "as", "forall", and "hiding".+ [ "case",+ "class",+ "data",+ "default",+ "deriving",+ "do",+ "else",+ "foreign",+ "if",+ "import",+ "in",+ "infix",+ "infixl",+ "infixr",+ "instance",+ "let",+ "module",+ "newtype",+ "of",+ "then",+ "type",+ "where"+ ]+ ++ [ "mdo", -- Nonstandard extensions+ -- RecursiveDo+ "rec", -- Arrows, RecursiveDo+ "pattern", -- PatternSynonyms+ "proc" -- Arrows+ ] safeFromIntegral :: forall a b. (Integral a, Integral b, Bounded b) => a -> Maybe b