From 143091eb3f1a153d17b1bdae12fb70b768e07cf3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Thu, 7 Nov 2019 18:53:41 -0500 Subject: [PATCH 1/4] merge documentation from duplicate routes Servant supports defining the same route multiple times with different content-types and result-types, but servant-docs was only documenting the first of copy of such duplicated routes. It now combines the documentation from all the copies. Unfortunately, it is not yet possible for the documentation to specify multiple status codes. --- servant-docs/src/Servant/Docs/Internal.hs | 20 +++++++++++++++----- 1 file changed, 15 insertions(+), 5 deletions(-) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index 4ba7c962..c102007e 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -20,6 +20,7 @@ #include "overlapping-compat.h" module Servant.Docs.Internal where +import Debug.Trace import Prelude () import Prelude.Compat @@ -116,7 +117,8 @@ instance Semigroup API where (<>) = mappend instance Monoid API where - API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) (b1 `mappend` b2) + API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) + (HM.unionWith combineAction b1 (traceShowId b2)) mempty = API mempty mempty -- | An empty 'API' @@ -223,6 +225,15 @@ data Response = Response , _respHeaders :: [HTTP.Header] } deriving (Eq, Ord, Show) +-- | Combine two Responses, we can't make a monoid because merging Status breaks +-- the laws. +-- +-- As such, we invent a non-commutative, left associative operation +-- 'combineResponse' to mush two together taking the status from the very left. +combineResponse :: Response -> Response -> Response +Response s ts bs hs `combineResponse` Response _ ts' bs' hs' + = Response s (ts <> ts') (bs <> bs') (hs <> hs') + -- | Default response: status code 200, no response body. -- -- Can be tweaked with two lenses. @@ -265,11 +276,10 @@ data Action = Action -- laws. -- -- As such, we invent a non-commutative, left associative operation --- 'combineAction' to mush two together taking the response, body and content --- types from the very left. +-- 'combineAction' to mush two together taking the response from the very left. combineAction :: Action -> Action -> Action -Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ = - Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp +Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' body' resp' = + Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp') -- | Default 'Action'. Has no 'captures', no query 'params', expects -- no request body ('rqbody') and the typical response is 'defResponse'. From 1f6d7d7ea8aef0cb927e89e308dd99874bda9daa Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Thu, 7 Nov 2019 19:01:56 -0500 Subject: [PATCH 2/4] remove leftover debug code --- servant-docs/src/Servant/Docs/Internal.hs | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/servant-docs/src/Servant/Docs/Internal.hs b/servant-docs/src/Servant/Docs/Internal.hs index c102007e..65394c4c 100644 --- a/servant-docs/src/Servant/Docs/Internal.hs +++ b/servant-docs/src/Servant/Docs/Internal.hs @@ -20,7 +20,6 @@ #include "overlapping-compat.h" module Servant.Docs.Internal where -import Debug.Trace import Prelude () import Prelude.Compat @@ -118,7 +117,7 @@ instance Semigroup API where instance Monoid API where API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) - (HM.unionWith combineAction b1 (traceShowId b2)) + (HM.unionWith combineAction b1 b2) mempty = API mempty mempty -- | An empty 'API' From fdb1e030e6a7e3565db4ee2f2b1317295b0025fd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Thu, 7 Nov 2019 19:08:45 -0500 Subject: [PATCH 3/4] add changelog.d entry --- changelog.d/issue1240 | 15 +++++++++++++++ 1 file changed, 15 insertions(+) create mode 100644 changelog.d/issue1240 diff --git a/changelog.d/issue1240 b/changelog.d/issue1240 new file mode 100644 index 00000000..95f6b05e --- /dev/null +++ b/changelog.d/issue1240 @@ -0,0 +1,15 @@ +synopsis: Merge documentation from duplicate routes +prs: #1241 +issues: #1240 + +description: { + +Servant supports defining the same route multiple times with different +content-types and result-types, but servant-docs was only documenting +the first of copy of such duplicated routes. It now combines the +documentation from all the copies. + +Unfortunately, it is not yet possible for the documentation to specify +multiple status codes. + +} From 0cfd9e6597a9a97e7e860a6a4468cda1da21eda7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Samuel=20G=C3=A9lineau?= Date: Thu, 7 Nov 2019 19:31:29 -0500 Subject: [PATCH 4/4] test "merge documentation from duplicate routes" --- servant-docs/test/Servant/DocsSpec.hs | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/servant-docs/test/Servant/DocsSpec.hs b/servant-docs/test/Servant/DocsSpec.hs index eedc18a9..c6f7a915 100644 --- a/servant-docs/test/Servant/DocsSpec.hs +++ b/servant-docs/test/Servant/DocsSpec.hs @@ -52,8 +52,10 @@ spec :: Spec spec = describe "Servant.Docs" $ do describe "markdown" $ do - let md = markdown (docs (Proxy :: Proxy TestApi1)) - tests md + let md1 = markdown (docs (Proxy :: Proxy TestApi1)) + tests1 md1 + let md2 = markdown (docs (Proxy :: Proxy TestApi2)) + tests2 md2 describe "markdown with extra info" $ do let @@ -65,7 +67,7 @@ spec = describe "Servant.Docs" $ do (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1)) (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]]) md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1)) - tests md + tests1 md it "contains the extra info provided" $ do md `shouldContain` "Get an Integer" md `shouldContain` "Post data" @@ -93,7 +95,7 @@ spec = describe "Servant.Docs" $ do where - tests md = do + tests1 md = do it "mentions supported content-types" $ do md `shouldContain` "application/json" md `shouldContain` "text/plain;charset=utf-8" @@ -116,6 +118,11 @@ spec = describe "Servant.Docs" $ do it "does not generate any docs mentioning the 'empty-api' path" $ md `shouldNotContain` "empty-api" + tests2 md = do + it "mentions the content-types from both copies of the route" $ do + md `shouldContain` "application/json" + md `shouldContain` "text/plain;charset=utf-8" + -- * APIs @@ -142,6 +149,10 @@ type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int) :<|> Header "X-Test" Int :> Put '[JSON] Int :<|> "empty-api" :> EmptyAPI +type TestApi2 = "duplicate-endpoint" :> Get '[JSON] Datatype1 + :<|> "duplicate-endpoint" :> Get '[PlainText] Int + + data TT = TT1 | TT2 deriving (Show, Eq) data UT = UT1 | UT2 deriving (Show, Eq)