proto3 standard compatibility improvements (#143)

* expose Proto3.Suite.DotProto.Internal

* cabal fix

* conditional compilation according Swagger version

* globalIdentifier support, circleci support

* DotProtoMessageOption

* data PartRank for easier ordering, refactored CanonicalRank implementation of DotProtoMessagePart, removed CircleCI support

* optional swagger2isAbove_2_4_0 flag for getting correct proto3-suite-linux generator binary matching local swagger2 version

* better swagger2 overrides

* WIP debug namespace

* qualifiedMessageTypeName function to fix deep nested message namespace codegen bug

* Ignore `result-*` files

Co-authored-by: Ilja Tkachuk <tkachuk.labs@gmail.com>
Co-authored-by: Evan Relf <evan@awakesecurity.com>

Author: 3 people

.gitignore

@@ -7,6 +7,7 @@ dist/
 dist-newstyle/
 .stack-work/
 result
+result-*
 *.pyc
 # This should be auto-generated by protoc
 test-files/test_proto_pb2.py

proto3-suite.cabal

@@ -119,6 +119,9 @@ test-suite tests
                        TestProtoImport
                        TestProtoOneof
                        TestProtoOneofImport
+                       --TestProtoLeadingDot
+                       TestProtoNestedMessage
+                       --TestProtoProtocPlugin
 
   hs-source-dirs:      tests gen
   default-language:    Haskell2010

src/Proto3/Suite/DotProto/AST.hs

@@ -342,6 +342,7 @@ data DotProtoMessagePart
   | DotProtoMessageOneOf DotProtoIdentifier [DotProtoField]
   | DotProtoMessageDefinition DotProtoDefinition
   | DotProtoMessageReserved   [DotProtoReservedField]
+  | DotProtoMessageOption DotProtoOption
   deriving (Show, Eq)
 
 instance Arbitrary DotProtoMessagePart where

src/Proto3/Suite/DotProto/Generate.hs

@@ -314,10 +314,10 @@ ctxtImports = fmap (map mkImport . nub)
 --   been provided with a valid module path in its 'dotProtoTypeInfoModulePath'
 --   field. The latter describes the name of the Haskell module being generated.
 msgTypeFromDpTypeInfo :: MonadError CompileError m
-                      => DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
-msgTypeFromDpTypeInfo DotProtoTypeInfo{..} ident = do
+                      => TypeContext -> DotProtoTypeInfo -> DotProtoIdentifier -> m HsType
+msgTypeFromDpTypeInfo ctxt DotProtoTypeInfo{..} ident = do
     modName   <- modulePathModName dotProtoTypeInfoModulePath
-    identName <- qualifiedMessageName dotProtoTypeInfoParent ident
+    identName <- qualifiedMessageTypeName ctxt dotProtoTypeInfoParent ident
     pure $ HsTyCon (Qual modName (HsIdent identName))
 
 haskellName, jsonpbName, grpcName, protobufName, protobufWrapperName, proxyName :: String -> HsQName
@@ -446,8 +446,8 @@ dptToHsTypeWrapped opts =
       Named msgName ->
         case M.lookup msgName ctxt of
           Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) ->
-              HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ty msgName
-          Just ty -> msgTypeFromDpTypeInfo ty msgName
+              HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ctxt ty msgName
+          Just ty -> msgTypeFromDpTypeInfo ctxt ty msgName
           Nothing -> noSuchTypeError msgName
 
 foldDPT :: MonadError CompileError m
@@ -541,8 +541,8 @@ dpptToHsType ctxt = \case
   Named msgName ->
     case M.lookup msgName ctxt of
       Just ty@(DotProtoTypeInfo { dotProtoTypeInfoKind = DotProtoKindEnum }) ->
-          HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ty msgName
-      Just ty -> msgTypeFromDpTypeInfo ty msgName
+          HsTyApp (protobufType_ "Enumerated") <$> msgTypeFromDpTypeInfo ctxt ty msgName
+      Just ty -> msgTypeFromDpTypeInfo ctxt ty msgName
       Nothing -> noSuchTypeError msgName
 
 validMapKey :: DotProtoPrimType -> Bool

src/Proto3/Suite/DotProto/Generate/Swagger.hs

@@ -83,7 +83,11 @@ instance {-# OVERLAPPING #-} (ToJSONKey k, ToSchema k) => ToSchema (OverrideToSc
           declareNamedSchema (Proxy :: Proxy [(k, (OverrideToSchema ByteString))])
     where
       schema_ = mempty
+#if MIN_VERSION_swagger2(2,4,0)
         & type_ ?~ SwaggerObject
+#else
+        & type_ .~ SwaggerObject
+#endif
         & additionalProperties ?~ AdditionalPropertiesSchema (Inline byteSchema)
 
 {-| This is a convenience function that uses type inference to select the

src/Proto3/Suite/DotProto/Internal.hs

@@ -437,6 +437,28 @@ nestedTypeName (Qualified {})        _  = internalError "nestedTypeName: Qualifi
 qualifiedMessageName :: MonadError CompileError m => DotProtoIdentifier -> DotProtoIdentifier -> m String
 qualifiedMessageName parentIdent msgIdent = nestedTypeName parentIdent =<< dpIdentUnqualName msgIdent
 
+qualifiedMessageTypeName :: MonadError CompileError m =>
+                            TypeContext ->
+                            DotProtoIdentifier ->
+                            DotProtoIdentifier ->
+                            m String
+qualifiedMessageTypeName ctxt parentIdent msgIdent = do
+  xs <- parents parentIdent []
+  case xs of
+    [] -> nestedTypeName parentIdent =<< dpIdentUnqualName msgIdent
+    x : xs' -> nestedTypeName (Dots . Path $ x NE.:| xs') =<< dpIdentUnqualName msgIdent
+  where
+    parents par@(Single x) xs =
+      case M.lookup par ctxt of
+        Just (DotProtoTypeInfo { dotProtoTypeInfoParent = parentIdent' }) ->
+          parents parentIdent' $ x : xs
+        Nothing ->
+          pure $ x : xs
+    parents Anonymous xs =
+      pure xs
+    parents par _ =
+      internalError $ "qualifiedMessageTypeName: wrong parent " <> show par
+
 --------------------------------------------------------------------------------
 --
 -- ** Codegen bookkeeping helpers

src/Proto3/Suite/DotProto/Parsing.hs

@@ -103,12 +103,10 @@ singleIdentifier = Single <$> token identifierName
 identifier :: ProtoParser DotProtoIdentifier
 identifier = token _identifier
 
--- [note] message and enum types are defined by the proto3 spec to have an optional leading period (messageType and enumType in the spec)
---        what this indicates is, as far as i can tell, not documented, and i haven't found this syntax used in practice
---        it's ommitted but can be fairly easily added if there is in fact a use for it
-
--- [update] the leading dot denotes that the identifier path starts in global scope
---          i still haven't seen a use case for this but i can add it upon request
+-- Parses a full identifier, consuming trailing space.
+-- The leading dot denotes that the identifier path starts in global scope.
+globalIdentifier :: ProtoParser DotProtoIdentifier
+globalIdentifier = token $ string "." >> _identifier
 
 -- Parses a nested identifier, consuming trailing space.
 nestedIdentifier :: ProtoParser DotProtoIdentifier
@@ -162,7 +160,7 @@ primType = try (symbol "double"   $> Double)
        <|> try (symbol "string"   $> String)
        <|> try (symbol "bytes"    $> Bytes)
        <|> try (symbol "bool"     $> Bool)
-       <|> Named <$> identifier
+       <|> Named <$> (identifier <|> globalIdentifier)
 
 --------------------------------------------------------------------------------
 -- top-level parser and version annotation
@@ -256,7 +254,7 @@ rpcOptions = braces $ many topOption
 
 rpcClause :: ProtoParser (DotProtoIdentifier, Streaming)
 rpcClause = do
-  let sid ctx = (,ctx) <$> identifier
+  let sid ctx = (,ctx) <$> (identifier <|> globalIdentifier)
   -- NB: Distinguish "stream stream.foo" from "stream.foo"
   try (symbol "stream" *> sid Streaming) <|> sid NonStreaming
 
@@ -296,6 +294,7 @@ messagePart = try (DotProtoMessageDefinition <$> enum)
           <|> try (DotProtoMessageDefinition <$> message)
           <|> try messageOneOf
           <|> try (DotProtoMessageField      <$> messageField)
+          <|> try (DotProtoMessageOption     <$> topOption)
 
 messageType :: ProtoParser DotProtoType
 messageType = try mapType <|> try repType <|> (Prim <$> primType)

src/Proto3/Suite/DotProto/Rendering.hs

@@ -129,6 +129,8 @@ prettyPrintProtoDefinition opts = defn where
     <+> (PP.hcat . PP.punctuate (PP.text ", ") $ pPrint <$> reservations)
     <>  PP.text ";"
   msgPart msgName (DotProtoMessageOneOf name fields)     = vbraces (PP.text "oneof" <+> pPrint name) (PP.vcat $ field msgName <$> fields)
+  msgPart _       (DotProtoMessageOption opt)
+    = PP.text "option" <+> pPrint opt <> PP.text ";"
 
   field :: DotProtoIdentifier -> DotProtoField -> PP.Doc
   field msgName (DotProtoField number mtype name options comments)

test-files/leading_dot/data.proto

@@ -0,0 +1,11 @@
+syntax = "proto3";
+
+package LeadingDot.Rpc.Data;
+
+message Request {
+  uint32 hello = 1;
+}
+
+message Response {
+  uint32 world = 1;
+}