diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2013-2014, Iris Connect +Copyright (c) 2013-2022, Iris Connect All rights reserved. @@ -28,3 +28,19 @@ THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + + +The Text.Regex module is derived from the regex-compat-tdfa package under the following license: + +Copyright (c) 2007, Christopher Kuklewicz +Copyright (c) 2012, shelarcy +All rights reserved. + +Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. + * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. + * The names of the contributors may not be used to endorse or promote products derived from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/api-tools.cabal b/api-tools.cabal --- a/api-tools.cabal +++ b/api-tools.cabal @@ -1,5 +1,5 @@ Name: api-tools -Version: 0.9.0.0 +Version: 0.10.0.0 Synopsis: DSL for generating API boilerplate and docs Description: api-tools provides a compact DSL for describing an API. It uses Template Haskell to generate the @@ -12,12 +12,12 @@ License-file: LICENSE Author: Chris Dornan and Adam Gundry Maintainer: Chris Dornan and Adam Gundry -Copyright: (c) Iris Connect 2013-2021 +Copyright: (c) Iris Connect 2013-2022 Category: Network, Web, Cloud, Distributed Computing Build-type: Simple Extra-source-files: changelog Cabal-version: >=1.10 -Tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.4 +Tested-with: GHC == 8.4.4, GHC == 8.6.5, GHC == 8.8.4, GHC == 8.10.7, GHC == 9.0.2, GHC == 9.2.2 Source-Repository head Type: git @@ -26,7 +26,7 @@ Source-Repository this Type: git Location: git://github.com/iconnect/api-tools.git - Tag: 0.9.0.0 + Tag: 0.10.0.0 Library Hs-Source-Dirs: src @@ -41,6 +41,7 @@ Data.API.Doc.Subst Data.API.Error Data.API.JSON + Data.API.JSON.Compat Data.API.JSONToCBOR Data.API.Markdown Data.API.NormalForm @@ -74,13 +75,14 @@ Data.API.Doc.Types Data.API.Scan Data.API.TH.Compat + Text.Regex Build-depends: QuickCheck >= 2.5.1 && < 2.15 , - aeson >= 0.10 && < 1.6 , + aeson >= 0.10 && < 1.6 || >= 2.0 && < 2.1 , aeson-pretty >= 0.1 && < 0.9 , array >= 0.4 && < 0.6 , - attoparsec >= 0.10.4 && < 0.14 , + attoparsec >= 0.10.4 && < 0.15 , base >= 4.9 && < 5 , base16-bytestring >= 0.1 && < 1.1 , base64-bytestring >= 1.0 && < 1.3 , @@ -89,15 +91,16 @@ cborg >= 0.1.1.0 && < 0.3 , containers >= 0.5 && < 0.7 , deepseq >= 1.1 && < 1.5 , - lens >= 3.8.7 && < 4.20 , - regex-compat-tdfa >= 0.95.1 && < 0.96 , + lens >= 3.8.7 && < 5.2 , + regex-base >= 0.93 && < 0.95 , + regex-tdfa >= 1.1.0 && < 1.4 , safe >= 0.3.3 && < 0.4 , safecopy >= 0.8.1 && < 0.11 , scientific >= 0.3 && < 0.4 , serialise >= 0.1.0.0 && < 0.3 , - template-haskell >= 2.7 && < 2.17 , - text >= 0.11.3 && < 1.3 , - time >= 1.5.0 && < 1.10, + template-haskell >= 2.7 && < 2.19 , + text >= 0.11.3 && < 2.1 , + time >= 1.5.0 && < 1.13 , unordered-containers >= 0.2.3.0 && < 0.3 , vector >= 0.10.0.1 && < 0.13 diff --git a/changelog b/changelog --- a/changelog +++ b/changelog @@ -1,5 +1,11 @@ -*-change-log-*- +0.10.0.0 Adam Gundry June 2022 + * Adjust dependency bounds and support building on GHC 9.2.x + * Add support for aeson-2.0 + * Drop dependency on regex-compat-tdfa + * Expose new module Data.API.JSON.Compat (primarily for internal use) + 0.9.0.0 Adam Gundry March 2021 * Adjust dependency bounds and support building on GHC 8.10.x * Drop support for GHC verisons older than 8.4.x diff --git a/src/Data/API/Changes.hs b/src/Data/API/Changes.hs --- a/src/Data/API/Changes.hs +++ b/src/Data/API/Changes.hs @@ -57,6 +57,7 @@ import Data.API.Changes.Types import Data.API.Error import Data.API.JSON +import Data.API.JSON.Compat import Data.API.NormalForm import Data.API.TH.Compat import Data.API.Types @@ -73,7 +74,6 @@ import Data.Maybe import Data.Set (Set) import qualified Data.Set as Set -import qualified Data.HashMap.Strict as HMap import qualified Data.Vector as V import qualified Data.Text as T import Data.Time @@ -585,27 +585,27 @@ applyChangeToData (ChAddField tname fname ftype mb_defval) _ = case mb_defval <|> defaultValueForType ftype of Just defval -> let newFieldValue = defaultValueAsJsValue defval - in withObject (\ v _ -> pure $ HMap.insert (_FieldName fname) newFieldValue v) + in withObject (\ v _ -> pure $ insertKey (_FieldName fname) newFieldValue v) Nothing -> \ _ p -> Left (InvalidAPI (DefaultMissing tname fname), p) applyChangeToData (ChDeleteField _ fname) _ = - withObject (\ v _ -> pure $ HMap.delete (_FieldName fname) v) + withObject (\ v _ -> pure $ deleteKey (_FieldName fname) v) applyChangeToData (ChRenameField _ fname fname') _ = - withObject $ \rec p -> case HMap.lookup (_FieldName fname) rec of + withObject $ \rec p -> case lookupKey (_FieldName fname) rec of Just field -> rename field rec Nothing -> Left (JSONError MissingField, inField fname : p) where - rename x = pure . HMap.insert (_FieldName fname') x . HMap.delete (_FieldName fname) + rename x = pure . insertKey (_FieldName fname') x . deleteKey (_FieldName fname) applyChangeToData (ChChangeField _ fname _ftype tag) custom = withObjectField (_FieldName fname) (liftMigration $ fieldMigration custom tag) applyChangeToData (ChRenameUnionAlt _ fname fname') _ = withObject $ \un p -> - case HMap.toList un of - [(k, r)] | k == _FieldName fname -> return $ HMap.singleton (_FieldName fname') r - | otherwise -> return un - _ -> Left (JSONError $ SyntaxError "Not singleton", p) + case matchSingletonObject un of + Just (k, r) | k == _FieldName fname -> return $ singletonObject (_FieldName fname') r + | otherwise -> return un + Nothing -> Left (JSONError $ SyntaxError "Not singleton", p) applyChangeToData (ChRenameEnumVal _ fname fname') _ = withString $ \s _ -> if s == _FieldName fname then return (_FieldName fname') @@ -748,9 +748,9 @@ withObjectField :: T.Text -> (JS.Value -> Position -> Either (ValueError, Position) JS.Value) -> JS.Value -> Position -> Either (ValueError, Position) JS.Value withObjectField field alter (JS.Object obj) p = - case HMap.lookup field obj of + case lookupKey field obj of Nothing -> Left (JSONError MissingField, InField field : p) - Just fvalue -> JS.Object <$> (HMap.insert field + Just fvalue -> JS.Object <$> (insertKey field <$> (alter fvalue (InField field : p)) <*> pure obj) withObjectField _ _ v p = Left (JSONError $ expectedObject v, p) @@ -759,27 +759,24 @@ -> (a -> JS.Value -> Position -> Either (ValueError, Position) JS.Value) -> JS.Value -> Position -> Either (ValueError, Position) JS.Value withObjectMatchingFields m f (JS.Object obj) p = do - zs <- matchMaps (Map.mapKeys _FieldName m) (hmapToMap obj) ?!? toErr + zs <- matchMaps (Map.mapKeys _FieldName m) (objectToMap obj) ?!? toErr obj' <- Map.traverseWithKey (\ k (ty, val) -> (f ty val (InField k : p))) zs - return $ JS.Object $ mapToHMap obj' + return $ JS.Object $ mapToObject obj' where toErr (k, Left _) = (JSONError MissingField, InField k : p) toErr (k, Right _) = (JSONError UnexpectedField, InField k : p) - hmapToMap = Map.fromList . HMap.toList - mapToHMap = HMap.fromList . Map.toList - withObjectMatchingFields _ _ v p = Left (JSONError $ expectedObject v, p) withObjectMatchingUnion :: Map FieldName a -> (a -> JS.Value -> Position -> Either (ValueError, Position) JS.Value) -> JS.Value -> Position -> Either (ValueError, Position) JS.Value withObjectMatchingUnion m f (JS.Object obj) p - | [(k, r)] <- HMap.toList obj + | Just (k, r) <- matchSingletonObject obj = do x <- Map.lookup (FieldName k) m ?! (JSONError UnexpectedField, InField k : p) r' <- f x r (InField k : p) - return $ JS.Object $ HMap.singleton k r' + return $ JS.Object $ singletonObject k r' withObjectMatchingUnion _ _ _ p = Left (JSONError $ SyntaxError "Not singleton", p) withArrayElems :: (JS.Value -> Position -> Either (ValueError, Position) JS.Value) diff --git a/src/Data/API/Error.hs b/src/Data/API/Error.hs --- a/src/Data/API/Error.hs +++ b/src/Data/API/Error.hs @@ -365,8 +365,8 @@ : indent (ppLines af) -$(deriveJSON defaultOptions ''JSONError) $(deriveJSON defaultOptions ''Expected) $(deriveJSON defaultOptions ''FormatExpected) $(deriveJSON defaultOptions ''Step) +$(deriveJSON defaultOptions ''JSONError) $(SC.deriveSafeCopy 1 'SC.base ''Step) diff --git a/src/Data/API/JSON.hs b/src/Data/API/JSON.hs --- a/src/Data/API/JSON.hs +++ b/src/Data/API/JSON.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE TemplateHaskell #-} -- | This module defines a JSON parser, like Aeson's 'FromJSON', but @@ -64,6 +65,7 @@ ) where import Data.API.Error +import Data.API.JSON.Compat import Data.API.Time import Data.API.Types import Data.API.Utils @@ -77,7 +79,6 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy as BL -import qualified Data.HashMap.Strict as HMap import Data.Maybe import qualified Data.Text as T import qualified Data.Text.Encoding as T @@ -368,7 +369,7 @@ -> JS.Object -> ParserWithErrs a withField k f m = stepInside (InField k) $ modifyTopError treatAsMissing $ f v where - v = fromMaybe JS.Null $ HMap.lookup k m + v = fromMaybe JS.Null $ lookupKey k m treatAsMissing :: JSONError -> JSONError treatAsMissing (Expected _ _ JS.Null) = MissingField @@ -382,15 +383,15 @@ stepInside (InField k) $ modifyTopError treatAsMissing $ withParseFlags foo where foo q | readOnly && enforceReadOnlyFields q = f defVal - | useDefaults q = f $ fromMaybe defVal $ HMap.lookup k m - | otherwise = f $ fromMaybe JS.Null $ HMap.lookup k m + | useDefaults q = f $ fromMaybe defVal $ lookupKey k m + | otherwise = f $ fromMaybe JS.Null $ lookupKey k m defVal = fromMaybe JS.Null mb_defVal -- | Look up the value of a field, failing on missing fields withStrictField :: T.Text -> (JS.Value -> ParserWithErrs a) -> JS.Object -> ParserWithErrs a -withStrictField k f m = stepInside (InField k) $ case HMap.lookup k m of +withStrictField k f m = stepInside (InField k) $ case lookupKey k m of Nothing -> failWith MissingField Just r -> f r @@ -408,7 +409,7 @@ -- to the field name. withUnion :: [(T.Text, JS.Value -> ParserWithErrs a)] -> JS.Value -> ParserWithErrs a withUnion xs (JS.Object hs) = - case HMap.toList hs of + case objectToList hs of [(k, v)] -> case lookup k xs of Just c -> stepInside (InField k) $ c v Nothing -> failWith $ MissingAlt $ map (T.unpack . fst) xs diff --git a/src/Data/API/JSON/Compat.hs b/src/Data/API/JSON/Compat.hs new file mode 100644 --- /dev/null +++ b/src/Data/API/JSON/Compat.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE CPP #-} + +-- | This module provides wrappers for compatibility between versions of @aeson@ +-- prior to and after 2.0. It is not necessarily stable. +-- +module Data.API.JSON.Compat + ( Key + , KeyMap + + , lookupKey + , listToObject + , objectToList + , matchSingletonObject + , singletonObject + , insertKey + , deleteKey + , objectToMap + , mapToObject + , traverseObjectWithKey + , adjustObject + + , fieldNameToKey + , keyToFieldName + , textToKey + , keyToText + ) where + +import Data.API.Types + +import qualified Data.Map.Strict as Map +import qualified Data.Text as T + +#if MIN_VERSION_aeson(2,0,0) + +import Data.Aeson.Key (Key) +import qualified Data.Aeson.Key as Key +import Data.Aeson.KeyMap (KeyMap) +import qualified Data.Aeson.KeyMap as KeyMap + +lookupKey :: T.Text -> KeyMap a -> Maybe a +lookupKey k m = KeyMap.lookup (Key.fromText k) m + +listToObject :: [(T.Text, a)] -> KeyMap a +listToObject = KeyMap.fromList . map (\ (x, y) -> (Key.fromText x, y)) + +objectToList :: KeyMap a -> [(T.Text, a)] +objectToList = map (\ (x, y) -> (Key.toText x, y)) . KeyMap.toList + +matchSingletonObject :: KeyMap a -> Maybe (T.Text, a) +matchSingletonObject km = case objectToList km of + [(k, v)] -> Just (k, v) + _ -> Nothing + +singletonObject :: T.Text -> a -> KeyMap a +singletonObject k = KeyMap.singleton (Key.fromText k) + +insertKey :: T.Text -> a -> KeyMap a -> KeyMap a +insertKey k = KeyMap.insert (Key.fromText k) + +deleteKey :: T.Text -> KeyMap a -> KeyMap a +deleteKey k = KeyMap.delete (Key.fromText k) + +objectToMap :: KeyMap a -> Map.Map T.Text a +objectToMap = KeyMap.toMapText + +mapToObject :: Map.Map T.Text a -> KeyMap a +mapToObject = KeyMap.fromMapText + +traverseObjectWithKey :: Applicative f => (T.Text -> v1 -> f v2) -> KeyMap v1 -> f (KeyMap v2) +traverseObjectWithKey f = KeyMap.traverseWithKey (\ k -> f (Key.toText k)) + +fieldNameToKey :: FieldName -> Key +fieldNameToKey = Key.fromText . _FieldName + +textToKey :: T.Text -> Key +textToKey = Key.fromText + +keyToFieldName :: Key -> FieldName +keyToFieldName = FieldName . Key.toText + +keyToText :: Key -> T.Text +keyToText = Key.toText + +adjustObject :: (v -> v) -> Key -> KeyMap v -> KeyMap v +adjustObject f k m = case KeyMap.lookup k m of + Nothing -> m + Just v -> KeyMap.insert k (f v) m + +#else + +import qualified Data.HashMap.Strict as HMap + +type Key = T.Text + +type KeyMap = HMap.HashMap Key + +lookupKey :: T.Text -> KeyMap a -> Maybe a +lookupKey = HMap.lookup + +listToObject :: [(T.Text, a)] -> KeyMap a +listToObject = HMap.fromList + +objectToList :: KeyMap a -> [(T.Text, a)] +objectToList = HMap.toList + +matchSingletonObject :: KeyMap a -> Maybe (T.Text, a) +matchSingletonObject km = case objectToList km of + [(k, v)] -> Just (k, v) + _ -> Nothing + +singletonObject :: T.Text -> a -> KeyMap a +singletonObject = HMap.singleton + +insertKey :: T.Text -> a -> KeyMap a -> KeyMap a +insertKey = HMap.insert + +deleteKey :: T.Text -> KeyMap a -> KeyMap a +deleteKey = HMap.delete + +objectToMap :: KeyMap a -> Map.Map T.Text a +objectToMap = Map.fromList . HMap.toList + +mapToObject :: Map.Map T.Text a -> KeyMap a +mapToObject = HMap.fromList . Map.toList + +traverseObjectWithKey :: Applicative f => (T.Text -> v1 -> f v2) -> KeyMap v1 -> f (KeyMap v2) +traverseObjectWithKey = HMap.traverseWithKey + +adjustObject :: (v -> v) -> Key -> KeyMap v -> KeyMap v +adjustObject = HMap.adjust + +fieldNameToKey :: FieldName -> Key +fieldNameToKey = _FieldName + +keyToFieldName :: Key -> FieldName +keyToFieldName = FieldName + +textToKey :: T.Text -> Key +textToKey = id + +keyToText :: Key -> T.Text +keyToText = id + +#endif diff --git a/src/Data/API/JSONToCBOR.hs b/src/Data/API/JSONToCBOR.hs --- a/src/Data/API/JSONToCBOR.hs +++ b/src/Data/API/JSONToCBOR.hs @@ -1,4 +1,5 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} module Data.API.JSONToCBOR ( serialiseJSONWithSchema , jsonToCBORWithSchema @@ -8,6 +9,7 @@ import Data.API.Changes import Data.API.JSON +import Data.API.JSON.Compat import Data.API.Time import Data.API.Types import Data.API.Utils @@ -16,7 +18,6 @@ import Data.Aeson hiding (encode) import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy as LBS -import qualified Data.HashMap.Strict as HMap import qualified Data.Map as Map import Data.Traversable import qualified Data.Vector as Vec @@ -36,6 +37,16 @@ -- schema-dependent fashion. This is necessary because the JSON -- representation carries less information than we need in CBOR -- (e.g. it lacks a distinction between bytestrings and text). +-- +-- There is a corner case where this may lose information: if the schema +-- contains a field with type @? json@ (i.e. @'Maybe' 'Value'@), then we have +-- +-- > toJSON Nothing == Null +-- > toJSON (Just Null) == Null +-- +-- so 'serialiseJSONWithSchema' cannot distinguish these values, and will use +-- the CBOR-encoding of 'Nothing' for both. +-- serialiseJSONWithSchema :: API -> TypeName -> Value -> LBS.ByteString serialiseJSONWithSchema api tn v = serialise $ jsonToCBORWithSchema api tn v @@ -73,14 +84,14 @@ Object hm -> TMap $ map (f hm) $ Map.toAscList nrt _ -> error "serialiseJSONWithSchema: expected object" where - f hm (fn, ty) = case HMap.lookup (_FieldName fn) hm of + f hm (fn, ty) = case lookupKey (_FieldName fn) hm of Nothing -> error $ "serialiseJSONWithSchema: missing field " ++ T.unpack (_FieldName fn) Just v' -> (TString (_FieldName fn), jsonToCBORType napi ty v') -- | Encode a union as a single-element map from the field name to the value. jsonToCBORUnion :: NormAPI -> NormUnionType -> Value -> Term jsonToCBORUnion napi nut v = case v of - Object hm | [(k, r)] <- HMap.toList hm -> case Map.lookup (FieldName k) nut of + Object hm | Just (k, r) <- matchSingletonObject hm -> case Map.lookup (FieldName k) nut of Just ty -> TMap [(TString k, jsonToCBORType napi ty r)] Nothing -> error "serialiseJSONWithSchema: unexpected alternative in union" _ -> error "serialiseJSONWithSchema: expected single-field object" @@ -155,9 +166,9 @@ _ -> Left $ JSONError $ expectedArray v TyName tn -> postprocessJSONTypeName napi tn v TyBasic BTutc -> case v of - Object obj -> case HMap.toList obj of - [(k1, Number v0), (km12, Number v1)] - | T.unpack k1 == "1" && T.unpack km12 == "-12" -> + Object obj + | Just (Number v0) <- lookupKey "1" obj + , Just (Number v1) <- lookupKey "-12" obj -> -- Taken from @Codec.Serialise.Class@: let psecs :: Pico psecs = realToFrac v1 / 1000000000000 @@ -166,7 +177,7 @@ dt = realToFrac v0 + realToFrac psecs in pure $! String $! printUTC $! forceUTCTime (posixSecondsToUTCTime dt) - _ -> Left $ JSONError UnexpectedField + | otherwise -> Left $ JSONError (Expected ExpObject "UTCTime" v) String t -> case parseUTC t of Nothing -> Left $ JSONError $ SyntaxError $ "UTC time in wrong format: " ++ T.unpack t @@ -181,15 +192,15 @@ postprocessJSONRecord :: NormAPI -> NormRecordType -> Value -> Either ValueError Value postprocessJSONRecord napi nrt v = case v of - Object hm -> Object <$> HMap.traverseWithKey f hm + Object hm -> Object <$> traverseObjectWithKey f hm _ -> Left $ JSONError $ expectedObject v where - f t v' = do ty <- Map.lookup (FieldName t) nrt ?! JSONError UnexpectedField + f t v' = do ty <- Map.lookup (FieldName t) nrt ?! JSONError MissingField postprocessJSONType napi ty v' postprocessJSONUnion :: NormAPI -> NormUnionType -> Value -> Either ValueError Value postprocessJSONUnion napi nut v = case v of - Object hm | [(k, r)] <- HMap.toList hm + Object hm | Just (k, r) <- matchSingletonObject hm , Just ty <- Map.lookup (FieldName k) nut - -> Object . HMap.singleton k <$> postprocessJSONType napi ty r + -> Object . singletonObject k <$> postprocessJSONType napi ty r _ -> Left $ JSONError $ expectedObject v diff --git a/src/Data/API/TH/Compat.hs b/src/Data/API/TH/Compat.hs --- a/src/Data/API/TH/Compat.hs +++ b/src/Data/API/TH/Compat.hs @@ -3,7 +3,13 @@ import Language.Haskell.TH -mkDataD :: Cxt -> Name -> [TyVarBndr] -> [Con] -> [Name] -> Dec +#if MIN_VERSION_template_haskell(2,17,0) +type TyVarBndr' = TyVarBndr () +#else +type TyVarBndr' = TyVarBndr +#endif + +mkDataD :: Cxt -> Name -> [TyVarBndr'] -> [Con] -> [Name] -> Dec mkDataD cxt1 name tyVarBndrs cons drvs = #if MIN_VERSION_template_haskell(2,12,0) DataD cxt1 name tyVarBndrs Nothing cons [DerivClause Nothing (map ConT drvs)] @@ -21,7 +27,7 @@ InstanceD #endif -mkNewtypeD :: Cxt -> Name -> [TyVarBndr] -> Con -> [Name] -> Dec +mkNewtypeD :: Cxt -> Name -> [TyVarBndr'] -> Con -> [Name] -> Dec mkNewtypeD cxt1 name tyVarBndrs cons drvs = #if MIN_VERSION_template_haskell(2,12,0) NewtypeD cxt1 name tyVarBndrs Nothing cons [DerivClause Nothing (map ConT drvs)] diff --git a/src/Data/API/Tools/JSON.hs b/src/Data/API/Tools/JSON.hs --- a/src/Data/API/Tools/JSON.hs +++ b/src/Data/API/Tools/JSON.hs @@ -17,7 +17,6 @@ import Data.Aeson hiding (withText, withBool) import Control.Applicative -import qualified Data.HashMap.Strict as HMap import Data.Maybe import qualified Data.Map as Map import Data.Monoid @@ -133,7 +132,7 @@ v .: "Input" <*> v .: "Output" <*> v .: "PipelineId" - parseJSONWithErrs Null = parseJSONWithErrs (Object HMap.empty) + parseJSONWithErrs Null = parseJSONWithErrs (Object mempty) parseJSONWithErrs v = failWith $ expectedObject val -} @@ -150,7 +149,7 @@ where ro = ftReadOnly ft mb_dv = ftDefault ft - clNull = clause [conP 'Null []] (normalB [e| parseJSONWithErrs (Object HMap.empty) |]) [] + clNull = clause [conP 'Null []] (normalB [e| parseJSONWithErrs (Object mempty) |]) [] cl' x = clause [varP x] (normalB (bdy' x)) [] bdy' x = [e| failWith (expectedObject $(varE x)) |] diff --git a/src/Data/API/Types.hs b/src/Data/API/Types.hs --- a/src/Data/API/Types.hs +++ b/src/Data/API/Types.hs @@ -358,20 +358,44 @@ liftTyped (APINode a b c d e) = [e|| APINode a b $$(liftTypedPrefix c) d e ||] #endif + +#if MIN_VERSION_template_haskell(2,17,0) +liftPrefix :: Quote m => Prefix -> m Exp +liftText :: Quote m => T.Text -> m Exp +liftUTC :: Quote m => UTCTime -> m Exp +liftMaybeUTCTime :: Quote m => Maybe UTCTime -> m Exp +#else liftPrefix :: Prefix -> ExpQ +liftText :: T.Text -> ExpQ +liftUTC :: UTCTime -> ExpQ +liftMaybeUTCTime :: Maybe UTCTime -> ExpQ +#endif + liftPrefix ci = let s = CI.original ci in [e| CI.mk s |] -liftText :: T.Text -> ExpQ liftText s = [e| T.pack $(litE (stringL (T.unpack s))) |] -liftUTC :: UTCTime -> ExpQ liftUTC u = [e| unsafeParseUTC $(liftText (printUTC u)) |] -liftMaybeUTCTime :: Maybe UTCTime -> ExpQ liftMaybeUTCTime Nothing = [e| Nothing |] liftMaybeUTCTime (Just u) = [e| Just $(liftUTC u) |] -#if MIN_VERSION_template_haskell(2,16,0) + + +#if MIN_VERSION_template_haskell(2,17,0) +liftTypedPrefix :: Quote m => Prefix -> Code m Prefix +liftTypedPrefix ci = let s = CI.original ci in [e|| CI.mk s ||] + +liftTypedText :: Quote m => T.Text -> Code m T.Text +liftTypedText s = [e|| T.pack $$(liftTyped (T.unpack s)) ||] + +liftTypedUTC :: Quote m => UTCTime -> Code m UTCTime +liftTypedUTC u = [e|| unsafeParseUTC $$(liftTypedText (printUTC u)) ||] + +liftTypedMaybeUTCTime :: Quote m => Maybe UTCTime -> Code m (Maybe UTCTime) +liftTypedMaybeUTCTime Nothing = [e|| Nothing ||] +liftTypedMaybeUTCTime (Just u) = [e|| Just $$(liftTypedUTC u) ||] +#elif MIN_VERSION_template_haskell(2,16,0) liftTypedPrefix :: Prefix -> TExpQ Prefix liftTypedPrefix ci = let s = CI.original ci in [e|| CI.mk s ||] @@ -429,20 +453,22 @@ $(deriveSafeCopy 0 'base ''Binary) -$(deriveJSON defaultOptions ''Thing) -$(deriveJSON defaultOptions ''APINode) -$(deriveJSON defaultOptions ''TypeName) -$(deriveJSON defaultOptions ''FieldName) -$(deriveJSON defaultOptions ''Spec) -$(deriveJSON defaultOptions ''APIType) -$(deriveJSON defaultOptions ''DefaultValue) -$(deriveJSON defaultOptions ''SpecEnum) -$(deriveJSON defaultOptions ''SpecUnion) -$(deriveJSON defaultOptions ''SpecRecord) -$(deriveJSON defaultOptions ''FieldType) -$(deriveJSON defaultOptions ''SpecNewtype) -$(deriveJSON defaultOptions ''Filter) -$(deriveJSON defaultOptions ''IntRange) -$(deriveJSON defaultOptions ''UTCRange) -$(deriveJSON defaultOptions ''BasicType) -$(deriveJSON defaultOptions ''CI.CI) +$(let deriveJSONs = fmap concat . mapM (deriveJSON defaultOptions) + in deriveJSONs [ ''CI.CI + , ''TypeName + , ''FieldName + , ''DefaultValue + , ''SpecEnum + , ''SpecUnion + , ''SpecRecord + , ''FieldType + , ''SpecNewtype + , ''Filter + , ''IntRange + , ''UTCRange + , ''BasicType + , ''APIType + , ''Spec + , ''APINode + , ''Thing + ]) diff --git a/src/Data/API/Value.hs b/src/Data/API/Value.hs --- a/src/Data/API/Value.hs +++ b/src/Data/API/Value.hs @@ -46,6 +46,7 @@ import Data.API.Error import Data.API.JSON +import Data.API.JSON.Compat import Data.API.NormalForm import Data.API.Time import Data.API.Types @@ -61,7 +62,6 @@ import Data.Binary.Serialise.CBOR.Extra import qualified Codec.CBOR.FlatTerm as CBOR import Data.Binary.Serialise.CBOR.JSON -import qualified Data.HashMap.Strict as HMap import Data.List (sortBy) import qualified Data.Map.Strict as Map import Data.Monoid @@ -174,9 +174,9 @@ List vs -> JS.toJSON vs Maybe Nothing -> JS.Null Maybe (Just v) -> JS.toJSON v - Union fn v -> JS.object [_FieldName fn JS..= v] + Union fn v -> JS.object [fieldNameToKey fn JS..= v] Enum fn -> JS.String (_FieldName fn) - Record xs -> JS.object $ map (\ (Field fn v) -> _FieldName fn JS..= v) xs + Record xs -> JS.object $ map (\ (Field fn v) -> fieldNameToKey fn JS..= v) xs JSON js -> js -- | Parse a generic 'Value' from a JSON 'JS.Value', given the schema @@ -403,7 +403,7 @@ arbitraryJSONValue :: QC.Gen JS.Value arbitraryJSONValue = QC.sized $ \ size -> - QC.oneof [ JS.Object . HMap.fromList <$> QC.resize (size `div` 2) (QC.listOf ((,) <$> QC.arbitrary <*> arbitraryJSONValue)) + QC.oneof [ JS.Object . listToObject <$> QC.resize (size `div` 2) (QC.listOf ((,) <$> QC.arbitrary <*> arbitraryJSONValue)) , JS.Array . V.fromList <$> QC.resize (size `div` 2) (QC.listOf arbitraryJSONValue) , JS.String <$> QC.arbitrary , JS.Number . fromInteger <$> QC.arbitrary diff --git a/src/Data/Binary/Serialise/CBOR/JSON.hs b/src/Data/Binary/Serialise/CBOR/JSON.hs --- a/src/Data/Binary/Serialise/CBOR/JSON.hs +++ b/src/Data/Binary/Serialise/CBOR/JSON.hs @@ -6,10 +6,11 @@ decodeJSON, ) where +import Data.API.JSON.Compat + import qualified Data.Aeson as JSON import qualified Data.Scientific as Scientific import qualified Data.Vector as Vec -import qualified Data.HashMap.Strict as HashMap import Data.Text (Text) import qualified Data.Text as Text @@ -81,7 +82,7 @@ -- integers into strings containing their decimal representation); -- however, doing so introduces a danger of key collision. -cborToJson (TMap kvs) = JSON.object [ (cborToJsonString k, cborToJson v) +cborToJson (TMap kvs) = JSON.object [ (textToKey (cborToJsonString k), cborToJson v) | (k, v) <- kvs ] -- o False (major type 7, additional information 20) becomes a JSON false. @@ -170,7 +171,7 @@ jsonToCbor :: JSON.Value -> CBOR.Term jsonToCbor (JSON.Object kvs) = CBOR.TMap [ (CBOR.TString k, jsonToCbor v) - | (k, v) <- HashMap.toList kvs ] + | (k, v) <- objectToList kvs ] jsonToCbor (JSON.Array vs) = CBOR.TList [ jsonToCbor v | v <- Vec.toList vs ] jsonToCbor (JSON.String str) = CBOR.TString str jsonToCbor (JSON.Number n) = case Scientific.floatingOrInteger n of diff --git a/src/Text/Regex.hs b/src/Text/Regex.hs new file mode 100644 --- /dev/null +++ b/src/Text/Regex.hs @@ -0,0 +1,82 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +----------------------------------------------------------------------------- +-- | +-- Module : Text.Regex +-- Copyright : (c) Chris Kuklewicz 2006, (c) shelarcy 2012, derived from (c) The University of Glasgow 2001 +-- License : BSD-style (see the file LICENSE) +-- +-- Maintainer : libraries@haskell.org +-- Stability : experimental +-- Portability : non-portable (regex-base needs MPTC+FD) +-- +-- Regular expression matching. Uses the POSIX regular expression +-- interface in "Text.Regex.TDFA". +-- +--------------------------------------------------------------------------- + +-- +-- Modified by Chris Kuklewicz to be a thin layer over the regex-posix +-- package, and moved into a regex-compat package. +-- +-- Modified by Adam Gundry to contain only the functions needed for api-tools. +-- +module Text.Regex ( + -- * Regular expressions + Regex, + mkRegex, + mkRegexWithOpts, + matchRegex, + matchRegexAll + ) where + +import Text.Regex.Base(RegexMaker(makeRegexOpts),defaultCompOpt,defaultExecOpt,RegexContext(matchM)) +import Text.Regex.TDFA(Regex,caseSensitive,multiline,newSyntax) + +-- | Makes a regular expression with the default options (multi-line, +-- case-sensitive). The syntax of regular expressions is +-- otherwise that of @egrep@ (i.e. POSIX \"extended\" regular +-- expressions). +mkRegex :: String -> Regex +mkRegex s = makeRegexOpts opt defaultExecOpt s + where opt = defaultCompOpt { newSyntax = True, multiline = True } + +-- | Makes a regular expression, where the multi-line and +-- case-sensitive options can be changed from the default settings. +mkRegexWithOpts + :: String -- ^ The regular expression to compile + -> Bool -- ^ 'True' @\<=>@ @\'^\'@ and @\'$\'@ match the beginning and + -- end of individual lines respectively, and @\'.\'@ does /not/ + -- match the newline character. + -> Bool -- ^ 'True' @\<=>@ matching is case-sensitive + -> Regex -- ^ Returns: the compiled regular expression + +mkRegexWithOpts s single_line case_sensitive + = let opt = defaultCompOpt + { multiline = (if single_line then True else False) + , caseSensitive = (if case_sensitive then True else False) + , newSyntax = True } + in makeRegexOpts opt defaultExecOpt s + +-- | Match a regular expression against a string +matchRegex + :: Regex -- ^ The regular expression + -> String -- ^ The string to match against + -> Maybe [String] -- ^ Returns: @'Just' strs@ if the match succeeded + -- (and @strs@ is the list of subexpression matches), + -- or 'Nothing' otherwise. +matchRegex p str = fmap (\(_,_,_,str) -> str) (matchRegexAll p str) + +-- | Match a regular expression against a string, returning more information +-- about the match. +matchRegexAll + :: Regex -- ^ The regular expression + -> String -- ^ The string to match against + -> Maybe ( String, String, String, [String] ) + -- ^ Returns: 'Nothing' if the match failed, or: + -- + -- > Just ( everything before match, + -- > portion matched, + -- > everything after the match, + -- > subexpression matches ) + +matchRegexAll p str = matchM p str diff --git a/tests/Data/API/Test/DSL.hs b/tests/Data/API/Test/DSL.hs --- a/tests/Data/API/Test/DSL.hs +++ b/tests/Data/API/Test/DSL.hs @@ -118,7 +118,10 @@ mt :: MaybeThing = record - thing :: ? JSON + thing :: JSON // This used to be ? JSON but aeson doesn't round-trip for Maybe Value, + // so prop_jsonToCBOR can be violated. There doesn't seem to be a good + // solution for this other than disabling the test. If a field in the schema + // has type ? json then storing Just Null in it may get read back as Nothing.i nu :: NewUnion = union diff --git a/tests/Data/API/Test/Gen.hs b/tests/Data/API/Test/Gen.hs --- a/tests/Data/API/Test/Gen.hs +++ b/tests/Data/API/Test/Gen.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE OverloadedStrings #-} @@ -13,7 +14,9 @@ import Data.API.Tools import Data.API.Tools.Datatypes import Data.API.Tools.Example +#if !MIN_VERSION_aeson(2,0,3) import Data.API.Value ( arbitraryJSONValue ) +#endif import Control.Applicative import qualified Control.Monad.Fail as Fail @@ -117,8 +120,10 @@ -- | These instances are required by the generated code, but we don't -- really want to force them on clients of the library, so just define -- orphans here. +#if !MIN_VERSION_aeson(2,0,3) instance Arbitrary JS.Value where arbitrary = arbitraryJSONValue +#endif instance SafeCopy JS.Value where getCopy = error "Not implemented" diff --git a/tests/Data/API/Test/JSON.hs b/tests/Data/API/Test/JSON.hs --- a/tests/Data/API/Test/JSON.hs +++ b/tests/Data/API/Test/JSON.hs @@ -20,7 +20,6 @@ import qualified Data.API.Value as Value import qualified Data.Aeson as JS -import qualified Data.HashMap.Strict as HMap import Test.Tasty import Test.Tasty.HUnit @@ -49,7 +48,7 @@ , help (JS.Number 2) True False , help (JS.String "0") False False , help (JS.String "1") True False - , help (JS.Object (HMap.singleton "id" (JS.Number 3))) + , help (JS.object ["id" JS..= JS.Number 3]) (Recursive (Id 3) Nothing) True , help' noFilter (JS.Number 0) (UnsafeMkFilteredInt 0) True @@ -73,7 +72,7 @@ [(SyntaxError "not enough input", [])] #endif , help "object for int" "{}" (proxy :: Int) - [(Expected ExpInt "Int" (JS.Object HMap.empty), [])] + [(Expected ExpInt "Int" (JS.Object mempty), [])] , help "missing alt" "{}" (proxy :: AUnion) [(MissingAlt ["bar"], [])] , help "error inside alt" "{\"bar\": {}}" (proxy :: AUnion) diff --git a/tests/Data/API/Test/Migration.hs b/tests/Data/API/Test/Migration.hs --- a/tests/Data/API/Test/Migration.hs +++ b/tests/Data/API/Test/Migration.hs @@ -1,8 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DeriveDataTypeable #-} -{-# OPTIONS_GHC -XNoCPP -fno-warn-unused-binds #-} +{-# OPTIONS_GHC -fno-warn-unused-binds #-} module Data.API.Test.Migration ( migrationTests @@ -23,7 +24,6 @@ import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy.Char8 as BL -import qualified Data.HashMap.Strict as HMap import qualified Data.Map as Map import qualified Data.Text as T import qualified Data.Text.Encoding as TE @@ -32,6 +32,12 @@ import qualified Test.Tasty.HUnit as HUnit import qualified Test.Tasty.QuickCheck as QC import Test.QuickCheck.Property as P + +#if MIN_VERSION_aeson(2,0,0) +import qualified Data.Aeson.KeyMap as HMap +#else +import qualified Data.HashMap.Strict as HMap +#endif $(generateMigrationKinds changelog "TestDatabaseMigration" "TestRecordMigration" "TestFieldMigration")