From 5cdb2783f15058f753c41b800415d4ba1149a78b Mon Sep 17 00:00:00 2001
From: Owen Harvey <owenlharvey@gmail.com>
Date: Wed, 13 Sep 2023 16:20:38 +1000
Subject: [PATCH] Adding the required flag to request bodies, matching servant
 semantics

---
 src/Servant/OpenApi.hs               | 11 +++++---
 src/Servant/OpenApi/Internal.hs      |  2 ++
 src/Servant/OpenApi/Internal/Test.hs |  4 +--
 test/Servant/OpenApiSpec.hs          | 41 ++++++++++++++++++++++++++++
 4 files changed, 52 insertions(+), 6 deletions(-)

diff --git a/src/Servant/OpenApi.hs b/src/Servant/OpenApi.hs
index 1cf5689..4f6db7e 100644
--- a/src/Servant/OpenApi.hs
+++ b/src/Servant/OpenApi.hs
@@ -157,7 +157,8 @@ import           Servant.OpenApi.Internal.Orphans ()
 --                                 "$ref": "#/components/schemas/User"
 --                             }
 --                         }
---                     }
+--                     },
+--                     "required": true
 --                 },
 --                 "responses": {
 --                     "200": {
@@ -288,7 +289,8 @@ import           Servant.OpenApi.Internal.Orphans ()
 --                                 "$ref": "#/components/schemas/User"
 --                             }
 --                         }
---                     }
+--                     },
+--                     "required": true
 --                 },
 --                 "responses": {
 --                     "200": {
@@ -420,7 +422,8 @@ import           Servant.OpenApi.Internal.Orphans ()
 --                                 "$ref": "#/components/schemas/User"
 --                             }
 --                         }
---                     }
+--                     },
+--                     "required": true
 --                 },
 --                 "responses": {
 --                     "200": {
@@ -512,7 +515,7 @@ import           Servant.OpenApi.Internal.Orphans ()
 -- UserId...
 -- ...
 -- Finished in ... seconds
--- ...3 examples, 0 failures...
+-- 3 examples, 0 failures
 --
 -- Although servant is great, chances are that your API clients don't use Haskell.
 -- In many cases @swagger.json@ serves as a specification, not a Haskell type.
diff --git a/src/Servant/OpenApi/Internal.hs b/src/Servant/OpenApi/Internal.hs
index 7551058..407f2a8 100644
--- a/src/Servant/OpenApi/Internal.hs
+++ b/src/Servant/OpenApi/Internal.hs
@@ -402,6 +402,8 @@ instance (ToSchema a, AllAccept cs, HasOpenApi sub, KnownSymbol (FoldDescription
       (defs, ref) = runDeclare (declareSchemaRef (Proxy :: Proxy a)) mempty
       reqBody = (mempty :: RequestBody)
         & description .~ transDesc (reflectDescription (Proxy :: Proxy mods))
+        -- ReqBody' is always required, as per the Servant documentation
+        & required ?~ True
         & content .~ InsOrdHashMap.fromList [(t, mempty & schema ?~ ref) | t <- allContentType (Proxy :: Proxy cs)]
 
 -- | This instance is an approximation.
diff --git a/src/Servant/OpenApi/Internal/Test.hs b/src/Servant/OpenApi/Internal/Test.hs
index d5c7fc7..772f114 100644
--- a/src/Servant/OpenApi/Internal/Test.hs
+++ b/src/Servant/OpenApi/Internal/Test.hs
@@ -56,7 +56,7 @@ import           Servant.OpenApi.Internal.TypeLevel
 --   UserId...
 -- ...
 -- Finished in ... seconds
--- ...2 examples, 0 failures...
+-- 2 examples, 0 failures
 --
 -- For the test to compile all body types should have the following instances:
 --
@@ -122,7 +122,7 @@ validateEveryToJSONWithPatternChecker checker _ = props
 --   [Char]...
 -- ...
 -- Finished in ... seconds
--- ...3 examples, 0 failures...
+-- 3 examples, 0 failures
 props :: forall p p'' cs xs. TMap (Every (Typeable ': Show ': Arbitrary ': cs)) xs =>
   p cs                                          -- ^ A list of constraints.
   -> (forall x. EveryTF cs x => x -> Property)  -- ^ Property predicate.
diff --git a/test/Servant/OpenApiSpec.hs b/test/Servant/OpenApiSpec.hs
index df9555d..7a0b239 100644
--- a/test/Servant/OpenApiSpec.hs
+++ b/test/Servant/OpenApiSpec.hs
@@ -65,6 +65,7 @@ newtype TodoId = TodoId String deriving (Generic)
 instance ToParamSchema TodoId
 
 type TodoAPI = "todo" :> Capture "id" TodoId :> Get '[JSON] Todo
+          :<|> "todo" :> Capture "id" TodoId :> ReqBody '[JSON] Todo :> Post '[JSON] Todo
 
 todoAPI :: Value
 todoAPI = [aesonQQ|
@@ -129,6 +130,46 @@ todoAPI = [aesonQQ|
             "name": "id"
           }
         ]
+      },
+      "post": {
+        "requestBody": {
+          "required": true,
+          "content": {
+            "application/json;charset=utf-8": {
+              "schema": {
+                "$ref": "#/components/schemas/Todo"
+              }
+            }
+          }
+        },
+        "responses": {
+          "404": {
+            "description": "`id` not found"
+          },
+          "400": {
+            "description": "Invalid `body`"
+          },
+          "200": {
+            "content": {
+              "application/json;charset=utf-8": {
+                "schema": {
+                  "$ref": "#/components/schemas/Todo"
+                }
+              }
+            },
+            "description": ""
+          }
+        },
+        "parameters": [
+          {
+            "required": true,
+            "schema": {
+              "type": "string"
+            },
+            "in": "path",
+            "name": "id"
+          }
+        ]
       }
     }
   }