diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml new file mode 100644 index 00000000..a1929ede --- /dev/null +++ b/.github/workflows/ci.yml @@ -0,0 +1,41 @@ +name: ci +on: + push: + branches: + - master + pull_request: + +jobs: + cabal: + runs-on: ${{ matrix.os }} + strategy: + matrix: + ghc: ["8.6.5", "8.8.4", "8.10.4", "8.10.7"] + cabal: ["3.6.2.0"] + os: [ubuntu-latest, macOS-latest] + name: build and test (cabal) + steps: + - uses: actions/checkout@v2 + - name: Run Haskell + uses: haskell/actions/setup@v1 + with: + ghc-version: ${{ matrix.ghc }} + cabal-version: ${{ matrix.cabal }} + - run: | + cabal build --enable-tests && cabal test + + stack: + name: build and test (stack) + runs-on: ${{ matrix.os }} + strategy: + matrix: + os: [ubuntu-latest, macOS-latest] + steps: + - uses: actions/checkout@v2 + - uses: haskell/actions/setup@v1 + with: + ghc-version: "8.10.7" + enable-stack: true + stack-version: "latest" + - run: | + stack build && stack test diff --git a/.gitignore b/.gitignore index 4a277591..c2cab955 100644 --- a/.gitignore +++ b/.gitignore @@ -17,3 +17,4 @@ cabal.sandbox.config *.aux *.hp .stack-work/ +stack.yaml.lock diff --git a/.travis.yml b/.travis.yml deleted file mode 100644 index cf3170f4..00000000 --- a/.travis.yml +++ /dev/null @@ -1,155 +0,0 @@ -# This Travis job script has been generated by a script via -# -# haskell-ci '--branches' 'master' '--haddock-jobs=>=8.4' '--output' '.travis.yml' 'swagger2.cabal' -# -# To regenerate the script (for example after adjusting tested-with) run -# -# haskell-ci regenerate -# -# For more information, see https://github.com/haskell-CI/haskell-ci -# -# version: 0.10 -# -version: ~> 1.0 -language: c -os: linux -dist: xenial -git: - # whether to recursively clone submodules - submodules: false -branches: - only: - - master -cache: - directories: - - $HOME/.cabal/packages - - $HOME/.cabal/store - - $HOME/.hlint -before_cache: - - rm -fv $CABALHOME/packages/hackage.haskell.org/build-reports.log - # remove files that are regenerated by 'cabal update' - - rm -fv $CABALHOME/packages/hackage.haskell.org/00-index.* - - rm -fv $CABALHOME/packages/hackage.haskell.org/*.json - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.cache - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar - - rm -fv $CABALHOME/packages/hackage.haskell.org/01-index.tar.idx - - rm -rfv $CABALHOME/packages/head.hackage -jobs: - include: - - compiler: ghc-8.10.1 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.10.1","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.8.1 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.8.1","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.6.5 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.6.5","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.4.4 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.4.4","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.2.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.2.2","cabal-install-3.2"]}} - os: linux - - compiler: ghc-8.0.2 - addons: {"apt":{"sources":[{"sourceline":"deb http://ppa.launchpad.net/hvr/ghc/ubuntu xenial main","key_url":"https://keyserver.ubuntu.com/pks/lookup?op=get&search=0x063dab2bdc0b3f9fcebc378bff3aeacef6f88286"}],"packages":["ghc-8.0.2","cabal-install-3.2"]}} - os: linux -before_install: - - HC=$(echo "/opt/$CC/bin/ghc" | sed 's/-/\//') - - WITHCOMPILER="-w $HC" - - HADDOCK=$(echo "/opt/$CC/bin/haddock" | sed 's/-/\//') - - HCPKG="$HC-pkg" - - unset CC - - CABAL=/opt/ghc/bin/cabal - - CABALHOME=$HOME/.cabal - - export PATH="$CABALHOME/bin:$PATH" - - TOP=$(pwd) - - "HCNUMVER=$(${HC} --numeric-version|perl -ne '/^(\\d+)\\.(\\d+)\\.(\\d+)(\\.(\\d+))?$/; print(10000 * $1 + 100 * $2 + ($3 == 0 ? $5 != 1 : $3))')" - - echo $HCNUMVER - - CABAL="$CABAL -vnormal+nowrap" - - set -o pipefail - - TEST=--enable-tests - - BENCH=--enable-benchmarks - - HEADHACKAGE=false - - rm -f $CABALHOME/config - - | - echo "verbose: normal +nowrap +markoutput" >> $CABALHOME/config - echo "remote-build-reporting: anonymous" >> $CABALHOME/config - echo "write-ghc-environment-files: always" >> $CABALHOME/config - echo "remote-repo-cache: $CABALHOME/packages" >> $CABALHOME/config - echo "logs-dir: $CABALHOME/logs" >> $CABALHOME/config - echo "world-file: $CABALHOME/world" >> $CABALHOME/config - echo "extra-prog-path: $CABALHOME/bin" >> $CABALHOME/config - echo "symlink-bindir: $CABALHOME/bin" >> $CABALHOME/config - echo "installdir: $CABALHOME/bin" >> $CABALHOME/config - echo "build-summary: $CABALHOME/logs/build.log" >> $CABALHOME/config - echo "store-dir: $CABALHOME/store" >> $CABALHOME/config - echo "install-dirs user" >> $CABALHOME/config - echo " prefix: $CABALHOME" >> $CABALHOME/config - echo "repository hackage.haskell.org" >> $CABALHOME/config - echo " url: http://hackage.haskell.org/" >> $CABALHOME/config -install: - - ${CABAL} --version - - echo "$(${HC} --version) [$(${HC} --print-project-git-commit-id 2> /dev/null || echo '?')]" - - | - echo "program-default-options" >> $CABALHOME/config - echo " ghc-options: $GHCJOBS +RTS -M6G -RTS" >> $CABALHOME/config - - cat $CABALHOME/config - - rm -fv cabal.project cabal.project.local cabal.project.freeze - - travis_retry ${CABAL} v2-update -v - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: ." >> cabal.project - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package swagger2' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" - - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(swagger2)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - - if [ -f "./configure.ac" ]; then (cd "." && autoreconf -i); fi - - ${CABAL} v2-freeze $WITHCOMPILER ${TEST} ${BENCH} - - "cat cabal.project.freeze | sed -E 's/^(constraints: *| *)//' | sed 's/any.//'" - - rm cabal.project.freeze - - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} --dep -j2 all - - travis_wait 40 ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks --dep -j2 all -script: - - DISTDIR=$(mktemp -d /tmp/dist-test.XXXX) - # Packaging... - - ${CABAL} v2-sdist all - # Unpacking... - - mv dist-newstyle/sdist/*.tar.gz ${DISTDIR}/ - - cd ${DISTDIR} || false - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec tar -xvf '{}' \; - - find . -maxdepth 1 -type f -name '*.tar.gz' -exec rm '{}' \; - - PKGDIR_swagger2="$(find . -maxdepth 1 -type d -regex '.*/swagger2-[0-9.]*')" - # Generate cabal.project - - rm -rf cabal.project cabal.project.local cabal.project.freeze - - touch cabal.project - - | - echo "packages: ${PKGDIR_swagger2}" >> cabal.project - - if [ $HCNUMVER -ge 80200 ] ; then echo 'package swagger2' >> cabal.project ; fi - - "if [ $HCNUMVER -ge 80200 ] ; then echo ' ghc-options: -Werror=missing-methods' >> cabal.project ; fi" - - | - - "for pkg in $($HCPKG list --simple-output); do echo $pkg | sed 's/-[^-]*$//' | (grep -vE -- '^(swagger2)$' || true) | sed 's/^/constraints: /' | sed 's/$/ installed/' >> cabal.project.local; done" - - cat cabal.project || true - - cat cabal.project.local || true - # Building... - # this builds all libraries and executables (without tests/benchmarks) - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all - # Building with tests and benchmarks... - # build & run tests, build benchmarks - - ${CABAL} v2-build $WITHCOMPILER ${TEST} ${BENCH} all - # Testing... - - ${CABAL} v2-test $WITHCOMPILER ${TEST} ${BENCH} all - # cabal check... - - (cd ${PKGDIR_swagger2} && ${CABAL} -vnormal check) - # haddock... - - if [ $HCNUMVER -ge 80400 ] ; then ${CABAL} v2-haddock $WITHCOMPILER --with-haddock $HADDOCK ${TEST} ${BENCH} all ; fi - # Building without installed constraints for packages in global-db... - - rm -f cabal.project.local - - ${CABAL} v2-build $WITHCOMPILER --disable-tests --disable-benchmarks all - -# REGENDATA ("0.10",["--branches","master","--haddock-jobs=>=8.4","--output",".travis.yml","swagger2.cabal"]) -# EOF diff --git a/src/Data/Swagger.hs b/src/Data/Swagger.hs index 2ea7facb..b2bb4aea 100644 --- a/src/Data/Swagger.hs +++ b/src/Data/Swagger.hs @@ -144,7 +144,7 @@ import Data.Swagger.Internal -- In this library you can use @'mempty'@ for a default/empty value. For instance: -- -- >>> encode (mempty :: Swagger) --- "{\"swagger\":\"2.0\",\"info\":{\"version\":\"\",\"title\":\"\"}}" +-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"}}" -- -- As you can see some spec properties (e.g. @"version"@) are there even when the spec is empty. -- That is because these properties are actually required ones. @@ -153,12 +153,12 @@ import Data.Swagger.Internal -- although it is not strictly necessary: -- -- >>> encode mempty { _infoTitle = "Todo API", _infoVersion = "1.0" } --- "{\"version\":\"1.0\",\"title\":\"Todo API\"}" +-- "{\"title\":\"Todo API\",\"version\":\"1.0\"}" -- -- You can merge two values using @'mappend'@ or its infix version @('<>')@: -- -- >>> encode $ mempty { _infoTitle = "Todo API" } <> mempty { _infoVersion = "1.0" } --- "{\"version\":\"1.0\",\"title\":\"Todo API\"}" +-- "{\"title\":\"Todo API\",\"version\":\"1.0\"}" -- -- This can be useful for combining specifications of endpoints into a whole API specification: -- @@ -192,7 +192,7 @@ import Data.Swagger.Internal -- & 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\"}}}" +-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"200\":{\"description\":\"OK\",\"schema\":{\"$ref\":\"#/definitions/User\"}},\"404\":{\"description\":\"User info not found\"}}}}},\"definitions\":{\"User\":{\"type\":\"string\"}}}" -- -- 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 diff --git a/src/Data/Swagger/Internal.hs b/src/Data/Swagger/Internal.hs index aba43653..4df508a8 100644 --- a/src/Data/Swagger/Internal.hs +++ b/src/Data/Swagger/Internal.hs @@ -42,6 +42,7 @@ import Text.Read (readMaybe) import Data.HashMap.Strict.InsOrd (InsOrdHashMap) import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap +import qualified Data.Aeson.KeyMap as KM import Generics.SOP.TH (deriveGeneric) import Data.Swagger.Internal.AesonUtils (sopSwaggerGenericToJSON @@ -1302,7 +1303,7 @@ instance FromJSON ParamOtherSchema where instance FromJSON Responses where parseJSON (Object o) = Responses <$> o .:? "default" - <*> (parseJSON (Object (HashMap.delete "default" o))) + <*> parseJSON (Object (KM.delete "default" o)) parseJSON _ = empty instance FromJSON Example where diff --git a/src/Data/Swagger/Internal/AesonUtils.hs b/src/Data/Swagger/Internal/AesonUtils.hs index 984da777..196ce731 100644 --- a/src/Data/Swagger/Internal/AesonUtils.hs +++ b/src/Data/Swagger/Internal/AesonUtils.hs @@ -25,10 +25,17 @@ import Prelude () import Prelude.Compat import Control.Applicative ((<|>)) -import Control.Lens (makeLenses, (^.)) -import Control.Monad (unless) -import Data.Aeson (ToJSON(..), FromJSON(..), Value(..), Object, object, (.:), (.:?), (.!=), withObject) +import Control.Lens (makeLenses, (^.)) +import Control.Monad (unless) +import Data.Aeson ( Encoding, FromJSON (..), ToJSON (..) + , Object, Series, Value (..) + , object, pairs, withObject + , (.!=), (.:), (.:?), (.=) + ) +import Data.Aeson.Key (fromString, toString, fromText, toText) +import qualified Data.Aeson.KeyMap as KM import Data.Aeson.Types (Parser, Pair) +import Data.Bifunctor (first) import Data.Char (toLower, isUpper) import Data.Foldable (traverse_) import Data.Text (Text) @@ -41,8 +48,6 @@ import qualified Data.Set as Set import qualified Data.HashMap.Strict.InsOrd as InsOrd import qualified Data.HashSet.InsOrd as InsOrdHS -import Data.Aeson (Encoding, pairs, (.=), Series) - ------------------------------------------------------------------------------- -- SwaggerAesonOptions ------------------------------------------------------------------------------- @@ -105,7 +110,7 @@ sopSwaggerGenericToJSON -> Value sopSwaggerGenericToJSON x = let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy) - in object (opts ^. saoAdditionalPairs ++ ps) + in object $ (map $ first fromText) (opts ^. saoAdditionalPairs ++ (map $ first toText) ps) where proxy = Proxy :: Proxy a opts = swaggerAesonOptions proxy @@ -127,7 +132,7 @@ sopSwaggerGenericToJSONWithOpts -> Value sopSwaggerGenericToJSONWithOpts opts x = let ps = sopSwaggerGenericToJSON' opts (from x) (datatypeInfo proxy) defs - in object (opts ^. saoAdditionalPairs ++ ps) + in object $ (map $ first fromText) (opts ^. saoAdditionalPairs ++ (map $ first toText) ps) where proxy = Proxy :: Proxy a defs = hcpure (Proxy :: Proxy AesonDefaultValue) defaultValue @@ -156,14 +161,14 @@ sopSwaggerGenericToJSON'' (SwaggerAesonOptions prefix _ sub) = go go Nil Nil Nil = [] go (I x :* xs) (FieldInfo name :* names) (def :* defs) | Just name' == sub = case json of - Object m -> HM.toList m ++ rest + Object m -> KM.toList m ++ rest Null -> rest _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show json -- If default value: omit it. | Just x == def = rest | otherwise = - (T.pack name', json) : rest + (fromString name', json) : rest where json = toJSON x name' = fieldNameModifier name @@ -199,7 +204,7 @@ sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj -> parseAdditionalField :: Object -> (Text, Value) -> Parser () parseAdditionalField obj (k, v) = do - v' <- obj .: k + v' <- obj .: fromText k unless (v == v') $ fail $ "Additonal field don't match for key " ++ T.unpack k ++ ": " ++ show v @@ -230,10 +235,10 @@ sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go go (FieldInfo name :* names) (def :* defs) | Just name' == sub = -- Note: we might strip fields of outer structure. - cons <$> (withDef $ parseJSON $ Object obj) <*> rest + cons <$> withDef (parseJSON $ Object obj) <*> rest | otherwise = case def of - Just def' -> cons <$> obj .:? T.pack name' .!= def' <*> rest - Nothing -> cons <$> obj .: T.pack name' <*> rest + Just def' -> cons <$> obj .:? fromString name' .!= def' <*> rest + Nothing -> cons <$> obj .: fromString name' <*> rest where cons h t = I h :* t name' = fieldNameModifier name @@ -264,7 +269,7 @@ sopSwaggerGenericToEncoding -> Encoding sopSwaggerGenericToEncoding x = let ps = sopSwaggerGenericToEncoding' opts (from x) (datatypeInfo proxy) (aesonDefaults proxy) - in pairs (pairsToSeries (opts ^. saoAdditionalPairs) <> ps) + in pairs (pairsToSeries ((map $ first fromText) (opts ^. saoAdditionalPairs)) <> ps) where proxy = Proxy :: Proxy a opts = swaggerAesonOptions proxy @@ -296,14 +301,14 @@ sopSwaggerGenericToEncoding'' (SwaggerAesonOptions prefix _ sub) = go go Nil Nil Nil = mempty go (I x :* xs) (FieldInfo name :* names) (def :* defs) | Just name' == sub = case toJSON x of - Object m -> pairsToSeries (HM.toList m) <> rest + Object m -> pairsToSeries (KM.toList m) <> rest Null -> rest _ -> error $ "sopSwaggerGenericToJSON: subjson is not an object: " ++ show (toJSON x) -- If default value: omit it. | Just x == def = rest | otherwise = - (T.pack name' .= x) <> rest + (fromString name' .= x) <> rest where name' = fieldNameModifier name rest = go xs names defs diff --git a/src/Data/Swagger/Internal/ParamSchema.hs b/src/Data/Swagger/Internal/ParamSchema.hs index b927fb6f..0a92d0d0 100644 --- a/src/Data/Swagger/Internal/ParamSchema.hs +++ b/src/Data/Swagger/Internal/ParamSchema.hs @@ -270,7 +270,7 @@ instance ToParamSchema a => ToParamSchema (HashSet a) where -- | -- >>> encode $ toParamSchema (Proxy :: Proxy ()) --- "{\"type\":\"string\",\"enum\":[\"_\"]}" +-- "{\"enum\":[\"_\"],\"type\":\"string\"}" instance ToParamSchema () where toParamSchema _ = mempty & type_ ?~ SwaggerString @@ -286,7 +286,7 @@ instance ToParamSchema UUID where -- >>> :set -XDeriveGeneric -- >>> data Color = Red | Blue deriving Generic -- >>> encode $ genericToParamSchema defaultSchemaOptions (Proxy :: Proxy Color) --- "{\"type\":\"string\",\"enum\":[\"Red\",\"Blue\"]}" +-- "{\"enum\":[\"Red\",\"Blue\"],\"type\":\"string\"}" genericToParamSchema :: forall a t. (Generic a, GToParamSchema (Rep a)) => SchemaOptions -> Proxy a -> ParamSchema t genericToParamSchema opts _ = gtoParamSchema opts (Proxy :: Proxy (Rep a)) mempty diff --git a/src/Data/Swagger/Internal/Schema.hs b/src/Data/Swagger/Internal/Schema.hs index 210cc856..ed625a59 100644 --- a/src/Data/Swagger/Internal/Schema.hs +++ b/src/Data/Swagger/Internal/Schema.hs @@ -69,6 +69,8 @@ import Data.Swagger.Internal.TypeShape import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BSL import GHC.TypeLits (TypeError, ErrorMessage(..)) +import qualified Data.Aeson.KeyMap as KM +import Data.Aeson.Key (toText) unnamed :: Schema -> NamedSchema unnamed schema = NamedSchema Nothing schema @@ -321,7 +323,7 @@ passwordSchema = mempty -- >>> data Person = Person { name :: String, age :: Int } deriving (Generic) -- >>> instance ToJSON Person -- >>> encode $ sketchSchema (Person "Jack" 25) --- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"type\":\"number\"},\"name\":{\"type\":\"string\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}" +-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"type\":\"string\"},\"age\":{\"type\":\"number\"}},\"example\":{\"age\":25,\"name\":\"Jack\"},\"type\":\"object\"}" sketchSchema :: ToJSON a => a -> Schema sketchSchema = sketch . toJSON where @@ -345,7 +347,7 @@ sketchSchema = sketch . toJSON ischema = case ys of (z:_) | allSame -> Just z _ -> Nothing - go (Object o) = mempty + go (Object o') = let o = KM.toHashMapText o' in mempty & type_ ?~ SwaggerObject & required .~ HashMap.keys o & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o) @@ -354,18 +356,18 @@ sketchSchema = sketch . toJSON -- Produced schema uses as much constraints as possible. -- -- >>> encode $ sketchStrictSchema "hello" --- "{\"maxLength\":5,\"pattern\":\"hello\",\"minLength\":5,\"type\":\"string\",\"enum\":[\"hello\"]}" +-- "{\"enum\":[\"hello\"],\"maxLength\":5,\"minLength\":5,\"pattern\":\"hello\",\"type\":\"string\"}" -- -- >>> encode $ sketchStrictSchema (1, 2, 3) --- "{\"minItems\":3,\"uniqueItems\":true,\"items\":[{\"maximum\":1,\"minimum\":1,\"multipleOf\":1,\"type\":\"number\",\"enum\":[1]},{\"maximum\":2,\"minimum\":2,\"multipleOf\":2,\"type\":\"number\",\"enum\":[2]},{\"maximum\":3,\"minimum\":3,\"multipleOf\":3,\"type\":\"number\",\"enum\":[3]}],\"maxItems\":3,\"type\":\"array\",\"enum\":[[1,2,3]]}" +-- "{\"enum\":[[1,2,3]],\"items\":[{\"enum\":[1],\"maximum\":1,\"minimum\":1,\"multipleOf\":1,\"type\":\"number\"},{\"enum\":[2],\"maximum\":2,\"minimum\":2,\"multipleOf\":2,\"type\":\"number\"},{\"enum\":[3],\"maximum\":3,\"minimum\":3,\"multipleOf\":3,\"type\":\"number\"}],\"maxItems\":3,\"minItems\":3,\"type\":\"array\",\"uniqueItems\":true}" -- -- >>> encode $ sketchStrictSchema ("Jack", 25) --- "{\"minItems\":2,\"uniqueItems\":true,\"items\":[{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]},{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]}],\"maxItems\":2,\"type\":\"array\",\"enum\":[[\"Jack\",25]]}" +-- "{\"enum\":[[\"Jack\",25]],\"items\":[{\"enum\":[\"Jack\"],\"maxLength\":4,\"minLength\":4,\"pattern\":\"Jack\",\"type\":\"string\"},{\"enum\":[25],\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\"}],\"maxItems\":2,\"minItems\":2,\"type\":\"array\",\"uniqueItems\":true}" -- -- >>> data Person = Person { name :: String, age :: Int } deriving (Generic) -- >>> instance ToJSON Person -- >>> encode $ sketchStrictSchema (Person "Jack" 25) --- "{\"required\":[\"age\",\"name\"],\"properties\":{\"age\":{\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\",\"enum\":[25]},\"name\":{\"maxLength\":4,\"pattern\":\"Jack\",\"minLength\":4,\"type\":\"string\",\"enum\":[\"Jack\"]}},\"maxProperties\":2,\"minProperties\":2,\"type\":\"object\",\"enum\":[{\"age\":25,\"name\":\"Jack\"}]}" +-- "{\"required\":[\"name\",\"age\"],\"properties\":{\"name\":{\"enum\":[\"Jack\"],\"maxLength\":4,\"minLength\":4,\"pattern\":\"Jack\",\"type\":\"string\"},\"age\":{\"enum\":[25],\"maximum\":25,\"minimum\":25,\"multipleOf\":25,\"type\":\"number\"}},\"maxProperties\":2,\"minProperties\":2,\"enum\":[{\"age\":25,\"name\":\"Jack\"}],\"type\":\"object\"}" sketchStrictSchema :: ToJSON a => a -> Schema sketchStrictSchema = go . toJSON where @@ -395,7 +397,7 @@ sketchStrictSchema = go . toJSON where sz = length xs allUnique = sz == HashSet.size (HashSet.fromList (V.toList xs)) - go js@(Object o) = mempty + go js@(Object o') = let o = KM.toHashMapText o' in mempty & type_ ?~ SwaggerObject & required .~ names & properties .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o) @@ -403,7 +405,7 @@ sketchStrictSchema = go . toJSON & minProperties ?~ fromIntegral (length names) & enum_ ?~ [js] where - names = HashMap.keys o + names = HashMap.keys (KM.toHashMapText o') class GToSchema (f :: * -> *) where gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema @@ -613,9 +615,9 @@ declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key o objectSchema keyToText = do valueRef <- declareSchemaRef (Proxy :: Proxy value) let allKeys = [minBound..maxBound :: key] - mkPair k = (keyToText k, valueRef) + mkPair k = (toText $ keyToText k, valueRef) return $ mempty - & type_ ?~ SwaggerObject + & type_ ?~ SwaggerObject & properties .~ InsOrdHashMap.fromList (map mkPair allKeys) -- | A 'Schema' for a mapping with 'Bounded' 'Enum' keys. diff --git a/src/Data/Swagger/Internal/Schema/Validation.hs b/src/Data/Swagger/Internal/Schema/Validation.hs index 39fd03a5..bef52ea3 100644 --- a/src/Data/Swagger/Internal/Schema/Validation.hs +++ b/src/Data/Swagger/Internal/Schema/Validation.hs @@ -50,6 +50,7 @@ import Data.Swagger.Declare import Data.Swagger.Internal import Data.Swagger.Internal.Schema import Data.Swagger.Lens +import qualified Data.Aeson.KeyMap as KM -- | Validate @'ToJSON'@ instance matches @'ToSchema'@ for a given value. -- This can be used with QuickCheck to ensure those instances are coherent: @@ -101,33 +102,33 @@ validateToJSONWithPatternChecker checker = validateJSONWithPatternChecker checke -- -- Swagger Schema: -- { --- "required": [ --- "name", --- "phone" --- ], --- "type": "object", -- "properties": { --- "phone": { --- "$ref": "#/definitions/Phone" --- }, -- "name": { -- "type": "string" +-- }, +-- "phone": { +-- "$ref": "#/definitions/Phone" -- } --- } +-- }, +-- "required": [ +-- "name", +-- "phone" +-- ], +-- "type": "object" -- } -- -- Swagger Description Context: -- { -- "Phone": { --- "required": [ --- "value" --- ], --- "type": "object", -- "properties": { -- "value": { -- "type": "string" -- } --- } +-- }, +-- "required": [ +-- "value" +-- ], +-- "type": "object" -- } -- } -- @@ -375,7 +376,7 @@ validateObject :: HashMap Text Value -> Validation Schema () validateObject o = withSchema $ \sch -> case sch ^. discriminator of Just pname -> case fromJSON <$> HashMap.lookup pname o of - Just (Success ref) -> validateWithSchemaRef ref (Object o) + Just (Success ref) -> validateWithSchemaRef ref (Object $ KM.fromHashMapText o) Just (Error msg) -> invalid ("failed to parse discriminator property " ++ show pname ++ ": " ++ show msg) Nothing -> invalid ("discriminator property " ++ show pname ++ "is missing") Nothing -> do @@ -476,14 +477,14 @@ validateSchemaType value = withSchema $ \sch -> (Just SwaggerNumber, Number n) -> sub_ paramSchema (validateNumber n) (Just SwaggerString, String s) -> sub_ paramSchema (validateString s) (Just SwaggerArray, Array xs) -> sub_ paramSchema (validateArray xs) - (Just SwaggerObject, Object o) -> validateObject o + (Just SwaggerObject, Object o) -> validateObject $ KM.toHashMapText o (Nothing, Null) -> valid (Nothing, Bool _) -> valid -- Number by default (Nothing, Number n) -> sub_ paramSchema (validateNumber n) (Nothing, String s) -> sub_ paramSchema (validateString s) (Nothing, Array xs) -> sub_ paramSchema (validateArray xs) - (Nothing, Object o) -> validateObject o + (Nothing, Object o) -> validateObject $ KM.toHashMapText o bad -> invalid $ "expected JSON value of type " ++ showType bad validateParamSchemaType :: Value -> Validation (ParamSchema t) () diff --git a/src/Data/Swagger/Operation.hs b/src/Data/Swagger/Operation.hs index 607dc992..33100b54 100644 --- a/src/Data/Swagger/Operation.hs +++ b/src/Data/Swagger/Operation.hs @@ -80,9 +80,9 @@ allOperations = paths.traverse.template -- >>> 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\":{\"get\":{\"responses\":{\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}" +-- "{\"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\":{\"version\":\"\",\"title\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"404\":{\"description\":\"Not found\"},\"200\":{\"description\":\"OK\"}}},\"post\":{\"responses\":{\"200\":{\"description\":\"OK\"}}}}}}" +-- "{\"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 sub = paths.itraversed.withIndex.subops where @@ -139,7 +139,7 @@ declareResponse proxy = do -- >>> 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\":\"\"},\"paths\":{\"/user\":{\"get\":{\"responses\":{\"200\":{\"schema\":{\"$ref\":\"#/definitions/Day\"},\"description\":\"\"}}}}},\"definitions\":{\"Day\":{\"example\":\"2016-07-22\",\"format\":\"date\",\"type\":\"string\"}}}" +-- "{\"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 diff --git a/src/Data/Swagger/Optics.hs b/src/Data/Swagger/Optics.hs index 07819c7f..9c22e056 100644 --- a/src/Data/Swagger/Optics.hs +++ b/src/Data/Swagger/Optics.hs @@ -29,7 +29,7 @@ -- & 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\"}}}" +-- "{\"swagger\":\"2.0\",\"info\":{\"title\":\"\",\"version\":\"\"},\"paths\":{\"/user\":{\"get\":{\"produces\":[\"application/json\"],\"responses\":{\"200\":{\"description\":\"OK\",\"schema\":{\"$ref\":\"#/definitions/User\"}},\"404\":{\"description\":\"User info not found\"}}}}},\"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 diff --git a/src/Data/Swagger/Schema/Generator.hs b/src/Data/Swagger/Schema/Generator.hs index a5cca577..32f5480e 100644 --- a/src/Data/Swagger/Schema/Generator.hs +++ b/src/Data/Swagger/Schema/Generator.hs @@ -10,6 +10,7 @@ import Prelude.Compat import Control.Lens.Operators import Control.Monad (filterM) import Data.Aeson +import qualified Data.Aeson.KeyMap as KM import Data.Aeson.Types import qualified Data.HashMap.Strict.InsOrd as M import Data.Maybe @@ -93,7 +94,7 @@ schemaGen defns schema = return . M.fromList $ zip additionalKeys (repeat . schemaGen defns $ dereference defns addlSchema) _ -> return [] x <- sequence $ gens <> additionalGens - return . Object $ M.toHashMap x + return . Object . KM.fromHashMapText $ M.toHashMap x where dereference :: Definitions a -> Referenced a -> a dereference _ (Inline a) = a diff --git a/stack.yaml b/stack.yaml index b6fecb68..bf888ea5 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,9 +1,8 @@ -resolver: lts-15.1 +resolver: lts-18.16 packages: -- '.' + - "." extra-deps: -- optics-core-0.3 -- optics-th-0.3 -- optics-extra-0.3 -- indexed-profunctors-0.1 -- insert-ordered-containers-0.2.3.1 + - aeson-2.0.1.0@sha256:ee0847af4d1fb9ece3f24f443d8d8406431c32688a57880314ac36617da937eb,6229 + - semialign-1.2.0.1@sha256:5efc30d6f53f8d2a8a26d9bf3a57c0f20f4ba3086797ccaa615f644abc21d42e,2814 + - time-compat-1.9.6.1@sha256:381a2e8ed6e41d20ff5929d12d25c1d9337d459de5964ef1d90b06d115b31f07,5033 + - hashable-1.3.5.0@sha256:47d1232d9788bb909cfbd80618de18dcdfb925609593e202912bd5841db138c1,4193 diff --git a/swagger2.cabal b/swagger2.cabal index a24d8761..14c2cea2 100644 --- a/swagger2.cabal +++ b/swagger2.cabal @@ -23,12 +23,12 @@ extra-source-files: , CHANGELOG.md , examples/*.hs tested-with: - GHC ==8.0.2 - || ==8.2.2 - || ==8.4.4 + GHC ==8.4.4 || ==8.6.5 - || ==8.8.1 - || ==8.10.1 + || ==8.8.4 + || ==8.10.4 + || ==8.10.7 + || ==9.0.1 custom-setup setup-depends: @@ -59,10 +59,10 @@ library -- GHC boot libraries build-depends: - base >=4.9 && <4.15 + base >=4.9 && <4.16 , bytestring >=0.10.8.1 && <0.11 , containers >=0.5.7.1 && <0.7 - , template-haskell >=2.11.1.0 && <2.17 + , template-haskell >=2.11.1.0 && <2.18 , time >=1.6.0.1 && <1.10 , transformers >=0.5.2.0 && <0.6 @@ -73,7 +73,7 @@ library -- other dependencies build-depends: base-compat-batteries >=0.11.1 && <0.12 - , aeson >=1.4.2.0 && <1.6 + , aeson >=2.0.0.0 && <2.1 , aeson-pretty >=0.8.7 && <0.9 -- cookie 0.4.3 is needed by GHC 7.8 due to time>=1.4 constraint , cookie >=0.4.3 && <0.5 @@ -81,10 +81,10 @@ library , hashable >=1.2.7.0 && <1.4 , http-media >=0.8.0.0 && <0.9 , insert-ordered-containers >=0.2.3 && <0.3 - , lens >=4.16.1 && <4.20 + , lens >=4.16.1 && <5.1 , network >=2.6.3.5 && <3.2 - , optics-core >=0.2 && <0.4 - , optics-th >=0.2 && <0.4 + , optics-core >=0.2 && <0.5 + , optics-th >=0.2 && <0.5 , scientific >=0.3.6.2 && <0.4 , unordered-containers >=0.2.9.0 && <0.3 , uuid-types >=1.0.3 && <1.1 @@ -120,14 +120,14 @@ test-suite spec -- test-suite only dependencies build-depends: - hspec >=2.5.5 && <2.8 + hspec >=2.5.5 && <2.9 , HUnit >=1.6.0.0 && <1.7 , quickcheck-instances >=0.3.19 && <0.14 , utf8-string >=1.0.1.1 && <1.1 -- https://github.com/haskell/cabal/issues/3708 build-tool-depends: - hspec-discover:hspec-discover >=2.5.5 && <2.8 + hspec-discover:hspec-discover >=2.5.5 && <2.9 other-modules: SpecCommon diff --git a/test/Data/Swagger/Schema/ValidationSpec.hs b/test/Data/Swagger/Schema/ValidationSpec.hs index beade4b3..822c12a3 100644 --- a/test/Data/Swagger/Schema/ValidationSpec.hs +++ b/test/Data/Swagger/Schema/ValidationSpec.hs @@ -2,6 +2,7 @@ {-# LANGUAGE PackageImports #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE FlexibleInstances #-} {-# OPTIONS_GHC -fno-warn-orphans #-} module Data.Swagger.Schema.ValidationSpec where @@ -9,6 +10,8 @@ import Control.Applicative import Control.Lens ((&), (.~), (?~)) import Data.Aeson import Data.Aeson.Types +import Data.Aeson.Key +import qualified Data.Aeson.KeyMap as KM import Data.Hashable (Hashable) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HashMap @@ -122,9 +125,9 @@ instance Arbitrary Person where invalidPersonToJSON :: Person -> Value invalidPersonToJSON Person{..} = object - [ T.pack "personName" .= toJSON name - , T.pack "personPhone" .= toJSON phone - , T.pack "personEmail" .= toJSON email + [ fromString "personName" .= toJSON name + , fromString "personPhone" .= toJSON phone + , fromString "personEmail" .= toJSON email ] -- ======================================================================== @@ -251,7 +254,7 @@ instance ToSchema FreeForm where & additionalProperties ?~ AdditionalPropertiesAllowed True instance Arbitrary FreeForm where - arbitrary = (FreeForm . fromList) <$> genObj + arbitrary = FreeForm . fromList <$> genObj where genObj = listOf $ do k <- arbitrary @@ -269,9 +272,12 @@ instance Arbitrary Value where -- Weights are almost random -- Uniform oneof tends not to build complex objects cause of recursive call. arbitrary = resize 4 $ frequency - [ (3, Object <$> arbitrary) + [ (3, Object . KM.fromHashMapText <$> arbitrary) , (3, Array <$> arbitrary) , (3, String <$> arbitrary) , (3, Number <$> arbitrary) , (3, Bool <$> arbitrary) , (1, return Null) ] + +instance Arbitrary (KM.KeyMap Value) where + arbitrary = KM.fromHashMapText <$> arbitrary diff --git a/test/SpecCommon.hs b/test/SpecCommon.hs index c8c2e960..6dcd0b8c 100644 --- a/test/SpecCommon.hs +++ b/test/SpecCommon.hs @@ -1,18 +1,20 @@ module SpecCommon where import Data.Aeson +import Data.Aeson.Key import Data.ByteString.Builder (toLazyByteString) -import qualified Data.Foldable as F +import qualified Data.Foldable as F import qualified Data.HashMap.Strict as HashMap -import qualified Data.Vector as Vector +import qualified Data.Aeson.KeyMap as KM +import qualified Data.Vector as Vector import Test.Hspec isSubJSON :: Value -> Value -> Bool isSubJSON Null _ = True -isSubJSON (Object x) (Object y) = HashMap.keys x == HashMap.keys i && F.and i +isSubJSON (Object x) (Object y) = map toText (KM.keys x) == HashMap.keys i && F.and i where - i = HashMap.intersectionWith isSubJSON x y + i = HashMap.intersectionWith isSubJSON (KM.toHashMapText x) (KM.toHashMapText y) isSubJSON (Array xs) (Array ys) = Vector.length xs == Vector.length ys && F.and (Vector.zipWith isSubJSON xs ys) isSubJSON x y = x == y