@@ -0,0 +1,78 @@
1+{-# LANGUAGE RankNTypes #-}
2+module Data.Swagger.Operation where
3+
4+import Control.Lens
5+import Data.Data.Lens
6+
7+import qualified Data.HashMap.Strict as HashMap
8+import Data.Maybe (mapMaybe)
9+import Data.Monoid
10+import Data.Swagger.Declare
11+import Data.Swagger.Internal
12+import Data.Swagger.Lens
13+import Data.Swagger.Schema
14+
15+-- $setup
16+-- >>> import Data.Aeson
17+-- >>> import Data.Proxy
18+-- >>> import Data.Time
19+
20+-- | @'operationsOf' sub@ will traverse only those operations
21+-- that are present in @sub@. Note that @'Operation'@ is determined
22+-- by both path and method.
23+--
24+-- >>> let ok = (mempty :: Operation) & at 200 ?~ "OK"
25+-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ ok & post ?~ ok)]
26+-- >>> let sub = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
27+-- >>> encode api
28+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}"
29+-- >>> encode $ api & operationsOf sub . at 404 ?~ "Not found"
30+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}}}}}"
31+operationsOf :: Swagger -> Traversal' Swagger Operation
32+operationsOf sub = paths.itraversed.withIndex.subops
33+ where
34+ -- | Traverse operations that correspond to paths and methods of the sub API.
35+ subops :: Traversal' (FilePath, PathItem) Operation
36+ subops f (path, item) = case HashMap.lookup path (sub ^. paths) of
37+ Just subitem -> (,) path <$> methodsOf subitem f item
38+ Nothing -> pure (path, item)
39+
40+ -- | Traverse operations that exist in a given @'PathItem'@
41+ -- This is used to traverse only the operations that exist in sub API.
42+ methodsOf :: PathItem -> Traversal' PathItem Operation
43+ methodsOf pathItem = partsOf template . itraversed . indices (`elem` ns) . _Just
44+ where
45+ ops = pathItem ^.. template :: [Maybe Operation]
46+ ns = mapMaybe (fmap fst . sequenceA) $ zip [0..] ops
47+
48+-- | Apply tags to a part of Swagger spec and update the global
49+-- list of tags.
50+applyTagsFor :: Swagger -> [Tag] -> Swagger -> Swagger
51+applyTagsFor sub ts swag = swag
52+ & operationsOf sub . tags %~ (map _tagName ts ++)
53+ & tags %~ (ts ++)
54+
55+-- | Construct a response with @'Schema'@ while declaring all
56+-- necessary schema definitions.
57+--
58+-- >>> encode $ runDeclare (declareResponse (Proxy :: Proxy Day)) mempty
59+-- "[{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}]"
60+declareResponse :: ToSchema a => proxy a -> Declare (Definitions Schema) Response
61+declareResponse proxy = do
62+ s <- declareSchemaRef proxy
63+ return (mempty & schema ?~ s)
64+
65+-- | Set response for all operations of a subspec.
66+-- This will also update global schema definitions.
67+--
68+-- >>> let api = (mempty :: Swagger) & paths .~ [("/user", mempty & get ?~ mempty)]
69+-- >>> let res = declareResponse (Proxy :: Proxy Day)
70+-- >>> encode $ api & setResponseFor api 200 res
71+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"definitions\":{\"Day\":{\"format\":\"date\",\"type\":\"string\"}},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}}}"
72+setResponseFor :: Swagger -> HttpStatusCode -> Declare (Definitions Schema) Response -> Swagger -> Swagger
73+setResponseFor sub code dres swag = swag
74+ & definitions %~ (<> defs)
75+ & operationsOf sub . at code ?~ Inline res
76+ where
77+ (defs, res) = runDeclare dres mempty
78+