openapi-hs-4.0.0: src/Data/OpenApi/Operation.hs
-- |
-- Module: Data.OpenApi.Operation
-- Maintainer: Nadeem Bitar <nadeem@gmail.com>
-- Stability: experimental
--
-- Helper traversals and functions for OpenAPI operations manipulations.
-- These might be useful when you already have an OpenAPI specification
-- generated by something else.
module Data.OpenApi.Operation
( -- * Operation traversals
allOperations,
operationsOf,
-- * Manipulation
-- ** Tags
applyTags,
applyTagsFor,
-- ** Responses
setResponse,
setResponseWith,
setResponseFor,
setResponseForWith,
-- ** Paths
prependPath,
-- * Miscellaneous
declareResponse,
)
where
import Control.Lens
import Data.Data.Lens
import Data.HashMap.Strict.InsOrd.Compat qualified as InsOrdHashMap
import Data.HashSet.InsOrd qualified as InsOrdHS
import Data.List.Compat
import Data.Maybe (mapMaybe)
import Data.OpenApi.Declare
import Data.OpenApi.Internal
import Data.OpenApi.Lens
import Data.OpenApi.Schema
import Data.Proxy
import Data.Set qualified as Set
import Data.Text (Text)
import Network.HTTP.Media (MediaType)
import Prelude.Compat
import Prelude ()
-- $setup
-- >>> import Data.Aeson
-- >>> import Data.Proxy
-- >>> import Data.Time
-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL
-- >>> import qualified Data.HashMap.Strict.InsOrd.Compat as IOHM
-- >>> import Data.OpenApi.Internal.Utils
-- | Prepend path piece to all operations of the spec.
-- Leading and trailing slashes are trimmed/added automatically.
--
-- >>> let api = (mempty :: OpenApi) & paths .~ IOHM.fromList [("/info", mempty)]
-- >>> BSL.putStrLn $ encodePretty $ prependPath "user/{user_id}" api ^. paths
-- {
-- "/user/{user_id}/info": {}
-- }
prependPath :: FilePath -> OpenApi -> OpenApi
prependPath path = paths %~ InsOrdHashMap.mapKeys (path </>)
where
x </> y = case trim y of
"" -> "/" <> trim x
y' -> "/" <> trim x <> "/" <> y'
trim = dropWhile (== '/') . dropWhileEnd (== '/')
-- | All operations of an OpenAPI spec.
allOperations :: Traversal' OpenApi 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 :: OpenApi) & paths .~ IOHM.fromList [("/user", mempty & get ?~ ok & post ?~ ok)]
-- >>> let sub = (mempty :: OpenApi) & paths .~ IOHM.fromList [("/user", mempty & get ?~ mempty)]
-- >>> BSL.putStrLn $ encodePretty api
-- {
-- "components": {},
-- "info": {
-- "title": "",
-- "version": ""
-- },
-- "openapi": "3.1.0",
-- "paths": {
-- "/user": {
-- "get": {
-- "responses": {
-- "200": {
-- "description": "OK"
-- }
-- }
-- },
-- "post": {
-- "responses": {
-- "200": {
-- "description": "OK"
-- }
-- }
-- }
-- }
-- }
-- }
-- >>> BSL.putStrLn $ encodePretty $ api & operationsOf sub . at 404 ?~ "Not found"
-- {
-- "components": {},
-- "info": {
-- "title": "",
-- "version": ""
-- },
-- "openapi": "3.1.0",
-- "paths": {
-- "/user": {
-- "get": {
-- "responses": {
-- "200": {
-- "description": "OK"
-- },
-- "404": {
-- "description": "Not found"
-- }
-- }
-- },
-- "post": {
-- "responses": {
-- "200": {
-- "description": "OK"
-- }
-- }
-- }
-- }
-- }
-- }
operationsOf :: OpenApi -> Traversal' OpenApi 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 InsOrdHashMap.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] -> OpenApi -> OpenApi
applyTags = applyTagsFor allOperations
-- | Apply tags to a part of an OpenAPI spec and update the global
-- list of tags.
applyTagsFor :: Traversal' OpenApi Operation -> [Tag] -> OpenApi -> OpenApi
applyTagsFor ops ts swag =
swag
& ops . tags %~ (<> InsOrdHS.fromList (map _tagName ts))
& tags %~ (<> InsOrdHS.fromList ts)
-- | Construct a 'Response' whose body, for the given media type, is the schema
-- derived from @a@, declaring any referenced schema definitions in the process.
-- The returned 'Response' has an empty description; set one with the 'description'
-- lens if your spec requires it.
--
-- >>> BSL.putStrLn $ encodePretty $ runDeclare (declareResponse "application/json" (Proxy :: Proxy Day)) mempty
-- [
-- {
-- "Day": {
-- "example": "2016-07-22",
-- "format": "date",
-- "type": "string"
-- }
-- },
-- {
-- "content": {
-- "application/json": {
-- "schema": {
-- "$ref": "#/components/schemas/Day"
-- }
-- }
-- },
-- "description": ""
-- }
-- ]
declareResponse :: (ToSchema a) => MediaType -> Proxy a -> Declare (Definitions Schema) Response
declareResponse cType proxy = do
s <- declareSchemaRef proxy
return (mempty & content . at cType ?~ (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 :: OpenApi) & paths .~ IOHM.fromList [("/user", mempty & get ?~ mempty)]
-- >>> let res = declareResponse "application/json" (Proxy :: Proxy Day)
-- >>> BSL.putStrLn $ encodePretty $ api & setResponse 200 res
-- {
-- "components": {
-- "schemas": {
-- "Day": {
-- "example": "2016-07-22",
-- "format": "date",
-- "type": "string"
-- }
-- }
-- },
-- "info": {
-- "title": "",
-- "version": ""
-- },
-- "openapi": "3.1.0",
-- "paths": {
-- "/user": {
-- "get": {
-- "responses": {
-- "200": {
-- "content": {
-- "application/json": {
-- "schema": {
-- "$ref": "#/components/schemas/Day"
-- }
-- }
-- },
-- "description": ""
-- }
-- }
-- }
-- }
-- }
-- }
--
-- See also @'setResponseWith'@.
setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi
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 -> OpenApi -> OpenApi
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' OpenApi Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi
setResponseFor ops code dres swag =
swag
& components . schemas %~ (<> 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' OpenApi Operation -> (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi
setResponseForWith ops f code dres swag =
swag
& components . schemas %~ (<> defs)
& ops . at code %~ Just . Inline . combine
where
(defs, new) = runDeclare dres mempty
combine (Just (Ref (Reference n))) = case swag ^. components . responses . at n 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