Merge pull request #133 from amiddelk/#132-infinite-expansion-datatyp…

…enamemodifier Fixes #132: Nontermination when using datatypeNameModifier with recursive data types
GetShopTV · Dec 31, 2017 · c669a64 · c669a64
2 parents f014fbc + 4376384
commit c669a64
Show file tree

Hide file tree

Showing 2 changed files with 35 additions and 2 deletions.
diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs
@@ -680,11 +680,12 @@ genericNameSchema :: forall a d f proxy.
 genericNameSchema opts _ = NamedSchema (gdatatypeSchemaName opts (Proxy :: Proxy d))
 
 gdatatypeSchemaName :: forall proxy d. Datatype d => SchemaOptions -> proxy d -> Maybe T.Text
-gdatatypeSchemaName opts _ = case name of
+gdatatypeSchemaName opts _ = case orig of
   (c:_) | isAlpha c && isUpper c -> Just (T.pack name)
   _ -> Nothing
   where
-    name = datatypeNameModifier opts (datatypeName (Proxy3 :: Proxy3 d f a))
+    orig = datatypeName (Proxy3 :: Proxy3 d f a)
+    name = datatypeNameModifier opts orig
 
 -- | Lift a plain @'ParamSchema'@ into a model @'NamedSchema'@.
 paramSchemaToNamedSchema :: forall a d f proxy.

diff --git a/test/Data/Swagger/SchemaSpec.hs b/test/Data/Swagger/SchemaSpec.hs
@@ -80,6 +80,7 @@ spec = do
       context "Player (unary record)" $ checkToSchema (Proxy :: Proxy Player) playerSchemaJSON
     context "Players (inlining schema)" $ checkToSchema (Proxy :: Proxy Players) playersSchemaJSON
     context "MyRoseTree (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
+    context "MyRoseTree' (datatypeNameModifier)" $ checkToSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
     context "Sum types" $ do
       context "Status (sum of unary constructors)" $ checkToSchema (Proxy :: Proxy Status) statusSchemaJSON
       context "Character (ref and record sum)" $ checkToSchema (Proxy :: Proxy Character) characterSchemaJSON
@@ -95,6 +96,7 @@ spec = do
     context "Light" $ checkDefs (Proxy :: Proxy Light) ["Color"]
     context "Character" $ checkDefs (Proxy :: Proxy Character) ["Player", "Point"]
     context "MyRoseTree" $ checkDefs (Proxy :: Proxy MyRoseTree) ["RoseTree"]
+    context "MyRoseTree'" $ checkDefs (Proxy :: Proxy MyRoseTree') ["myrosetree'"]
     context "[Set (Unit, Maybe Color)]" $ checkDefs (Proxy :: Proxy [Set (Unit, Maybe Color)]) ["Unit", "Color"]
     context "ResourceId" $ checkDefs (Proxy :: Proxy ResourceId) []
   describe "Inlining Schemas" $ do
@@ -103,6 +105,7 @@ spec = do
     context "Character (inlining only Player)" $ checkInlinedSchemas ["Player"] (Proxy :: Proxy Character) characterInlinedPlayerSchemaJSON
     context "Light" $ checkInlinedSchema (Proxy :: Proxy Light) lightInlinedSchemaJSON
     context "MyRoseTree (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree) myRoseTreeSchemaJSON
+    context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'
   describe "Bounded Enum key mapping" $ do
     context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON
 
@@ -398,6 +401,35 @@ myRoseTreeSchemaJSON = [aesonQQ|
 }
 |]
 
+data MyRoseTree' = MyRoseTree'
+  { root'  :: String
+  , trees' :: [MyRoseTree']
+  } deriving (Generic)
+
+instance ToSchema MyRoseTree' where
+  declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions
+    { datatypeNameModifier = map toLower }
+
+myRoseTreeSchemaJSON' :: Value
+myRoseTreeSchemaJSON' = [aesonQQ|
+{
+  "type": "object",
+  "properties":
+    {
+      "root'": { "type": "string" },
+      "trees'":
+        {
+          "type": "array",
+          "items":
+            {
+              "$ref": "#/definitions/myrosetree'"
+            }
+        }
+    },
+  "required": ["root'", "trees'"]
+}
+|]
+
 -- ========================================================================
 -- Inlined (newtype for inlining schemas)
 -- ========================================================================