Merge pull request #34 from biocad/maksbotan/aeson-2

Support aeson-2

.github/workflows/haskell-ci.yml

@@ -8,9 +8,9 @@
 #
 # For more information, see https://github.com/haskell-CI/haskell-ci
 #
-# version: 0.12
+# version: 0.12.1
 #
-# REGENDATA ("0.12",["github","cabal.project"])
+# REGENDATA ("0.12.1",["github","cabal.project"])
 #
 name: Haskell-CI
 on:
@@ -21,7 +21,7 @@ jobs:
     name: Haskell-CI - Linux - ${{ matrix.compiler }}
     runs-on: ubuntu-18.04
     container:
-      image: buildpack-deps:bionic
+      image: buildpack-deps:xenial
     continue-on-error: ${{ matrix.allow-failure }}
     strategy:
       matrix:
@@ -175,3 +175,12 @@ jobs:
         run: |
           rm -f cabal.project.local
           $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks all
+      - name: prepare for constraint sets
+        run: |
+          rm -f cabal.project.local
+      - name: constraint set aeson-2
+        run: |
+          $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='aeson >=2.0' all
+      - name: constraint set aeson-1
+        run: |
+          $CABAL v2-build $ARG_COMPILER --disable-tests --disable-benchmarks --constraint='aeson <2.0' all

cabal.haskell-ci

@@ -0,0 +1,7 @@
+branches: master
+
+constraint-set aeson-1
+  constraints: aeson <2.0
+
+constraint-set aeson-2
+  constraints: aeson >=2.0

openapi3.cabal

@@ -56,6 +56,8 @@ library
     Data.OpenApi.Internal.AesonUtils
     Data.OpenApi.Internal.TypeShape
 
+    Data.OpenApi.Aeson.Compat
+
   -- GHC boot libraries
   build-depends:
       base             >=4.11.1.0  && <4.16
@@ -71,8 +73,8 @@ library
 
   -- other dependencies
   build-depends:
-      base-compat-batteries     >=0.11.1   && <0.12
-    , aeson                     >=1.4.2.0  && <1.6
+      base-compat-batteries     >=0.11.1   && <0.13
+    , aeson                     >=1.4.2.0  && <1.6 || >=2.0.1.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

src/Data/OpenApi/Aeson/Compat.hs

@@ -0,0 +1,76 @@
+{-# LANGUAGE CPP #-}
+
+module Data.OpenApi.Aeson.Compat where
+
+#if MIN_VERSION_aeson(2,0,0)
+import           Data.Aeson        (Key)
+import qualified Data.Aeson.Key    as Key
+import qualified Data.Aeson.KeyMap as KeyMap
+#else
+import qualified Data.HashMap.Strict as HM
+#endif
+import           Data.Bifunctor             (first)
+import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
+import qualified Data.Text                  as T
+
+#if MIN_VERSION_aeson(2,0,0)
+deleteKey :: Key -> KeyMap.KeyMap v -> KeyMap.KeyMap v
+deleteKey = KeyMap.delete
+
+objectToList :: KeyMap.KeyMap v -> [(Key, v)]
+objectToList = KeyMap.toList
+
+objectKeys :: KeyMap.KeyMap v -> [T.Text]
+objectKeys = map Key.toText . KeyMap.keys
+
+stringToKey :: String -> Key
+stringToKey = Key.fromString
+
+keyToString :: Key -> String
+keyToString = Key.toString
+
+keyToText :: Key -> T.Text
+keyToText = Key.toText
+
+toInsOrdHashMap :: KeyMap.KeyMap v -> InsOrdHashMap.InsOrdHashMap T.Text v
+toInsOrdHashMap = InsOrdHashMap.fromList . fmap (first Key.toText) . KeyMap.toList
+
+fromInsOrdHashMap :: InsOrdHashMap.InsOrdHashMap T.Text v -> KeyMap.KeyMap v
+fromInsOrdHashMap = KeyMap.fromList . fmap (first Key.fromText) . InsOrdHashMap.toList
+
+lookupKey :: T.Text -> KeyMap.KeyMap v -> Maybe v
+lookupKey = KeyMap.lookup . Key.fromText
+
+hasKey :: T.Text -> KeyMap.KeyMap a -> Bool
+hasKey = KeyMap.member . Key.fromText
+#else
+deleteKey :: T.Text -> HM.HashMap T.Text v -> HM.HashMap T.Text v
+deleteKey = HM.delete
+
+objectToList :: HM.HashMap T.Text v -> [(T.Text, v)]
+objectToList = HM.toList
+
+objectKeys :: HM.HashMap T.Text v -> [T.Text]
+objectKeys = HM.keys
+
+stringToKey :: String -> T.Text
+stringToKey = T.pack
+
+keyToString :: T.Text -> String
+keyToString = T.unpack
+
+keyToText :: T.Text -> T.Text
+keyToText = id
+
+toInsOrdHashMap :: HM.HashMap T.Text v -> InsOrdHashMap.InsOrdHashMap T.Text v
+toInsOrdHashMap = InsOrdHashMap.fromHashMap
+
+fromInsOrdHashMap :: InsOrdHashMap.InsOrdHashMap T.Text v -> HM.HashMap T.Text v
+fromInsOrdHashMap = InsOrdHashMap.toHashMap
+
+lookupKey :: T.Text -> HM.HashMap T.Text v -> Maybe v
+lookupKey = HM.lookup
+
+hasKey :: T.Text -> HM.HashMap T.Text a -> Bool
+hasKey = HM.member
+#endif

src/Data/OpenApi/Internal.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE CPP #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE DeriveDataTypeable #-}
 {-# LANGUAGE DeriveGeneric #-}
@@ -21,6 +22,9 @@ import Prelude.Compat
 import           Control.Applicative
 import           Control.Lens          ((&), (.~), (?~))
 import           Data.Aeson            hiding (Encoding)
+#if MIN_VERSION_aeson(2,0,0)
+import qualified Data.Aeson.KeyMap     as KeyMap
+#endif
 import qualified Data.Aeson.Types      as JSON
 import           Data.Data             (Constr, Data (..), DataType, Fixity (..), Typeable,
                                         constrIndex, mkConstr, mkDataType)
@@ -45,17 +49,13 @@ import           Text.Read             (readMaybe)
 import           Data.HashMap.Strict.InsOrd (InsOrdHashMap)
 import qualified Data.HashMap.Strict.InsOrd as InsOrdHashMap
 
-import Generics.SOP.TH                  (deriveGeneric)
-import Data.OpenApi.Internal.AesonUtils (sopSwaggerGenericToEncoding
-                                        ,sopSwaggerGenericToJSON
-                                        ,sopSwaggerGenericToJSONWithOpts
-                                        ,sopSwaggerGenericParseJSON
-                                        ,HasSwaggerAesonOptions(..)
-                                        ,AesonDefaultValue(..)
-                                        ,mkSwaggerAesonOptions
-                                        ,saoAdditionalPairs
-                                        ,saoSubObject)
+import Data.OpenApi.Aeson.Compat        (deleteKey)
+import Data.OpenApi.Internal.AesonUtils (AesonDefaultValue (..), HasSwaggerAesonOptions (..),
+                                         mkSwaggerAesonOptions, saoAdditionalPairs, saoSubObject,
+                                         sopSwaggerGenericParseJSON, sopSwaggerGenericToEncoding,
+                                         sopSwaggerGenericToJSON, sopSwaggerGenericToJSONWithOpts)
 import Data.OpenApi.Internal.Utils
+import Generics.SOP.TH                  (deriveGeneric)
 
 -- $setup
 -- >>> :seti -XDataKinds
@@ -337,7 +337,7 @@ data RequestBody = RequestBody
     -- | The content of the request body.
     -- The key is a media type or media type range and the value describes it.
     -- For requests that match multiple keys, only the most specific key is applicable.
-    -- e.g. @text/plain@ overrides @text/*@
+    -- e.g. @text/plain@ overrides @text/\*@
   , _requestBodyContent :: InsOrdHashMap MediaType MediaTypeObject
 
     -- | Determines if the request body is required in the request.
@@ -394,7 +394,7 @@ data Encoding = Encoding
     -- for other primitive types – @text/plain@; for object - @application/json@;
     -- for array – the default is defined based on the inner type.
     -- The value can be a specific media type (e.g. @application/json@),
-    -- a wildcard media type (e.g. @image/*@), or a comma-separated list of the two types.
+    -- a wildcard media type (e.g. @image/\*@), or a comma-separated list of the two types.
     _encodingContentType :: Maybe MediaType
 
     -- | A map allowing additional information to be provided as headers,
@@ -734,7 +734,7 @@ data Response = Response
     -- | A map containing descriptions of potential response payloads.
     -- The key is a media type or media type range and the value describes it.
     -- For responses that match multiple keys, only the most specific key is applicable.
-    -- e.g. @text/plain@ overrides @text/*@.
+    -- e.g. @text/plain@ overrides @text/\*@.
   , _responseContent :: InsOrdHashMap MediaType MediaTypeObject
 
     -- | Maps a header name to its definition.
@@ -1492,7 +1492,7 @@ instance FromJSON Param where
 instance FromJSON Responses where
   parseJSON (Object o) = Responses
     <$> o .:? "default"
-    <*> parseJSON (Object (HashMap.delete "default" o))
+    <*> parseJSON (Object (deleteKey "default" o))
   parseJSON _ = empty
 
 instance FromJSON Example where

src/Data/OpenApi/Internal/AesonUtils.hs

@@ -36,18 +36,19 @@ import Data.Text        (Text)
 import Generics.SOP
 
 import qualified Data.Text as T
-import qualified Data.HashMap.Strict as HM
 import qualified Data.Set as Set
 import qualified Data.HashMap.Strict.InsOrd as InsOrd
 import qualified Data.HashSet.InsOrd as InsOrdHS
 
+import Data.OpenApi.Aeson.Compat (keyToString, objectToList, stringToKey)
+
 -------------------------------------------------------------------------------
 -- SwaggerAesonOptions
 -------------------------------------------------------------------------------
 
 data SwaggerAesonOptions = SwaggerAesonOptions
     { _saoPrefix          :: String
-    , _saoAdditionalPairs :: [(Text, Value)]
+    , _saoAdditionalPairs :: [Pair]
     , _saoSubObject       :: Maybe String
     }
 
@@ -154,14 +155,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 -> objectToList 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
+            (stringToKey name', json) : rest
       where
         json  = toJSON x
         name' = fieldNameModifier name
@@ -195,11 +196,11 @@ sopSwaggerGenericParseJSON = withObject "Swagger Record Object" $ \obj ->
     proxy = Proxy :: Proxy a
     opts  = swaggerAesonOptions proxy
 
-    parseAdditionalField :: Object -> (Text, Value) -> Parser ()
+    parseAdditionalField :: Object -> Pair -> Parser ()
     parseAdditionalField obj (k, v) = do
         v' <- obj .: k
         unless (v == v') $ fail $
-            "Additonal field don't match for key " ++ T.unpack k
+            "Additonal field don't match for key " ++ keyToString k
             ++ ": " ++ show v
             ++ " /= " ++ show v'
 
@@ -230,8 +231,8 @@ sopSwaggerGenericParseJSON'' (SwaggerAesonOptions prefix _ sub) obj = go
             -- Note: we might strip fields of outer structure.
             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 .:? stringToKey name' .!= def' <*> rest
+            Nothing  ->  cons <$> obj .: stringToKey name' <*> rest
       where
         cons h t = I h :* t
         name' = fieldNameModifier name
@@ -294,14 +295,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 (objectToList 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
+            (stringToKey name' .= x) <> rest
       where
         name' = fieldNameModifier name
         rest  = go xs names defs

src/Data/OpenApi/Internal/Schema.hs

@@ -64,13 +64,14 @@ import GHC.Generics
 import qualified Data.UUID.Types as UUID
 import Type.Reflection (Typeable, typeRep)
 
-import Data.OpenApi.Declare
-import Data.OpenApi.Internal
-import Data.OpenApi.Internal.ParamSchema (ToParamSchema(..))
-import Data.OpenApi.Lens hiding (name, schema)
-import qualified Data.OpenApi.Lens as Swagger
-import Data.OpenApi.SchemaOptions
-import Data.OpenApi.Internal.TypeShape
+import           Data.OpenApi.Aeson.Compat         (keyToText, objectKeys, toInsOrdHashMap)
+import           Data.OpenApi.Declare
+import           Data.OpenApi.Internal
+import           Data.OpenApi.Internal.ParamSchema (ToParamSchema (..))
+import           Data.OpenApi.Internal.TypeShape
+import           Data.OpenApi.Lens                 hiding (name, schema)
+import qualified Data.OpenApi.Lens                 as Swagger
+import           Data.OpenApi.SchemaOptions
 
 import qualified Data.ByteString as BS
 import qualified Data.ByteString.Lazy.Char8 as BSL
@@ -405,8 +406,8 @@ sketchSchema = sketch . toJSON
           _               -> Nothing
     go (Object o) = mempty
       & type_         ?~ OpenApiObject
-      & required      .~ sort (HashMap.keys o)
-      & properties    .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
+      & required      .~ sort (objectKeys o)
+      & properties    .~ fmap (Inline . go) (toInsOrdHashMap o)
 
 -- | Make a restrictive sketch of a @'Schema'@ based on a @'ToJSON'@ instance.
 -- Produced schema uses as much constraints as possible.
@@ -570,12 +571,12 @@ sketchStrictSchema = go . toJSON
     go js@(Object o) = mempty
       & type_         ?~ OpenApiObject
       & required      .~ sort names
-      & properties    .~ fmap (Inline . go) (InsOrdHashMap.fromHashMap o)
+      & properties    .~ fmap (Inline . go) (toInsOrdHashMap o)
       & maxProperties ?~ fromIntegral (length names)
       & minProperties ?~ fromIntegral (length names)
       & enum_         ?~ [js]
       where
-        names = HashMap.keys o
+        names = objectKeys o
 
 class GToSchema (f :: * -> *) where
   gdeclareNamedSchema :: SchemaOptions -> Proxy f -> Schema -> Declare (Definitions Schema) NamedSchema
@@ -810,13 +811,13 @@ declareSchemaBoundedEnumKeyMapping :: forall map key value.
   (Bounded key, Enum key, ToJSONKey key, ToSchema key, ToSchema value)
   => Proxy (map key value) -> Declare (Definitions Schema) Schema
 declareSchemaBoundedEnumKeyMapping _ = case toJSONKey :: ToJSONKeyFunction key of
-  ToJSONKeyText keyToText _ -> objectSchema keyToText
+  ToJSONKeyText getKey _ -> objectSchema getKey
   ToJSONKeyValue _ _ -> declareSchema (Proxy :: Proxy [(key, value)])
   where
-    objectSchema keyToText = do
+    objectSchema getKey = do
       valueRef <- declareSchemaRef (Proxy :: Proxy value)
       let allKeys   = [minBound..maxBound :: key]
-          mkPair k  =  (keyToText k, valueRef)
+          mkPair k  =  (keyToText $ getKey k, valueRef)
       return $ mempty
         & type_ ?~ OpenApiObject
         & properties .~ InsOrdHashMap.fromList (map mkPair allKeys)