git.iko.soy/typeable/openapi3
on 67f8475 help sign in
typeable/openapi3/src/Data/Swagger/Operation.hs
196 lines 7.4 kB history raw
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.
12module Data.Swagger.Operation (
13 -- * Operation traversals
14 allOperations,
15 operationsOf,
17 -- * Manipulation
18 -- ** Tags
19 applyTags,
20 applyTagsFor,
22 -- ** Responses
23 setResponse,
24 setResponseWith,
25 setResponseFor,
26 setResponseForWith,
28 -- ** Paths
29 prependPath,
31 -- * Miscellaneous
32 declareResponse,
33) where
35import Control.Applicative
36import Control.Arrow
37import Control.Lens
38import Data.Data.Lens
39import qualified Data.HashMap.Strict as HashMap
40import Data.List
41import Data.Maybe (mapMaybe)
42import Data.Monoid
43import qualified Data.Set as Set
44import Data.Traversable
46import Data.Swagger.Declare
47import Data.Swagger.Internal
48import Data.Swagger.Lens
49import Data.Swagger.Schema
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 %~ mapKeys (path </>)
64 where
65 mapKeys f = HashMap.fromList . map (first f) . HashMap.toList
67 x </> y = case trim y of
68 "" -> "/" <> trim x
69 y' -> "/" <> trim x <> "/" <> y'
71 trim = dropWhile (== '/') . dropWhileEnd (== '/')
73-- | All operations of a Swagger spec.
74allOperations :: Traversal' Swagger Operation
75allOperations = paths.traverse.template
77-- | @'operationsOf' sub@ will traverse only those operations
78-- that are present in @sub@. Note that @'Operation'@ is determined
79-- by both path and method.
80--
81-- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK"
82-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]
83-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
84-- >>> encode api
85-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
86-- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found"
87-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}}}}}"
88operationsOf :: Swagger -> Traversal' Swagger Operation
89operationsOf sub = paths.itraversed.withIndex.subops
90 where
91 -- | Traverse operations that correspond to paths and methods of the sub API.
92 subops :: Traversal' (FilePath, PathItem) Operation
93 subops f (path, item) = case HashMap.lookup path (sub ^. paths) of
94 Just subitem -> (,) path <$> methodsOf subitem f item
95 Nothing -> pure (path, item)
97 -- | Traverse operations that exist in a given @'PathItem'@
98 -- This is used to traverse only the operations that exist in sub API.
99 methodsOf :: PathItem -> Traversal' PathItem Operation
100 methodsOf pathItem = partsOf template . itraversed . indices (`elem` ns) . _Just
101 where
102 ops = pathItem ^.. template :: [Maybe Operation]
103 ns = mapMaybe (fmap fst . sequenceA) $ zip [0..] ops
105-- | Apply tags to all operations and update the global list of tags.
106--
107-- @
108-- 'applyTags' = 'applyTagsFor' 'allOperations'
109-- @
110applyTags :: [Tag] -> Swagger -> Swagger
111applyTags = applyTagsFor allOperations
113-- | Apply tags to a part of Swagger spec and update the global
114-- list of tags.
115applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
116applyTagsFor ops ts swag = swag
117 & ops . tags %~ (<> Set.fromList (map _tagName ts))
118 & tags %~ (<> Set.fromList ts)
120-- | Construct a response with @'Schema'@ while declaring all
121-- necessary schema definitions.
122--
123-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty
124-- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}]"
125declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response
126declareResponse proxy = do
127 s <- declareSchemaRef proxy
128 return (mempty & schema ?~ s)
130-- | Set response for all operations.
131-- This will also update global schema definitions.
132--
133-- If the response already exists it will be overwritten.
134--
135-- @
136-- 'setResponse' = 'setResponseFor' 'allOperations'
137-- @
138--
139-- Example:
140--
141-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
142-- >>> let res = declareResponse (Proxy :: Proxy Day)
143-- >>> encode $ api & setResponse 200 res
144-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}}}"
145--
146-- See also @'setResponseWith'@.
147setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
148setResponse = setResponseFor allOperations
150-- | Set or update response for all operations.
151-- This will also update global schema definitions.
152--
153-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),
154-- then just the new response is used.
155--
156-- @
157-- 'setResponseWith' = 'setResponseForWith' 'allOperations'
158-- @
159--
160-- See also @'setResponse'@.
161setResponseWith :: (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
162setResponseWith = setResponseForWith allOperations
164-- | Set response for specified operations.
165-- This will also update global schema definitions.
166--
167-- If the response already exists it will be overwritten.
168--
169-- See also @'setResponseForWith'@.
170setResponseFor :: Traversal' Swagger Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
171setResponseFor ops code dres swag = swag
172 & definitions %~ (<> defs)
173 & ops . at code ?~ Inline res
174 where
175 (defs, res) = runDeclare dres mempty
177-- | Set or update response for specified operations.
178-- This will also update global schema definitions.
179--
180-- If the response already exists, but it can't be dereferenced (invalid @\$ref@),
181-- then just the new response is used.
182--
183-- See also @'setResponseFor'@.
184setResponseForWith :: Traversal' Swagger Operation -> (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
185setResponseForWith ops f code dres swag = swag
186 & definitions %~ (<> defs)
187 & ops . at code %~ Just . Inline . combine
188 where
189 (defs, new) = runDeclare dres mempty
191 combine (Just (Ref (Reference name))) = case swag ^. responses.at name of
192 Just old -> f old new
193 Nothing -> new -- response name can't be dereferenced, replacing with new response
194 combine (Just (Inline old)) = f old new
195 combine Nothing = new