packages feed

swagger2 2.4 → 2.5

raw patch · 11 files changed

+769/−24 lines, 11 filesdep +aeson-prettydep +optics-coredep +optics-thdep ~basedep ~insert-ordered-containers

Dependencies added: aeson-pretty, optics-core, optics-th

Dependency ranges changed: base, insert-ordered-containers

Files

CHANGELOG.md view
@@ -1,3 +1,16 @@+2.5+---++Highlights:+- Add instance for `TimeOfDay` (see [#196]( https://github.com/GetShopTV/swagger2/pull/196 ));+- Add support for [`optics`](https://hackage.haskell.org/package/optics) (see [#200]( https://github.com/GetShopTV/swagger2/pull/200 ));+- Slightly better validation errors (see [#195]( https://github.com/GetShopTV/swagger2/pull/195 ));++Fixes and minor changes:+- Minor cleanup (see [#194]( https://github.com/GetShopTV/swagger2/pull/194 ));+- Allow base-4.13 and other GHC-8.8 related stuff (see [#198]( https://github.com/GetShopTV/swagger2/pull/198 ));+- Fix `stack.yaml` (see [#201]( https://github.com/GetShopTV/swagger2/pull/201 ));+ 2.4 ---
src/Data/Swagger.hs view
@@ -31,6 +31,7 @@    -- * Re-exports   module Data.Swagger.Lens,+  module Data.Swagger.Optics,   module Data.Swagger.Operation,   module Data.Swagger.ParamSchema,   module Data.Swagger.Schema,@@ -112,6 +113,7 @@ ) where  import Data.Swagger.Lens+import Data.Swagger.Optics () import Data.Swagger.Operation import Data.Swagger.ParamSchema import Data.Swagger.Schema@@ -174,6 +176,8 @@ -- @  -- $lens+--+-- Note: if you're working with the <https://hackage.haskell.org/package/optics optics> library, take a look at "Data.Swagger.Optics". -- -- Since @'Swagger'@ has a fairly complex structure, lenses and prisms are used -- to work comfortably with it. In combination with @'Monoid'@ instances, lenses
src/Data/Swagger/Internal/ParamSchema.hs view
@@ -194,6 +194,12 @@   toParamSchema _ = timeParamSchema "date"  -- |+-- >>> toParamSchema (Proxy :: Proxy TimeOfDay) ^. format+-- Just "hh:MM:ss"+instance ToParamSchema TimeOfDay where+  toParamSchema _ = timeParamSchema "hh:MM:ss"++-- | -- >>> toParamSchema (Proxy :: Proxy LocalTime) ^. format -- Just "yyyy-mm-ddThh:MM:ss" instance ToParamSchema LocalTime where
src/Data/Swagger/Internal/Schema.hs view
@@ -147,6 +147,10 @@     Proxy a -> Declare (Definitions Schema) NamedSchema   declareNamedSchema = genericDeclareNamedSchema defaultSchemaOptions +instance ToSchema TimeOfDay where+  declareNamedSchema _ = pure $ named "TimeOfDay" $ timeSchema "hh:MM:ss"+    & example ?~ toJSON (TimeOfDay 12 33 15)+ -- | Convert a type into a schema and declare all used schema definitions. declareSchema :: ToSchema a => Proxy a -> Declare (Definitions Schema) Schema declareSchema = fmap _namedSchemaSchema . declareNamedSchema
src/Data/Swagger/Internal/Schema/Validation.hs view
@@ -22,23 +22,27 @@ -- Validate JSON values with Swagger Schema. module Data.Swagger.Internal.Schema.Validation where +import           Prelude ()+import           Prelude.Compat+ import           Control.Applicative import           Control.Lens import           Control.Monad                       (when)  import           Data.Aeson                          hiding (Result)+import           Data.Aeson.Encode.Pretty            (encodePretty) import           Data.Foldable                       (for_, sequenceA_,                                                       traverse_) import           Data.HashMap.Strict                 (HashMap) import qualified Data.HashMap.Strict                 as HashMap import qualified Data.HashMap.Strict.InsOrd          as InsOrdHashMap import qualified "unordered-containers" Data.HashSet as HashSet-import           Data.List                           (intercalate)-import           Data.Monoid import           Data.Proxy import           Data.Scientific                     (Scientific, isInteger) import           Data.Text                           (Text) import qualified Data.Text                           as Text+import qualified Data.Text.Lazy                      as TL+import qualified Data.Text.Lazy.Encoding             as TL import           Data.Vector                         (Vector) import qualified Data.Vector                         as Vector @@ -54,18 +58,101 @@ -- -- /NOTE:/ @'validateToJSON'@ does not perform string pattern validation. -- See @'validateToJSONWithPatternChecker'@.+--+-- See 'renderValidationErrors' on how the output is structured.+validatePrettyToJSON :: forall a. (ToJSON a, ToSchema a) => a -> Maybe String+validatePrettyToJSON = renderValidationErrors validateToJSON++-- | Variant of 'validatePrettyToJSON' with typed output. validateToJSON :: forall a. (ToJSON a, ToSchema a) => a -> [ValidationError] validateToJSON = validateToJSONWithPatternChecker (\_pattern _str -> True)  -- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value and pattern checker. -- This can be used with QuickCheck to ensure those instances are coherent. ----- For validation without patterns see @'validateToJSON'@.+-- For validation without patterns see @'validateToJSON'@.  See also:+-- 'renderValidationErrors'. validateToJSONWithPatternChecker :: forall a. (ToJSON a, ToSchema a) => (Pattern -> Text -> Bool) -> a -> [ValidationError] validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checker defs sch . toJSON   where     (defs, sch) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty +-- | Pretty print validation errors+-- together with actual JSON and Swagger Schema+-- (using 'encodePretty').+--+-- >>> import Data.Aeson as Aeson+-- >>> import Data.Foldable (traverse_)+-- >>> import GHC.Generics+-- >>> data Phone = Phone { value :: String } deriving (Generic)+-- >>> data Person = Person { name :: String, phone :: Phone } deriving (Generic)+-- >>> instance ToJSON Person where toJSON p = object [ "name" Aeson..= name p ]+-- >>> instance ToSchema Phone+-- >>> instance ToSchema Person+-- >>> let person = Person { name = "John", phone = Phone "123456" }+-- >>> traverse_ putStrLn $ renderValidationErrors validateToJSON person+-- Validation against the schema fails:+--   * property "phone" is required, but not found in "{\"name\":\"John\"}"+-- <BLANKLINE>+-- JSON value:+-- {+--     "name": "John"+-- }+-- <BLANKLINE>+-- Swagger Schema:+-- {+--     "required": [+--         "name",+--         "phone"+--     ],+--     "type": "object",+--     "properties": {+--         "phone": {+--             "$ref": "#/definitions/Phone"+--         },+--         "name": {+--             "type": "string"+--         }+--     }+-- }+-- <BLANKLINE>+-- Swagger Description Context:+-- {+--     "Phone": {+--         "required": [+--             "value"+--         ],+--         "type": "object",+--         "properties": {+--             "value": {+--                 "type": "string"+--             }+--         }+--     }+-- }+-- <BLANKLINE>+renderValidationErrors+  :: forall a. (ToJSON a, ToSchema a)+  => (a -> [ValidationError]) -> a -> Maybe String+renderValidationErrors f x =+  case f x of+    []      -> Nothing+    errors  -> Just $ unlines+      [ "Validation against the schema fails:"+      , unlines (map ("  * " ++) errors)+      , "JSON value:"+      , ppJSONString (toJSON x)+      , ""+      , "Swagger Schema:"+      , ppJSONString (toJSON schema_)+      , ""+      , "Swagger Description Context:"+      , ppJSONString (toJSON refs_)+      ]+  where+    ppJSONString = TL.unpack . TL.decodeUtf8 . encodePretty+    (refs_, schema_) = runDeclare (declareSchema (Proxy :: Proxy a)) mempty+ -- | Validate JSON @'Value'@ against Swagger @'Schema'@. -- -- prop> validateJSON mempty (toSchema (Proxy :: Proxy Int)) (toJSON (x :: Int)) == []@@ -397,7 +484,7 @@     (Nothing, String s)               -> sub_ paramSchema (validateString s)     (Nothing, Array xs)               -> sub_ paramSchema (validateArray xs)     (Nothing, Object o)               -> validateObject o-    param@(t, _) -> invalid $ "expected JSON value of type " ++ showType param+    bad -> invalid $ "expected JSON value of type " ++ showType bad  validateParamSchemaType :: Value -> Validation (ParamSchema t) () validateParamSchemaType value = withSchema $ \sch ->@@ -412,8 +499,7 @@     (Nothing, Number n)               -> validateNumber n     (Nothing, String s)               -> validateString s     (Nothing, Array xs)               -> validateArray xs-    (t, _) -> invalid $ "expected JSON value of type " ++ show t-    param@(t, _) -> invalid $ "expected JSON value of type " ++ showType param+    bad -> invalid $ "expected JSON value of type " ++ showType bad  showType :: (Maybe (SwaggerType t), Value) -> String showType (Just type_, _)     = show type_
+ src/Data/Swagger/Optics.hs view
@@ -0,0 +1,597 @@+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedLabels #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TypeFamilies #-}+{-# LANGUAGE UndecidableInstances #-}+{-# OPTIONS_GHC -fno-warn-orphans #-}+-- |+-- Module:      Data.Swagger.Optics+-- Maintainer:  Andrzej Rybczak <andrzej@rybczak.net>+-- Stability:   experimental+--+-- Lenses and prisms for the <https://hackage.haskell.org/package/optics optics>+-- library.+--+-- >>> import Data.Aeson+-- >>> import Optics.Core+-- >>> :set -XOverloadedLabels+--+-- Example from the "Data.Swagger" module using @optics@:+--+-- >>> :{+-- encode $ (mempty :: Swagger)+--   & #definitions .~ [ ("User", mempty & #type ?~ SwaggerString) ]+--   & #paths .~+--     [ ("/user", mempty & #get ?~ (mempty+--         & #produces ?~ MimeList ["application/json"]+--         & at 200 ?~ ("OK" & #_Inline % #schema ?~ Ref (Reference "User"))+--         & at 404 ?~ "User info not found")) ]+-- :}+-- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"404\":{\"description\":\"User info not found\"},\"200\":{\"schema\":{\"$ref\":\"#/definitions/User\"},\"description\":\"OK\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}"+--+-- For convenience optics are defined as /labels/. It means that field accessor+-- names can be overloaded for different types. One such 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"+-- "{\"description\":\"No content\"}"+-- >>> :{+-- encode $ (mempty :: Schema)+--   & #type        ?~ SwaggerBoolean+--   & #description ?~ "To be or not to be"+-- :}+-- "{\"description\":\"To be or not to be\",\"type\":\"boolean\"}"+--+-- @'ParamSchema'@ is basically the /base schema specification/ and many types+-- contain it. So for convenience, all @'ParamSchema'@ fields are transitively+-- made fields of the type that has it. For example, you can use @#type@ to+-- access @'SwaggerType'@ of @'Header'@ schema without having to use+-- @#paramSchema@:+--+-- >>> encode $ (mempty :: Header) & #type ?~ SwaggerNumber+-- "{\"type\":\"number\"}"+--+-- Additionally, to simplify working with @'Response'@, both @'Operation'@ and+-- @'Responses'@ have direct access to it via @'Optics.Core.At.at'@. Example:+--+-- >>> :{+-- encode $ (mempty :: Operation)+--   & at 404 ?~ "Not found"+-- :}+-- "{\"responses\":{\"404\":{\"description\":\"Not found\"}}}"+--+module Data.Swagger.Optics () where++import Data.Aeson (Value)+import Data.Scientific (Scientific)+import Data.Swagger.Internal+import Data.Text (Text)+import Optics.Core+import Optics.TH++-- Lenses++makeFieldLabels ''Swagger+makeFieldLabels ''Host+makeFieldLabels ''Info+makeFieldLabels ''Contact+makeFieldLabels ''License+makeFieldLabels ''PathItem+makeFieldLabels ''Tag+makeFieldLabels ''Operation+makeFieldLabels ''Param+makeFieldLabels ''ParamOtherSchema+makeFieldLabels ''Header+makeFieldLabels ''Schema+makeFieldLabels ''NamedSchema+makeFieldLabels ''ParamSchema+makeFieldLabels ''Xml+makeFieldLabels ''Responses+makeFieldLabels ''Response+makeFieldLabels ''SecurityScheme+makeFieldLabels ''ApiKeyParams+makeFieldLabels ''OAuth2Params+makeFieldLabels ''ExternalDocs++-- Prisms++makePrismLabels ''ParamAnySchema+makePrismLabels ''SecuritySchemeType+makePrismLabels ''Referenced++-- SwaggerItems prisms++instance+  ( a ~ [Referenced Schema]+  , b ~ [Referenced Schema]+  ) => LabelOptic "_SwaggerItemsArray"+         A_Review+         (SwaggerItems 'SwaggerKindSchema)+         (SwaggerItems 'SwaggerKindSchema)+         a+         b where+  labelOptic = unto (\x -> SwaggerItemsArray x)+  {-# INLINE labelOptic #-}++instance+  ( a ~ Referenced Schema+  , b ~ Referenced Schema+  ) => LabelOptic "_SwaggerItemsObject"+         A_Review+         (SwaggerItems 'SwaggerKindSchema)+         (SwaggerItems 'SwaggerKindSchema)+         a+         b where+  labelOptic = unto (\x -> SwaggerItemsObject x)+  {-# INLINE labelOptic #-}++instance+  ( a ~ (Maybe (CollectionFormat t), ParamSchema t)+  , b ~ (Maybe (CollectionFormat t), ParamSchema t)+  ) => LabelOptic "_SwaggerItemsPrimitive"+         A_Review+         (SwaggerItems t)+         (SwaggerItems t)+         a+         b where+  labelOptic = unto (\(c, p) -> SwaggerItemsPrimitive c p)+  {-# INLINE labelOptic #-}++-- =============================================================+-- More helpful instances for easier access to schema properties++type instance Index Responses = HttpStatusCode+type instance Index Operation = HttpStatusCode++type instance IxValue Responses = Referenced Response+type instance IxValue Operation = Referenced Response++instance Ixed Responses where+  ix n = #responses % ix n+  {-# INLINE ix #-}+instance At   Responses where+  at n = #responses % at n+  {-# INLINE at #-}++instance Ixed Operation where+  ix n = #responses % ix n+  {-# INLINE ix #-}+instance At   Operation where+  at n = #responses % at n+  {-# INLINE at #-}++-- #paramSchema++instance+  ( a ~ ParamSchema 'SwaggerKindSchema+  , b ~ ParamSchema 'SwaggerKindSchema+  ) => LabelOptic "paramSchema" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #schema % #paramSchema+  {-# INLINE labelOptic #-}++-- #type++instance+  ( a ~ Maybe (SwaggerType ('SwaggerKindNormal Header))+  , b ~ Maybe (SwaggerType ('SwaggerKindNormal Header))+  ) => LabelOptic "type" A_Lens Header Header a b where+  labelOptic = #paramSchema % #type+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)+  , b ~ Maybe (SwaggerType 'SwaggerKindSchema)+  ) => LabelOptic "type" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #type+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe (SwaggerType 'SwaggerKindSchema)+  , b ~ Maybe (SwaggerType 'SwaggerKindSchema)+  ) => LabelOptic "type" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #type+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)+  , b ~ Maybe (SwaggerType 'SwaggerKindParamOtherSchema)+  ) => LabelOptic "type" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #type+  {-# INLINE labelOptic #-}++-- #default++instance+  ( a ~ Maybe Value, b ~ Maybe Value+  ) => LabelOptic "default" A_Lens Header Header a b where+  labelOptic = #paramSchema % #default+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Value, b ~ Maybe Value+  ) => LabelOptic "default" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #default+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Value, b ~ Maybe Value+  ) => LabelOptic "default" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #default+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Value, b ~ Maybe Value+  ) => LabelOptic "default" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #default+  {-# INLINE labelOptic #-}++-- #format++instance+  ( a ~ Maybe Format, b ~ Maybe Format+  ) => LabelOptic "format" A_Lens Header Header a b where+  labelOptic = #paramSchema % #format+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Format, b ~ Maybe Format+  ) => LabelOptic "format" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #format+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Format, b ~ Maybe Format+  ) => LabelOptic "format" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #format+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Format, b ~ Maybe Format+  ) => LabelOptic "format" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #format+  {-# INLINE labelOptic #-}++-- #items++instance+  ( a ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))+  , b ~ Maybe (SwaggerItems ('SwaggerKindNormal Header))+  ) => LabelOptic "items" A_Lens Header Header a b where+  labelOptic = #paramSchema % #items+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)+  , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)+  ) => LabelOptic "items" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #items+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe (SwaggerItems 'SwaggerKindSchema)+  , b ~ Maybe (SwaggerItems 'SwaggerKindSchema)+  ) => LabelOptic "items" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #items+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)+  , b ~ Maybe (SwaggerItems 'SwaggerKindParamOtherSchema)+  ) => LabelOptic "items" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #items+  {-# INLINE labelOptic #-}++-- #maximum++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "maximum" A_Lens Header Header a b where+  labelOptic = #paramSchema % #maximum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "maximum" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #maximum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "maximum" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #maximum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "maximum" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #maximum+  {-# INLINE labelOptic #-}++-- #exclusiveMaximum++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMaximum" A_Lens Header Header a b where+  labelOptic = #paramSchema % #exclusiveMaximum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMaximum" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #exclusiveMaximum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMaximum" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #exclusiveMaximum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMaximum" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #exclusiveMaximum+  {-# INLINE labelOptic #-}++-- #minimum++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "minimum" A_Lens Header Header a b where+  labelOptic = #paramSchema % #minimum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "minimum" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #minimum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "minimum" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #minimum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "minimum" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #minimum+  {-# INLINE labelOptic #-}++-- #exclusiveMinimum++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMinimum" A_Lens Header Header a b where+  labelOptic = #paramSchema % #exclusiveMinimum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMinimum" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #exclusiveMinimum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMinimum" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #exclusiveMinimum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "exclusiveMinimum" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #exclusiveMinimum+  {-# INLINE labelOptic #-}++-- #maxLength++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxLength" A_Lens Header Header a b where+  labelOptic = #paramSchema % #maxLength+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxLength" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #maxLength+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxLength" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #maxLength+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxLength" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #maxLength+  {-# INLINE labelOptic #-}++-- #minLength++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minLength" A_Lens Header Header a b where+  labelOptic = #paramSchema % #minLength+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minLength" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #minLength+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minLength" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #minLength+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minLength" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #minLength+  {-# INLINE labelOptic #-}++-- #pattern++instance+  ( a ~ Maybe Text, b ~ Maybe Text+  ) => LabelOptic "pattern" A_Lens Header Header a b where+  labelOptic = #paramSchema % #pattern+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Text, b ~ Maybe Text+  ) => LabelOptic "pattern" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #pattern+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Text, b ~ Maybe Text+  ) => LabelOptic "pattern" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #pattern+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Text, b ~ Maybe Text+  ) => LabelOptic "pattern" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #pattern+  {-# INLINE labelOptic #-}++-- #maxItems++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxItems" A_Lens Header Header a b where+  labelOptic = #paramSchema % #maxItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxItems" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #maxItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxItems" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #maxItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "maxItems" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #maxItems+  {-# INLINE labelOptic #-}++-- #minItems++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minItems" A_Lens Header Header a b where+  labelOptic = #paramSchema % #minItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minItems" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #minItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minItems" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #minItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Integer, b ~ Maybe Integer+  ) => LabelOptic "minItems" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #minItems+  {-# INLINE labelOptic #-}++-- #uniqueItems++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "uniqueItems" A_Lens Header Header a b where+  labelOptic = #paramSchema % #uniqueItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "uniqueItems" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #uniqueItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "uniqueItems" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #uniqueItems+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Bool, b ~ Maybe Bool+  ) => LabelOptic "uniqueItems" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #uniqueItems+  {-# INLINE labelOptic #-}++-- #enum++instance+  ( a ~ Maybe [Value], b ~ Maybe [Value]+  ) => LabelOptic "enum" A_Lens Header Header a b where+  labelOptic = #paramSchema % #enum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe [Value], b ~ Maybe [Value]+  ) => LabelOptic "enum" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #enum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe [Value], b ~ Maybe [Value]+  ) => LabelOptic "enum" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #enum+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe [Value], b ~ Maybe [Value]+  ) => LabelOptic "enum" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #enum+  {-# INLINE labelOptic #-}++-- #multipleOf++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "multipleOf" A_Lens Header Header a b where+  labelOptic = #paramSchema % #multipleOf+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "multipleOf" A_Lens Schema Schema a b where+  labelOptic = #paramSchema % #multipleOf+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "multipleOf" A_Lens NamedSchema NamedSchema a b where+  labelOptic = #paramSchema % #multipleOf+  {-# INLINE labelOptic #-}++instance+  ( a ~ Maybe Scientific, b ~ Maybe Scientific+  ) => LabelOptic "multipleOf" A_Lens ParamOtherSchema ParamOtherSchema a b where+  labelOptic = #paramSchema % #multipleOf+  {-# INLINE labelOptic #-}
src/Data/Swagger/Schema/Validation.hs view
@@ -19,8 +19,10 @@   ValidationError,    -- ** Using 'ToJSON' and 'ToSchema'+  validatePrettyToJSON,   validateToJSON,   validateToJSONWithPatternChecker,+  renderValidationErrors,    -- ** Using 'Value' and 'Schema'   validateJSON,
swagger2.cabal view
@@ -1,6 +1,6 @@ cabal-version:       >=1.10 name:                swagger2-version:             2.4+version:             2.5  synopsis:            Swagger 2.0 data model category:            Web, Swagger@@ -24,9 +24,7 @@   , examples/*.hs   , include/overlapping-compat.h tested-with:-  GHC ==7.8.4-   || ==7.10.3-   || ==8.0.2+  GHC ==8.0.2    || ==8.2.2    || ==8.4.4    || ==8.6.5@@ -44,6 +42,7 @@     Data.Swagger.Declare     Data.Swagger.Lens     Data.Swagger.Operation+    Data.Swagger.Optics     Data.Swagger.ParamSchema     Data.Swagger.Schema     Data.Swagger.Schema.Generator@@ -61,10 +60,11 @@    -- GHC boot libraries   build-depends:-      base             >=4.7      && <4.13+      base             >=4.9      && <4.14+    , aeson-pretty     >=0.8.7    && <0.9     , bytestring       >=0.10.4.0 && <0.11     , containers       >=0.5.5.1  && <0.7-    , template-haskell >=2.9.0.0  && <2.15+    , template-haskell >=2.9.0.0  && <2.16     , time             >=1.4.2    && <1.10     , transformers     >=0.3.0.0  && <0.6 @@ -74,16 +74,18 @@    -- other dependencies   build-depends:-      base-compat-batteries     >=0.10.4   && <0.11+      base-compat-batteries     >=0.10.4   && <0.12     , aeson                     >=1.4.2.0  && <1.5     -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint     , cookie                    >=0.4.3    && <0.5     , generics-sop              >=0.3.2.0  && <0.6     , hashable                  >=1.2.7.0  && <1.4     , http-media                >=0.7.1.2  && <0.9-    , insert-ordered-containers >=0.2.2    && <0.3-    , lens                      >=4.16.1   && <4.18+    , insert-ordered-containers >=0.2.3    && <0.3+    , lens                      >=4.16.1   && <4.19     , network                   >=2.6.3.5  && <3.2+    , optics-core               >=0.2      && <0.3+    , optics-th                 >=0.2      && <0.3     , scientific                >=0.3.6.2  && <0.4     , transformers-compat       >=0.3      && <0.7     , unordered-containers      >=0.2.9.0  && <0.3
test/Data/Swagger/CommonTestTypes.hs view
@@ -18,8 +18,6 @@ import           GHC.Generics  import           Data.Swagger-import           Data.Swagger.Declare-import           Data.Swagger.Internal (SwaggerKind (..))  -- ======================================================================== -- Unit type@@ -648,5 +646,34 @@     {       "singleMaybeField": { "type": "string" }     }+}+|]+++-- ========================================================================+-- TimeOfDay+-- ========================================================================+data TimeOfDay+  = Int+  | Pico+  deriving (Generic)+instance ToSchema TimeOfDay+instance ToParamSchema TimeOfDay+++timeOfDaySchemaJSON :: Value+timeOfDaySchemaJSON = [aesonQQ|+{+  "example": "12:33:15",+  "type": "string",+  "format": "hh:MM:ss"+}+|]++timeOfDayParamSchemaJSON :: Value+timeOfDayParamSchemaJSON = [aesonQQ|+{+  "type": "string",+  "format": "hh:MM:ss" } |]
test/Data/Swagger/ParamSchemaSpec.hs view
@@ -3,9 +3,10 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-}+{-# LANGUAGE OverloadedStrings #-} module Data.Swagger.ParamSchemaSpec where -import Data.Aeson (Value)+import Data.Aeson import Data.Aeson.QQ.Simple import Data.Char import Data.Proxy@@ -17,7 +18,10 @@ import Data.Swagger.CommonTestTypes import SpecCommon import Test.Hspec+import Data.Time.LocalTime +import qualified Data.HashMap.Strict as HM+ checkToParamSchema :: ToParamSchema a => Proxy a -> Value -> Spec checkToParamSchema proxy js = (toParamSchema proxy :: ParamSchema ('SwaggerKindNormal Param)) <=> js @@ -30,6 +34,7 @@     context "Unary records" $ do       context "Email (unary record)"  $ checkToParamSchema (Proxy :: Proxy Email)  emailSchemaJSON       context "UserId (non-record newtype)" $ checkToParamSchema (Proxy :: Proxy UserId) userIdSchemaJSON+    context "TimeOfDay" $ checkToParamSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDayParamSchemaJSON  main :: IO () main = hspec spec
test/Data/Swagger/SchemaSpec.hs view
@@ -8,16 +8,11 @@ import Prelude.Compat  import Control.Lens ((^.))-import Data.Aeson (Value, ToJSON(..), ToJSONKey(..))-import Data.Aeson.Types (toJSONKeyText)-import Data.Aeson.QQ.Simple-import Data.Char+import Data.Aeson (Value) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap import Data.Proxy import Data.Set (Set)-import Data.Map (Map) import qualified Data.Text as Text-import GHC.Generics  import Data.Swagger import Data.Swagger.Declare@@ -26,6 +21,9 @@ import SpecCommon import Test.Hspec +import qualified Data.HashMap.Strict as HM+import Data.Time.LocalTime+ checkToSchema :: ToSchema a => Proxy a -> Value -> Spec checkToSchema proxy js = toSchema proxy <=> js @@ -110,6 +108,7 @@     context "MyRoseTree' (inlineNonRecursiveSchemas)" $ checkInlinedRecSchema (Proxy :: Proxy MyRoseTree') myRoseTreeSchemaJSON'   describe "Bounded Enum key mapping" $ do     context "ButtonImages" $ checkToSchema (Proxy :: Proxy ButtonImages) buttonImagesSchemaJSON+    context "TimeOfDay" $ checkToSchema (Proxy :: Proxy Data.Time.LocalTime.TimeOfDay) timeOfDaySchemaJSON  main :: IO () main = hspec spec