{-# LANGUAGE RankNTypes #-}
-- |
-- Module:      Data.Swagger.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.Swagger.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.Swagger.Declare
import Data.Swagger.Internal
import Data.Swagger.Lens
import Data.Swagger.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

-- | 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 :: [Char] -> Swagger -> Swagger
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' Swagger Operation
allOperations :: Traversal' Swagger 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 :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]
-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
-- >>> encode api
-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
-- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found"
-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"},\"404\":{\"description\":\"Not found\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
operationsOf :: Swagger -> Traversal' Swagger Operation
operationsOf :: Swagger -> Traversal' Swagger Operation
operationsOf Swagger
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 (Swagger
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] -> Swagger -> Swagger
applyTags :: [Tag] -> Swagger -> Swagger
applyTags = Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
applyTagsFor Traversal' Swagger Operation
allOperations

-- | Apply tags to a part of Swagger spec and update the global
-- list of tags.
applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
applyTagsFor :: Traversal' Swagger Operation -> [Tag] -> Swagger -> Swagger
applyTagsFor Traversal' Swagger Operation
ops [Tag]
ts Swagger
swag = Swagger
swag
  forall a b. a -> (a -> b) -> b
& Traversal' Swagger 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.
--
-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty
-- "[{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}},{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}]"
declareResponse :: ToSchema a => Proxy a -> Declare (Definitions Schema) Response
declareResponse :: forall a.
ToSchema a =>
Proxy a -> Declare (Definitions Schema) Response
declareResponse 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. 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 :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
-- >>> let res = declareResponse (Proxy :: Proxy Day)
-- >>> encode $ api & setResponse 200 res
-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"description\":\"\",\"schema\":{\"$ref\":\"#/definitions/Day\"}}}}}},\"definitions\":{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}}}"
--
-- See also @'setResponseWith'@.
setResponse :: HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
setResponse :: Int -> Declare (Definitions Schema) Response -> Swagger -> Swagger
setResponse = Traversal' Swagger Operation
-> Int
-> Declare (Definitions Schema) Response
-> Swagger
-> Swagger
setResponseFor Traversal' Swagger 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 -> Swagger -> Swagger
setResponseWith :: (Response -> Response -> Response)
-> Int
-> Declare (Definitions Schema) Response
-> Swagger
-> Swagger
setResponseWith = Traversal' Swagger Operation
-> (Response -> Response -> Response)
-> Int
-> Declare (Definitions Schema) Response
-> Swagger
-> Swagger
setResponseForWith Traversal' Swagger 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' Swagger Operation -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
setResponseFor :: Traversal' Swagger Operation
-> Int
-> Declare (Definitions Schema) Response
-> Swagger
-> Swagger
setResponseFor Traversal' Swagger Operation
ops Int
code Declare (Definitions Schema) Response
dres Swagger
swag = Swagger
swag
  forall a b. a -> (a -> b) -> b
& forall s a. HasDefinitions s a => Lens' s a
definitions 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' Swagger 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' Swagger Operation -> (Response -> Response -> Response) -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
setResponseForWith :: Traversal' Swagger Operation
-> (Response -> Response -> Response)
-> Int
-> Declare (Definitions Schema) Response
-> Swagger
-> Swagger
setResponseForWith Traversal' Swagger Operation
ops Response -> Response -> Response
f Int
code Declare (Definitions Schema) Response
dres Swagger
swag = Swagger
swag
  forall a b. a -> (a -> b) -> b
& forall s a. HasDefinitions s a => Lens' s a
definitions 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' Swagger 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 Swagger
swag forall s a. s -> Getting a s a -> a
^. 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