Add Data.Swagger.Operation with a few helpers

src/Data/Swagger.hs

@@ -159,7 +159,7 @@ import Data.Swagger.Internal
 -- $lens
 --
 -- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used
--- to work comfortly with it. In combination with @'Monoid'@ instances, lenses
+-- to work comfortably with it. In combination with @'Monoid'@ instances, lenses
 -- make it fairly simple to construct/modify any part of the specification:
 --
 -- >>> :{
@@ -173,13 +173,14 @@ import Data.Swagger.Internal
 -- :}
 -- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"User\":{\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}},\"produces\":[\"application/json\"]}}}}"
 --
--- In the snippet above we declare API with a single path @/user@ providing method @GET@
--- which produces @application/json@ output and should respond with code @200@ and body specified
+-- In the snippet above we declare an API with a single path @/user@. This path provides method @GET@
+-- which produces @application/json@ output. It should respond with code @200@ and body specified
 -- by schema @User@ which is defined in @'definitions'@ property of swagger specification.
+-- Alternatively it may respond with code @404@ meaning that user info is not found.
 --
 -- For convenience, @swagger2@ uses /classy field lenses/. It means that
 -- field accessor names can be overloaded for different types. One such
--- common field is @'description'@. Many components of Swagger specification
+-- common field is @'description'@. Many components of a Swagger specification
 -- can have descriptions, and you can use the same name for them:
 --
 -- >>> encode $ (mempty :: Response) & description .~ "No content"

src/Data/Swagger/Operation.hs

@@ -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
+

src/Data/Swagger/Schema/Validation.hs

@@ -77,7 +77,7 @@ import Data.Swagger.Internal.Schema.Validation
 -- >>> data Person = Person { name :: String, age :: Maybe Int } deriving Generic
 -- >>> instance ToJSON Person
 -- >>> instance ToSchema Person
--- >>> validateToJSON (Person "John" (Just 25))
+-- >>> validateToJSON (Person "Nick" (Just 24))
 -- []
--- >>> validateToJSON (Person "John" Nothing)
+-- >>> validateToJSON (Person "Nick" Nothing)
 -- []

swagger2.cabal

@@ -26,6 +26,7 @@ library
     Data.Swagger
     Data.Swagger.Declare
     Data.Swagger.Lens
+    Data.Swagger.Operation
     Data.Swagger.ParamSchema
     Data.Swagger.Schema
     Data.Swagger.Schema.Validation