Merge pull request #1241 from Simspace/issue-1240

merge documentation from duplicate routes
This commit is contained in:
Oleg Grenrus 2019-12-14 22:23:25 +02:00 committed by GitHub
commit e229efdf25
No known key found for this signature in database
GPG key ID: 4AEE18F83AFDEB23
3 changed files with 44 additions and 9 deletions

15
changelog.d/issue1240 Normal file
View file

@ -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.
}

View file

@ -131,7 +131,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 b2)
mempty = API mempty mempty
-- | An empty 'API'
@ -240,6 +241,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 four lenses.
@ -284,11 +294,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'.

View file

@ -66,8 +66,10 @@ spec = describe "Servant.Docs" $ do
golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs)
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
@ -79,7 +81,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"
@ -107,7 +109,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"
@ -130,6 +132,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
@ -156,6 +163,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)