git.iko.soy/servant
on master help sign in
Merge pull request #1241 from Simspace/issue-1240
e229efdOleg Grenrus
changelog.d/issue1240new file+15
compare with master
unifiedsplit
@@ -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
131 (<>) = mappend
131 (<>) = mappend
132
132
133instance Monoid API where
133instance 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)
135 mempty = API mempty mempty
136 mempty = API mempty mempty
136
137
137-- | An empty 'API'
138-- | An empty 'API'
@@ -240,6 +241,15 @@ data Response = Response
240 , _respHeaders :: [HTTP.Header]
241 , _respHeaders :: [HTTP.Header]
241 } deriving (Eq, Ord, Show)
242 } deriving (Eq, Ord, Show)
242
243
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+
243-- | Default response: status code 200, no response body.
253-- | Default response: status code 200, no response body.
244--
254--
245-- Can be tweaked with four lenses.
255-- Can be tweaked with four lenses.
@@ -284,11 +294,10 @@ data Action = Action
284-- laws.
294-- laws.
285--
295--
286-- As such, we invent a non-commutative, left associative operation
296-- As such, we invent a non-commutative, left associative operation
287−-- 'combineAction' to mush two together taking the response, body and content
297+-- 'combineAction' to mush two together taking the response from the very left.
288−-- types from the very left.
289combineAction :: Action -> Action -> Action
298combineAction :: Action -> Action -> Action
290−Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' _ _ _ =
299+Action a c h p n m ts body resp `combineAction` Action a' c' h' p' n' m' ts' body' resp' =
291− Action (a <> a') (c <> c') (h <> h') (p <> p') (n <> n') (m <> 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')
292
301
293-- | Default 'Action'. Has no 'captures', no query 'params', expects
302-- | Default 'Action'. Has no 'captures', no query 'params', expects
294-- no request body ('rqbody') and the typical response is 'defResponse'.
303-- 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
66 golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs)
66 golden "comprehensive API" "golden/comprehensive.md" (markdown comprehensiveDocs)
67
67
68 describe "markdown" $ do
68 describe "markdown" $ do
69− let md = markdown (docs (Proxy :: Proxy TestApi1))
69+ let md1 = markdown (docs (Proxy :: Proxy TestApi1))
70− tests md
70+ tests1 md1
71+ let md2 = markdown (docs (Proxy :: Proxy TestApi2))
72+ tests2 md2
71
73
72 describe "markdown with extra info" $ do
74 describe "markdown with extra info" $ do
73 let
75 let
@@ -79,7 +81,7 @@ spec = describe "Servant.Docs" $ do
79 (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))
81 (Proxy :: Proxy (ReqBody '[JSON] String :> Post '[JSON] Datatype1))
80 (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])
82 (defAction & notes <>~ [DocNote "Post data" ["Posts some Json data"]])
81 md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))
83 md = markdown (docsWith defaultDocOptions [] extra (Proxy :: Proxy TestApi1))
82− tests md
84+ tests1 md
83 it "contains the extra info provided" $ do
85 it "contains the extra info provided" $ do
84 md `shouldContain` "Get an Integer"
86 md `shouldContain` "Get an Integer"
85 md `shouldContain` "Post data"
87 md `shouldContain` "Post data"
@@ -107,7 +109,7 @@ spec = describe "Servant.Docs" $ do
107
109
108
110
109 where
111 where
110− tests md = do
112+ tests1 md = do
111 it "mentions supported content-types" $ do
113 it "mentions supported content-types" $ do
112 md `shouldContain` "application/json"
114 md `shouldContain` "application/json"
113 md `shouldContain` "text/plain;charset=utf-8"
115 md `shouldContain` "text/plain;charset=utf-8"
@@ -130,6 +132,11 @@ spec = describe "Servant.Docs" $ do
130 it "does not generate any docs mentioning the 'empty-api' path" $
132 it "does not generate any docs mentioning the 'empty-api' path" $
131 md `shouldNotContain` "empty-api"
133 md `shouldNotContain` "empty-api"
132
134
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+
133
140
134-- * APIs
141-- * APIs
135
142
@@ -156,6 +163,10 @@ type TestApi1 = Get '[JSON, PlainText] (Headers '[Header "Location" String] Int)
156 :<|> Header "X-Test" Int :> Put '[JSON] Int
163 :<|> Header "X-Test" Int :> Put '[JSON] Int
157 :<|> "empty-api" :> EmptyAPI
164 :<|> "empty-api" :> EmptyAPI
158
165
166+type TestApi2 = "duplicate-endpoint" :> Get '[JSON] Datatype1
167+ :<|> "duplicate-endpoint" :> Get '[PlainText] Int
168+
169+
159data TT = TT1 | TT2 deriving (Show, Eq)
170data TT = TT1 | TT2 deriving (Show, Eq)
160data UT = UT1 | UT2 deriving (Show, Eq)
171data UT = UT1 | UT2 deriving (Show, Eq)
161
172