Merge pull request #228 from alissa-tung/master

Use Aeson `>=2.0.0.0  && <2.1` and GitHub Actions

.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

.gitignore

@@ -17,3 +17,4 @@ cabal.sandbox.config
 *.aux
 *.hp
 .stack-work/
+stack.yaml.lock

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

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

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

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