@@ -0,0 +1,195 @@
1+{-# LANGUAGE RankNTypes #-}
2+-- |
3+-- Module: Data.Swagger.Operation
4+-- Copyright: (c) 2015 GetShopTV
5+-- License: BSD3
6+-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com>
7+-- Stability: experimental
8+--
9+-- Helper traversals and functions for Swagger operations manipulations.
10+-- These might be useful when you already have Swagger specification
11+-- generated by something else.
12+module Data.Swagger.Operation (
13+ -- * Operation traversals
14+ allOperations,
15+ operationsOf,
16+
17+ -- * Manipulation
18+ -- ** Tags
19+ applyTags,
20+ applyTagsFor,
21+
22+ -- ** Responses
23+ setResponse,
24+ setResponseWith,
25+ setResponseFor,
26+ setResponseForWith,
27+
28+ -- ** Paths
29+ prependPath,
30+
31+ -- * Miscellaneous
32+ declareResponse,
33+) where
34+
35+import Control.Applicative
36+import Control.Arrow
37+import Control.Lens
38+import Data.Data.Lens
39+import qualified Data.HashMap.Strict as HashMap
40+import Data.List
41+import Data.Maybe (mapMaybe)
42+import Data.Monoid
43+import Data.Traversable
44+
45+import Data.Swagger.Declare
46+import Data.Swagger.Internal
47+import Data.Swagger.Lens
48+import Data.Swagger.Schema
49+
50+-- $setup
51+-- >>> import Data.Aeson
52+-- >>> import Data.Proxy
53+-- >>> import Data.Time
54+
55+-- | Prepend path piece to all operations of the spec.
56+-- Leading and trailing slashes are trimmed/added automatically.
57+--
58+-- >>> let api = (mempty :: Swagger) & paths .~ [("/info", mempty)]
59+-- >>> encode $ prependPath "user/{user_id}" api ^. paths
60+-- "{\"/user/{user_id}/info\":{}}"
61+prependPath :: FilePath -> Swagger -> Swagger
62+prependPath path = paths %~ mapKeys (path </>)
63+ where
64+ mapKeys f = HashMap.fromList . map (first f) . HashMap.toList
65+
66+ x </> y = case trim y of
67+ "" -> "/" <> trim x
68+ y' -> "/" <> trim x <> "/" <> y'
69+
70+ trim = dropWhile (== '/') . dropWhileEnd (== '/')
71+
72+-- | All operations of a Swagger spec.
73+allOperations :: Traversal' Swagger Operation
74+allOperations = paths.traverse.template
75+
76+-- | @'operationsOf' sub@ will traverse only those operations
77+-- that are present in @sub@. Note that @'Operation'@ is determined
78+-- by both path and method.
79+--
80+-- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK"
81+-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]
82+-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
83+-- >>> encode api
84+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
85+-- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found"
86+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}}}}}"
87+operationsOf :: Swagger -> Traversal' Swagger Operation
88+operationsOf sub = paths.itraversed.withIndex.subops
89+ where
90+ -- | Traverse operations that correspond to paths and methods of the sub API.
91+ subops :: Traversal' (FilePath, PathItem) Operation
92+ subops f (path, item) = case HashMap.lookup path (sub ^. paths) of
93+ Just subitem -> (,) path <$> methodsOf subitem f item
94+ Nothing -> pure (path, item)
95+
96+ -- | Traverse operations that exist in a given @'PathItem'@
97+ -- This is used to traverse only the operations that exist in sub API.
98+ methodsOf :: PathItem -> Traversal' PathItem Operation
99+ methodsOf pathItem = partsOf template . itraversed . indices (`elem` ns) . _Just
100+ where
101+ ops = pathItem ^.. template :: [Maybe Operation]
102+ ns = mapMaybe (fmap fst . sequenceA) $ zip [0..] ops
103+
104+-- | Apply tags to all operations and update the global list of tags.
105+--
106+-- @
107+-- 'applyTags' = 'applyTagsFor' 'allOperations'
108+-- @
109+applyTags :: [Tag] -> Swagger -> Swagger
110+applyTags = applyTagsFor allOperations
111+
112+-- | Apply tags to a part of Swagger spec and update the global
113+-- list of tags.
114+applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
115+applyTagsFor ops ts swag = swag
116+ & ops . tags %~ (map _tagName ts ++)
117+ & tags %~ (ts ++)
118+
119+-- | Construct a response with @'Schema'@ while declaring all
120+-- necessary schema definitions.
121+--
122+-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty
123+-- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}]"
124+declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response
125+declareResponse proxy = do
126+ s <- declareSchemaRef proxy
127+ return (mempty & schema ?~ s)
128+
129+-- | Set response for all operations.
130+-- This will also update global schema definitions.
131+--
132+-- If the response already exists it will be overwritten.
133+--
134+-- @
135+-- 'setResponse' = 'setResponseFor' 'allOperations'
136+-- @
137+--
138+-- Example:
139+--
140+-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
141+-- >>> let res = declareResponse (Proxy :: Proxy Day)
142+-- >>> encode $ api & setResponse 200 res
143+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}}}"
144+--
145+-- See also @'setResponseWith'@.
146+setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
147+setResponse = setResponseFor allOperations
148+
149+-- | Set or update response for all operations.
150+-- This will also update global schema definitions.
151+--
152+-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),
153+-- then just the new response is used.
154+--
155+-- @
156+-- 'setResponseWith' = 'setResponseForWith' 'allOperations'
157+-- @
158+--
159+-- See also @'setResponse'@.
160+setResponseWith :: (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
161+setResponseWith = setResponseForWith allOperations
162+
163+-- | Set response for specified operations.
164+-- This will also update global schema definitions.
165+--
166+-- If the response already exists it will be overwritten.
167+--
168+-- See also @'setResponseForWith'@.
169+setResponseFor :: Traversal' Swagger Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
170+setResponseFor ops code dres swag = swag
171+ & definitions %~ (<> defs)
172+ & ops . at code ?~ Inline res
173+ where
174+ (defs, res) = runDeclare dres mempty
175+
176+-- | Set or update response for specified operations.
177+-- This will also update global schema definitions.
178+--
179+-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),
180+-- then just the new response is used.
181+--
182+-- See also @'setResponseFor'@.
183+setResponseForWith :: Traversal' Swagger Operation -> (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
184+setResponseForWith ops f code dres swag = swag
185+ & definitions %~ (<> defs)
186+ & ops . at code %~ Just . Inline . combine
187+ where
188+ (defs, new) = runDeclare dres mempty
189+
190+ combine (Just (Ref (Reference name))) = case swag ^. responses.at name of
191+ Just old -> f old new
192+ Nothing -> new -- response name can't be dereferenced, replacing with new response
193+ combine (Just (Inline old)) = f old new
194+ combine Nothing = new
195+