git.iko.soy/typeable/servant
on master help sign in
Merge pull request #1241 from Simspace/issue-1240

merge documentation from duplicate routes

commite229efdf250de53d5b2db1802ca29214ab6c6931 authorOleg Grenrus <oleg.grenrus@iki.fi> dateSat 14 Dec 2019, 22:23 (7 years ago) parente1039520cfd9e6
3 files changed+44−9
compare with master
unifiedsplit
changelog.d/issue1240+15 servant-docs/src/Servant/Docs/Internal.hs+14−5 servant-docs/test/Servant/DocsSpec.hs+15−4
changelog.d/issue1240new file+15
@@ -0,0 +1,15 @@
1+synopsis: Merge documentation from duplicate routes
2+prs: #1241
3+issues: #1240
4+
5+description: {
6+
7+Servant supports defining the same route multiple times with different
8+content-types and result-types, but servant-docs was only documenting
9+the first of copy of such duplicated routes. It now combines the
10+documentation from all the copies.
11+
12+Unfortunately, it is not yet possible for the documentation to specify
13+multiple status codes.
14+
15+}
servant-docs/src/Servant/Docs/Internal.hs+14−5
@@ -131,7 +131,8 @@ instance Semigroup API where
131131 (<>) = mappend
132132
133133instance Monoid API where
134− API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2) (b1 `mappend` b2)
134+ API a1 b1 `mappend` API a2 b2 = API (a1 `mappend` a2)
135+ (HM.unionWith combineAction b1 b2)
135136 mempty = API mempty mempty
136137
137138-- | An empty 'API'
@@ -240,6 +241,15 @@ data Response = Response
240241 , _respHeaders :: [HTTP.Header]
241242 } deriving (Eq, Ord, Show)
242243
244+-- | Combine two Responses, we can't make a monoid because merging Status breaks
245+-- the laws.
246+--
247+-- As such, we invent a non-commutative, left associative operation
248+-- 'combineResponse' to mush two together taking the status from the very left.
249+combineResponse :: Response -> Response -> Response
250+Response s ts bs hs `combineResponse` Response _ ts' bs' hs'
251+ = Response s (ts <> ts') (bs <> bs') (hs <> hs')
252+
243253-- | Default response: status code 200, no response body.
244254--
245255-- Can be tweaked with four lenses.
@@ -284,11 +294,10 @@ data Action = Action
284294-- laws.
285295--
286296-- As such, we invent a non-commutative, left associative operation
287−-- 'combineAction' to mush two together taking the response, body and content
288−-- types from the very left.
297+-- 'combineAction' to mush two together taking the response from the very left.
289298combineAction :: Action -> Action -> Action
290−Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =
291− Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') ts body resp
299+Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' body' resp' =
300+ Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> m') (ts <> ts') (body <> body') (resp `combineResponse` resp')
292301
293302-- | Default 'Action'. Has no 'captures', no query 'params', expects
294303-- no request body ('rqbody') and the typical response is 'defResponse'.
servant-docs/test/Servant/DocsSpec.hs+15−4
@@ -66,8 +66,10 @@ spec = describe "Servant.Docs" $ do
6666 golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs)
6767
6868 describe "markdown" $ do
69− let md = markdown (docs (Proxy :: Proxy TestApi1))
70− tests md
69+ let md1 = markdown (docs (Proxy :: Proxy TestApi1))
70+ tests1 md1
71+ let md2 = markdown (docs (Proxy :: Proxy TestApi2))
72+ tests2 md2
7173
7274 describe "markdown with extra info" $ do
7375 let
@@ -79,7 +81,7 @@ spec = describe "Servant.Docs" $ do
7981 (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))
8082 (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])
8183 md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))
82− tests md
84+ tests1 md
8385 it "contains the extra info provided" $ do
8486 md `shouldContain` "Get an Integer"
8587 md `shouldContain` "Post data"
@@ -107,7 +109,7 @@ spec = describe "Servant.Docs" $ do
107109
108110
109111 where
110− tests md = do
112+ tests1 md = do
111113 it "mentions supported content-types" $ do
112114 md `shouldContain` "application/json"
113115 md `shouldContain` "text/plain;charset=utf-8"
@@ -130,6 +132,11 @@ spec = describe "Servant.Docs" $ do
130132 it "does not generate any docs mentioning the 'empty-api' path" $
131133 md `shouldNotContain` "empty-api"
132134
135+ tests2 md = do
136+ it "mentions the content-types from both copies of the route" $ do
137+ md `shouldContain` "application/json"
138+ md `shouldContain` "text/plain;charset=utf-8"
139+
133140
134141-- * APIs
135142
@@ -156,6 +163,10 @@ type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)
156163 :<|> Header "X-Test" Int :> Put '[JSON] Int
157164 :<|> "empty-api" :> EmptyAPI
158165
166+type TestApi2 = "duplicate-endpoint" :> Get '[JSON] Datatype1
167+ :<|> "duplicate-endpoint" :> Get '[PlainText] Int
168+
169+
159170data TT = TT1 | TT2 deriving (Show, Eq)
160171data UT = UT1 | UT2 deriving (Show, Eq)
161172