{-# LANGUAGE RankNTypes #-}
-- |
-- Module:      Data.OpenApi.Operation
-- 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.OpenApi.Operation (
  -- * Operation traversals
  allOperations,
  operationsOf,

  -- * Manipulation
  -- ** Tags
  applyTags,
  applyTagsFor,

  -- ** Responses
  setResponse,
  setResponseWith,
  setResponseFor,
  setResponseForWith,

  -- ** Paths
  prependPath,

  -- * Miscellaneous
  declareResponse,
) where

import Prelude ()
import Prelude.Compat

import Control.Lens
import Data.Data.Lens
import Data.List.Compat
import Data.Maybe (mapMaybe)
import Data.Proxy
import qualified Data.Set as Set
import Data.Text (Text)
import Network.HTTP.Media (MediaType)

import Data.OpenApi.Declare
import Data.OpenApi.Internal
import Data.OpenApi.Lens
import Data.OpenApi.Schema

import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
import qualified Data.HashSet.InsOrd as InsOrdHS

-- $setup
-- >>> import Data.Aeson
-- >>> import Data.Proxy
-- >>> import Data.Time
-- >>> import qualified Data.ByteString.Lazy.Char8 as BSL
-- >>> import qualified Data.HashMap.Strict.InsOrd 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 :: [Char] -> OpenApi -> OpenApi
prependPath [Char]
path = forall s a. HasPaths s a => Lens' s a
paths forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall k' k v.
(Eq k', Hashable k') =>
(k -> k') -> InsOrdHashMap k v -> InsOrdHashMap k' v
InsOrdHashMap.mapKeys ([Char]
path [Char] -> [Char] -> [Char]
</>)
  where
    [Char]
x </> :: [Char] -> [Char] -> [Char]
</> [Char]
y = case [Char] -> [Char]
trim [Char]
y of
      [Char]
"" -> [Char]
"/" forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
trim [Char]
x
      [Char]
y' -> [Char]
"/" forall a. Semigroup a => a -> a -> a
<> [Char] -> [Char]
trim [Char]
x forall a. Semigroup a => a -> a -> a
<> [Char]
"/" forall a. Semigroup a => a -> a -> a
<> [Char]
y'

    trim :: [Char] -> [Char]
trim = forall a. (a -> Bool) -> [a] -> [a]
dropWhile (forall a. Eq a => a -> a -> Bool
== Char
'/') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> Bool) -> [a] -> [a]
dropWhileEnd (forall a. Eq a => a -> a -> Bool
== Char
'/')

-- | All operations of a Swagger spec.
allOperations :: Traversal' OpenApi Operation
allOperations :: Traversal' OpenApi Operation
allOperations = forall s a. HasPaths s a => Lens' s a
pathsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverseforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (Data s, Typeable a) => Traversal' s a
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.0.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.0.0",
--     "paths": {
--         "/user": {
--             "get": {
--                 "responses": {
--                     "200": {
--                         "description": "OK"
--                     },
--                     "404": {
--                         "description": "Not found"
--                     }
--                 }
--             },
--             "post": {
--                 "responses": {
--                     "200": {
--                         "description": "OK"
--                     }
--                 }
--             }
--         }
--     }
-- }
operationsOf :: OpenApi -> Traversal' OpenApi Operation
operationsOf :: OpenApi -> Traversal' OpenApi Operation
operationsOf OpenApi
sub = forall s a. HasPaths s a => Lens' s a
pathsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall i (t :: * -> *) a b.
TraversableWithIndex i t =>
IndexedTraversal i (t a) (t b) a b
itraversedforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall i (p :: * -> * -> *) (f :: * -> *) s j t.
(Indexable i p, Functor f) =>
p (i, s) (f (j, t)) -> Indexed i s (f t)
withIndexforall b c a. (b -> c) -> (a -> b) -> a -> c
.Traversal' ([Char], PathItem) Operation
subops
  where
    -- | Traverse operations that correspond to paths and methods of the sub API.
    subops :: Traversal' (FilePath, PathItem) Operation
    subops :: Traversal' ([Char], PathItem) Operation
subops Operation -> f Operation
f ([Char]
path, PathItem
item) = case forall k v. (Eq k, Hashable k) => k -> InsOrdHashMap k v -> Maybe v
InsOrdHashMap.lookup [Char]
path (OpenApi
sub forall s a. s -> Getting a s a -> a
^. forall s a. HasPaths s a => Lens' s a
paths) of
      Just PathItem
subitem -> (,) [Char]
path forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PathItem -> Traversal' PathItem Operation
methodsOf PathItem
subitem Operation -> f Operation
f PathItem
item
      Maybe PathItem
Nothing      -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Char]
path, PathItem
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 -> Traversal' PathItem Operation
methodsOf PathItem
pathItem = forall (f :: * -> *) s t a.
Functor f =>
Traversing (->) f s t a a -> LensLike f s t [a] [a]
partsOf forall s a. (Data s, Typeable a) => Traversal' s a
template forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i (t :: * -> *) a b.
TraversableWithIndex i t =>
IndexedTraversal i (t a) (t b) a b
itraversed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall i (p :: * -> * -> *) (f :: * -> *) a.
(Indexable i p, Applicative f) =>
(i -> Bool) -> Optical' p (Indexed i) f a a
indices (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
ns) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. Prism (Maybe a) (Maybe b) a b
_Just
      where
        ops :: [Maybe Operation]
ops = PathItem
pathItem forall s a. s -> Getting (Endo [a]) s a -> [a]
^.. forall s a. (Data s, Typeable a) => Traversal' s a
template :: [Maybe Operation]
        ns :: [Int]
ns = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Maybe Operation]
ops

-- | Apply tags to all operations and update the global list of tags.
--
-- @
-- 'applyTags' = 'applyTagsFor' 'allOperations'
-- @
applyTags :: [Tag] -> OpenApi -> OpenApi
applyTags :: [Tag] -> OpenApi -> OpenApi
applyTags = Traversal' OpenApi Operation -> [Tag] -> OpenApi -> OpenApi
applyTagsFor Traversal' OpenApi Operation
allOperations

-- | Apply tags to a part of Swagger spec and update the global
-- list of tags.
applyTagsFor :: Traversal' OpenApi Operation -> [Tag] -> OpenApi -> OpenApi
applyTagsFor :: Traversal' OpenApi Operation -> [Tag] -> OpenApi -> OpenApi
applyTagsFor Traversal' OpenApi Operation
ops [Tag]
ts OpenApi
swag = OpenApi
swag
  forall a b. a -> (a -> b) -> b
& Traversal' OpenApi Operation
ops forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall s a. HasTags s a => Lens' s a
tags forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> forall k. (Eq k, Hashable k) => [k] -> InsOrdHashSet k
InsOrdHS.fromList (forall a b. (a -> b) -> [a] -> [b]
map Tag -> TagName
_tagName [Tag]
ts))
  forall a b. a -> (a -> b) -> b
& forall s a. HasTags s a => Lens' s a
tags forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> forall k. (Eq k, Hashable k) => [k] -> InsOrdHashSet k
InsOrdHS.fromList [Tag]
ts)

-- | Construct a response with @'Schema'@ while declaring all
-- necessary schema definitions.
--
-- FIXME doc
--
-- >>> 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 :: forall a.
ToSchema a =>
MediaType -> Proxy a -> Declare (Definitions Schema) Response
declareResponse MediaType
cType Proxy a
proxy = do
  Referenced Schema
s <- forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) (Referenced Schema)
declareSchemaRef Proxy a
proxy
  forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
& forall s a. HasContent s a => Lens' s a
contentforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at MediaType
cType forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ (forall a. Monoid a => a
mempty forall a b. a -> (a -> b) -> b
& forall s a. HasSchema s a => Lens' s a
schema forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ Referenced 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.0.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 :: Int -> Declare (Definitions Schema) Response -> OpenApi -> OpenApi
setResponse = Traversal' OpenApi Operation
-> Int
-> Declare (Definitions Schema) Response
-> OpenApi
-> OpenApi
setResponseFor Traversal' OpenApi Operation
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 :: (Response -> Response -> Response)
-> Int
-> Declare (Definitions Schema) Response
-> OpenApi
-> OpenApi
setResponseWith = Traversal' OpenApi Operation
-> (Response -> Response -> Response)
-> Int
-> Declare (Definitions Schema) Response
-> OpenApi
-> OpenApi
setResponseForWith Traversal' OpenApi Operation
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 :: Traversal' OpenApi Operation
-> Int
-> Declare (Definitions Schema) Response
-> OpenApi
-> OpenApi
setResponseFor Traversal' OpenApi Operation
ops Int
code Declare (Definitions Schema) Response
dres OpenApi
swag = OpenApi
swag
  forall a b. a -> (a -> b) -> b
& forall s a. HasComponents s a => Lens' s a
componentsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. HasSchemas s a => Lens' s a
schemas forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> Definitions Schema
defs)
  forall a b. a -> (a -> b) -> b
& Traversal' OpenApi Operation
ops forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Int
code forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ forall a. a -> Referenced a
Inline Response
res
  where
    (Definitions Schema
defs, Response
res) = forall d a. Declare d a -> d -> (d, a)
runDeclare Declare (Definitions Schema) Response
dres forall a. Monoid a => a
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 :: Traversal' OpenApi Operation
-> (Response -> Response -> Response)
-> Int
-> Declare (Definitions Schema) Response
-> OpenApi
-> OpenApi
setResponseForWith Traversal' OpenApi Operation
ops Response -> Response -> Response
f Int
code Declare (Definitions Schema) Response
dres OpenApi
swag = OpenApi
swag
  forall a b. a -> (a -> b) -> b
& forall s a. HasComponents s a => Lens' s a
componentsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. HasSchemas s a => Lens' s a
schemas forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ (forall a. Semigroup a => a -> a -> a
<> Definitions Schema
defs)
  forall a b. a -> (a -> b) -> b
& Traversal' OpenApi Operation
ops forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at Int
code forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Referenced a
Inline forall b c a. (b -> c) -> (a -> b) -> a -> c
. Maybe (Referenced Response) -> Response
combine
  where
    (Definitions Schema
defs, Response
new) = forall d a. Declare d a -> d -> (d, a)
runDeclare Declare (Definitions Schema) Response
dres forall a. Monoid a => a
mempty

    combine :: Maybe (Referenced Response) -> Response
combine (Just (Ref (Reference TagName
n))) = case OpenApi
swag forall s a. s -> Getting a s a -> a
^. forall s a. HasComponents s a => Lens' s a
componentsforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. HasResponses s a => Lens' s a
responsesforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall m. At m => Index m -> Lens' m (Maybe (IxValue m))
at TagName
n of
      Just Response
old -> Response -> Response -> Response
f Response
old Response
new
      Maybe Response
Nothing  -> Response
new -- response name can't be dereferenced, replacing with new response
    combine (Just (Inline Response
old)) = Response -> Response -> Response
f Response
old Response
new
    combine Maybe (Referenced Response)
Nothing = Response
new