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