-
Notifications
You must be signed in to change notification settings - Fork 59
Commit
This commit does not belong to any branch on this repository, and may belong to a fork outside of the repository.
Merge pull request #50 from GetShopTV/operation-helpers
Add Data.Swagger.Operation with a few helpers
- Loading branch information
Showing
4 changed files
with
203 additions
and
6 deletions.
There are no files selected for viewing
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -0,0 +1,195 @@ | ||
{-# LANGUAGE RankNTypes #-} | ||
-- | | ||
-- Module: Data.Swagger.Operation | ||
-- Copyright: (c) 2015 GetShopTV | ||
-- License: BSD3 | ||
-- Maintainer: Nickolay Kudasov <nickolay@getshoptv.com> | ||
-- Stability: experimental | ||
-- | ||
-- Helper traversals and functions for Swagger operations manipulations. | ||
-- These might be useful when you already have Swagger specification | ||
-- generated by something else. | ||
module Data.Swagger.Operation ( | ||
-- * Operation traversals | ||
allOperations, | ||
operationsOf, | ||
|
||
-- * Manipulation | ||
-- ** Tags | ||
applyTags, | ||
applyTagsFor, | ||
|
||
-- ** Responses | ||
setResponse, | ||
setResponseWith, | ||
setResponseFor, | ||
setResponseForWith, | ||
|
||
-- ** Paths | ||
prependPath, | ||
|
||
-- * Miscellaneous | ||
declareResponse, | ||
) where | ||
|
||
import Control.Applicative | ||
import Control.Arrow | ||
import Control.Lens | ||
import Data.Data.Lens | ||
import qualified Data.HashMap.Strict as HashMap | ||
import Data.List | ||
import Data.Maybe (mapMaybe) | ||
import Data.Monoid | ||
import Data.Traversable | ||
|
||
import Data.Swagger.Declare | ||
import Data.Swagger.Internal | ||
import Data.Swagger.Lens | ||
import Data.Swagger.Schema | ||
|
||
-- $setup | ||
-- >>> import Data.Aeson | ||
-- >>> import Data.Proxy | ||
-- >>> import Data.Time | ||
|
||
-- | Prepend path piece to all operations of the spec. | ||
-- Leading and trailing slashes are trimmed/added automatically. | ||
-- | ||
-- >>> let api = (mempty :: Swagger) & paths .~ [("/info", mempty)] | ||
-- >>> encode $ prependPath "user/{user_id}" api ^. paths | ||
-- "{\"/user/{user_id}/info\":{}}" | ||
prependPath :: FilePath -> Swagger -> Swagger | ||
prependPath path = paths %~ mapKeys (path </>) | ||
where | ||
mapKeys f = HashMap.fromList . map (first f) . HashMap.toList | ||
|
||
x </> y = case trim y of | ||
"" -> "/" <> trim x | ||
y' -> "/" <> trim x <> "/" <> y' | ||
|
||
trim = dropWhile (== '/') . dropWhileEnd (== '/') | ||
|
||
-- | All operations of a Swagger spec. | ||
allOperations :: Traversal' Swagger Operation | ||
allOperations = paths.traverse.template | ||
|
||
-- | @'operationsOf' sub@ will traverse only those operations | ||
-- that are present in @sub@. Note that @'Operation'@ is determined | ||
-- by both path and method. | ||
-- | ||
-- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK" | ||
-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)] | ||
-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)] | ||
-- >>> encode api | ||
-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}" | ||
-- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found" | ||
-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}}}}}" | ||
operationsOf :: Swagger -> Traversal' Swagger Operation | ||
operationsOf sub = paths.itraversed.withIndex.subops | ||
where | ||
-- | Traverse operations that correspond to paths and methods of the sub API. | ||
subops :: Traversal' (FilePath, PathItem) Operation | ||
subops f (path, item) = case HashMap.lookup path (sub ^. paths) of | ||
Just subitem -> (,) path <$> methodsOf subitem f item | ||
Nothing -> pure (path, item) | ||
|
||
-- | Traverse operations that exist in a given @'PathItem'@ | ||
-- This is used to traverse only the operations that exist in sub API. | ||
methodsOf :: PathItem -> Traversal' PathItem Operation | ||
methodsOf pathItem = partsOf template . itraversed . indices (`elem` ns) . _Just | ||
where | ||
ops = pathItem ^.. template :: [Maybe Operation] | ||
ns = mapMaybe (fmap fst . sequenceA) $ zip [0..] ops | ||
|
||
-- | Apply tags to all operations and update the global list of tags. | ||
-- | ||
-- @ | ||
-- 'applyTags' = 'applyTagsFor' 'allOperations' | ||
-- @ | ||
applyTags :: [Tag] -> Swagger -> Swagger | ||
applyTags = applyTagsFor allOperations | ||
|
||
-- | Apply tags to a part of Swagger spec and update the global | ||
-- list of tags. | ||
applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger | ||
applyTagsFor ops ts swag = swag | ||
& ops . tags %~ (map _tagName ts ++) | ||
& tags %~ (ts ++) | ||
|
||
-- | Construct a response with @'Schema'@ while declaring all | ||
-- necessary schema definitions. | ||
-- | ||
-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty | ||
-- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}]" | ||
declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response | ||
declareResponse proxy = do | ||
s <- declareSchemaRef proxy | ||
return (mempty & schema ?~ s) | ||
|
||
-- | Set response for all operations. | ||
-- This will also update global schema definitions. | ||
-- | ||
-- If the response already exists it will be overwritten. | ||
-- | ||
-- @ | ||
-- 'setResponse' = 'setResponseFor' 'allOperations' | ||
-- @ | ||
-- | ||
-- Example: | ||
-- | ||
-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)] | ||
-- >>> let res = declareResponse (Proxy :: Proxy Day) | ||
-- >>> encode $ api & setResponse 200 res | ||
-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}}}" | ||
-- | ||
-- See also @'setResponseWith'@. | ||
setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger | ||
setResponse = setResponseFor allOperations | ||
|
||
-- | Set or update response for all operations. | ||
-- This will also update global schema definitions. | ||
-- | ||
-- If the response already exists, but it can't be dereferenced (invalid @\$ref@), | ||
-- then just the new response is used. | ||
-- | ||
-- @ | ||
-- 'setResponseWith' = 'setResponseForWith' 'allOperations' | ||
-- @ | ||
-- | ||
-- See also @'setResponse'@. | ||
setResponseWith :: (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger | ||
setResponseWith = setResponseForWith allOperations | ||
|
||
-- | Set response for specified operations. | ||
-- This will also update global schema definitions. | ||
-- | ||
-- If the response already exists it will be overwritten. | ||
-- | ||
-- See also @'setResponseForWith'@. | ||
setResponseFor :: Traversal' Swagger Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger | ||
setResponseFor ops code dres swag = swag | ||
& definitions %~ (<> defs) | ||
& ops . at code ?~ Inline res | ||
where | ||
(defs, res) = runDeclare dres mempty | ||
|
||
-- | Set or update response for specified operations. | ||
-- This will also update global schema definitions. | ||
-- | ||
-- If the response already exists, but it can't be dereferenced (invalid @\$ref@), | ||
-- then just the new response is used. | ||
-- | ||
-- See also @'setResponseFor'@. | ||
setResponseForWith :: Traversal' Swagger Operation -> (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger | ||
setResponseForWith ops f code dres swag = swag | ||
& definitions %~ (<> defs) | ||
& ops . at code %~ Just . Inline . combine | ||
where | ||
(defs, new) = runDeclare dres mempty | ||
|
||
combine (Just (Ref (Reference name))) = case swag ^. responses.at name of | ||
Just old -> f old new | ||
Nothing -> new -- response name can't be dereferenced, replacing with new response | ||
combine (Just (Inline old)) = f old new | ||
combine Nothing = new | ||
|
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters
This file contains bidirectional Unicode text that may be interpreted or compiled differently than what appears below. To review, open the file in an editor that reveals hidden Unicode characters.
Learn more about bidirectional Unicode characters