diff --git a/src/Data/API/API.hs b/src/Data/API/API.hs index fb8a114..f707d1a 100644 --- a/src/Data/API/API.hs +++ b/src/Data/API/API.hs @@ -101,6 +101,7 @@ convert_type :: APIType -> D.APIType convert_type ty0 = case ty0 of TyList ty -> D.TY_list $ convert_type ty + TySet ty -> D.TY_set $ convert_type ty TyMaybe ty -> D.TY_maybe $ convert_type ty TyName tn -> D.TY_ref $ convert_ref tn TyBasic bt -> D.TY_basic $ convert_basic bt @@ -120,6 +121,7 @@ convert_basic bt = convert_default :: DefaultValue -> D.DefaultValue convert_default DefValList = D.DV_list 0 +convert_default DefValSet = D.DV_set 0 convert_default DefValMaybe = D.DV_maybe 0 convert_default (DefValString s) = D.DV_string s convert_default (DefValBool b) = D.DV_boolean b @@ -201,6 +203,7 @@ unconvert_type :: D.APIType -> APIType unconvert_type ty0 = case ty0 of D.TY_list ty -> TyList $ unconvert_type ty + D.TY_set ty -> TySet $ unconvert_type ty D.TY_maybe ty -> TyMaybe $ unconvert_type ty D.TY_ref r -> TyName $ unconvert_ref r D.TY_basic bt -> TyBasic $ unconvert_basic bt @@ -220,6 +223,7 @@ unconvert_basic bt = unconvert_default :: D.DefaultValue -> DefaultValue unconvert_default (D.DV_list _) = DefValList +unconvert_default (D.DV_set _) = DefValSet unconvert_default (D.DV_maybe _) = DefValMaybe unconvert_default (D.DV_string s) = DefValString s unconvert_default (D.DV_boolean b) = DefValBool b diff --git a/src/Data/API/API/DSL.hs b/src/Data/API/API/DSL.hs index e94fee1..3d88dc2 100644 --- a/src/Data/API/API/DSL.hs +++ b/src/Data/API/API/DSL.hs @@ -128,6 +128,7 @@ ty :: APIType // one of the following: = union | list :: APIType // a JSON list of the given type + | set :: APIType // a JSON set-like of the given type (ordering not guaranteed) | maybe :: APIType // either the given type or the null value | ref :: TypeRef // a named type (node) with possible example | 'basic':: BasicType // a basic JSON type @@ -152,6 +153,7 @@ dv :: DefaultValue // a default value = union | 'list' :: integer + | 'set' :: integer | 'maybe' :: integer | 'string' :: string | 'boolean' :: boolean diff --git a/src/Data/API/Changes.hs b/src/Data/API/Changes.hs index 4d16dbd..8f41233 100644 --- a/src/Data/API/Changes.hs +++ b/src/Data/API/Changes.hs @@ -290,6 +290,7 @@ findUpdatePos tname api = Map.alter (Just . UpdateHere) tname $ findType :: APIType -> Maybe UpdateTypePos findType (TyList ty) = UpdateList <$> findType ty + findType (TySet ty) = UpdateSet <$> findType ty findType (TyMaybe ty) = UpdateMaybe <$> findType ty findType (TyName tname') | tname' == tname || tname' `Set.member` deps = Just $ UpdateNamed tname' @@ -571,6 +572,7 @@ updateTypeAt :: Map TypeName UpdateDeclPos -> UpdateTypePos -> JS.Value -> Position -> Either (ValueError, Position) JS.Value updateTypeAt upds alter (UpdateList upd) v p = withArrayElems (updateTypeAt upds alter upd) v p +updateTypeAt upds alter (UpdateSet upd) v p = withArrayElems (updateTypeAt upds alter upd) v p updateTypeAt upds alter (UpdateMaybe upd) v p = withMaybe (updateTypeAt upds alter upd) v p updateTypeAt upds alter (UpdateNamed tname) v p = case Map.lookup tname upds of Just upd -> updateDeclAt upds alter upd v p @@ -679,6 +681,10 @@ updateTypeAt' :: Map TypeName UpdateDeclPos updateTypeAt' upds alter (UpdateList upd) v p = do xs <- expectList v p List <$!> mapM (\ (i, v') -> updateTypeAt' upds alter upd v' (InElem i : p)) (zip [0..] xs) +updateTypeAt' upds alter (UpdateSet upd) v p = do + xs <- expectSet v p + Set . Set.fromDistinctAscList <$!> + mapM (\ (i, v') -> updateTypeAt' upds alter upd v' (InElem i : p)) (zip [0..] xs) updateTypeAt' upds alter (UpdateMaybe upd) v p = do mb <- expectMaybe v p case mb of @@ -806,6 +812,7 @@ compatibleDefaultValue api ty dv = isJust (fromDefaultValue api ty dv) -- have access to the entire API. defaultValueForType :: APIType -> Maybe DefaultValue defaultValueForType (TyList _) = Just DefValList +defaultValueForType (TySet _) = Just DefValSet defaultValueForType (TyMaybe _) = Just DefValMaybe defaultValueForType _ = Nothing @@ -835,6 +842,7 @@ dataMatchesNormAPI root api db = void $ valueMatches (TyName root) db [] valueMatches :: APIType -> JS.Value -> Position -> Either (ValueError, Position) JS.Value valueMatches (TyList t) = withArrayElems (valueMatches t) + valueMatches (TySet t) = withArrayElems (valueMatches t) valueMatches (TyMaybe t) = withMaybe (valueMatches t) valueMatches (TyName tname) = \ v p -> do d <- lookupType tname api ?!? (\ f -> (InvalidAPI f, p)) diff --git a/src/Data/API/Changes/Types.hs b/src/Data/API/Changes/Types.hs index e258205..d0f653d 100644 --- a/src/Data/API/Changes/Types.hs +++ b/src/Data/API/Changes/Types.hs @@ -129,6 +129,7 @@ data UpdateDeclPos -- | Represents the positions in a type to apply an update data UpdateTypePos = UpdateList UpdateTypePos + | UpdateSet UpdateTypePos | UpdateMaybe UpdateTypePos | UpdateNamed TypeName deriving (Eq, Show) diff --git a/src/Data/API/Doc/Types.hs b/src/Data/API/Doc/Types.hs index e142b81..673b41f 100644 --- a/src/Data/API/Doc/Types.hs +++ b/src/Data/API/Doc/Types.hs @@ -103,6 +103,7 @@ renderBodyType _ (OtherBody s) = s renderAPIType :: DocInfo -> APIType -> String renderAPIType di (TyList ty ) = "[" ++ renderAPIType di ty ++ "]" +renderAPIType di (TySet ty ) = "{" ++ renderAPIType di ty ++ "}" renderAPIType di (TyMaybe ty ) = "?" ++ renderAPIType di ty renderAPIType di (TyName tn ) = mk_link (doc_info_type_url di tn) (T.unpack (_TypeName tn)) renderAPIType _ (TyBasic bt ) = pp bt diff --git a/src/Data/API/Error.hs b/src/Data/API/Error.hs index 358ca2a..832a569 100644 --- a/src/Data/API/Error.hs +++ b/src/Data/API/Error.hs @@ -1,6 +1,8 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE DefaultSignatures #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE TemplateHaskell #-} module Data.API.Error @@ -18,6 +20,7 @@ module Data.API.Error -- * JSON parse error construction , expectedArray + , expectedSet , expectedBool , expectedInt , expectedObject @@ -56,7 +59,6 @@ import qualified Data.Set as Set import qualified Data.Text as T import Data.Time - ---------------------------------------------------------- -- Representation of JSON parsing errors and positions -- @@ -92,13 +94,14 @@ data FormatExpected = FmtBinary | FmtOther deriving (Eq, Show) -expectedArray, expectedBool, expectedInt, expectedObject, expectedString +expectedArray, expectedSet, expectedBool, expectedInt, expectedObject, expectedString :: JS.Value -> JSONError expectedArray = Expected ExpArray "Array" expectedBool = Expected ExpBool "Bool" expectedInt = Expected ExpInt "Int" expectedObject = Expected ExpObject "Object" expectedString = Expected ExpString "String" +expectedSet = Expected ExpObject "Set" badFormat :: String -> T.Text -> JSONError badFormat = BadFormat FmtOther diff --git a/src/Data/API/JSON.hs b/src/Data/API/JSON.hs index 269abb1..35b93fa 100644 --- a/src/Data/API/JSON.hs +++ b/src/Data/API/JSON.hs @@ -76,10 +76,12 @@ import qualified Data.Aeson as JS import qualified Data.Aeson.Parser as JS import qualified Data.Aeson.Types as JS import Data.Attoparsec.ByteString +import Data.Binary.Serialise.CBOR.JSON import qualified Data.ByteString.Char8 as B import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Lazy as BL import Data.Maybe +import qualified Data.Set as Set import qualified Data.Text as T import qualified Data.Text.Encoding as T import Data.Time @@ -206,6 +208,15 @@ instance FromJSONWithErrs a => FromJSONWithErrs [a] where parseJSONWithErrs JS.Null = pure [] parseJSONWithErrs v = failWith $ expectedArray v +instance (Ord a, FromJSONWithErrs a) => FromJSONWithErrs (Set.Set a) where + parseJSONWithErrs v@(JS.Object kvs) = case jsonParseCborSet kvs of + Nothing -> failWith $ expectedSet v + Just xs -> fmap Set.fromList <$> traverse help $ zip (V.toList xs) [0..] + where + help (x, i) = stepInside (InElem i) $ parseJSONWithErrs x + parseJSONWithErrs JS.Null = pure mempty + parseJSONWithErrs v = failWith $ expectedArray v + instance FromJSONWithErrs Int where parseJSONWithErrs = withInt "Int" pure diff --git a/src/Data/API/JSONToCBOR.hs b/src/Data/API/JSONToCBOR.hs index 0028700..4c2a7b2 100644 --- a/src/Data/API/JSONToCBOR.hs +++ b/src/Data/API/JSONToCBOR.hs @@ -1,5 +1,6 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} module Data.API.JSONToCBOR ( serialiseJSONWithSchema , jsonToCBORWithSchema @@ -13,6 +14,7 @@ import Data.API.JSON.Compat import Data.API.Time import Data.API.Types import Data.API.Utils +import Data.Binary.Serialise.CBOR.Extra import Control.Applicative import Data.Aeson hiding (encode) @@ -32,7 +34,6 @@ import Data.Time.Clock.POSIX import Data.Time (UTCTime(UTCTime)) import Prelude - -- | Serialise a JSON value as a CBOR term in a generic but -- schema-dependent fashion. This is necessary because the JSON -- representation carries less information than we need in CBOR @@ -70,6 +71,9 @@ jsonToCBORType :: NormAPI -> APIType -> Value -> Term jsonToCBORType napi ty0 v = case (ty0, v) of (TyList ty, Array arr) | Vec.null arr -> TList [] | otherwise -> TListI $ map (jsonToCBORType napi ty) (Vec.toList arr) + (TySet ty, Array arr) | Vec.null arr -> TSetI $ [] + | otherwise -> TSetI $ map (jsonToCBORType napi ty) (Vec.toList arr) + (TySet _, _) -> error "serialiseJSONWithSchema: TySet, expected array" (TyList _ , _) -> error "serialiseJSONWithSchema: expected array" (TyMaybe _ , Null) -> TList [] (TyMaybe ty, _) -> TList [jsonToCBORType napi ty v] @@ -158,6 +162,9 @@ postprocessJSONType napi ty0 v = case ty0 of TyList ty -> case v of Array arr -> Array <$> traverse (postprocessJSONType napi ty) arr _ -> Left $ JSONError $ expectedArray v + TySet ty -> case v of + Array arr -> Array <$> traverse (postprocessJSONType napi ty) arr + _ -> Left $ JSONError $ expectedArray v TyMaybe ty -> case v of Array arr -> case Vec.toList arr of [] -> pure Null diff --git a/src/Data/API/Markdown.hs b/src/Data/API/Markdown.hs index 1809763..50805cc 100644 --- a/src/Data/API/Markdown.hs +++ b/src/Data/API/Markdown.hs @@ -196,6 +196,7 @@ default_value :: DefaultValue -> MDComment default_value dv = case dv of DefValList -> "[]" + DefValSet -> "{}" DefValMaybe -> "null" DefValString t -> show t DefValBool b -> map toLower $ show b @@ -206,6 +207,7 @@ type_md :: MarkdownMethods -> APIType -> MDComment type_md mdm ty = case ty of TyList ty' -> "[" ++ type_md mdm ty' ++ "]" + TySet ty' -> "{" ++ type_md mdm ty' ++ "}" TyMaybe ty' -> "? " ++ type_md mdm ty' TyName nm -> mdmLink mdm nm TyBasic bt -> basic_type_md bt diff --git a/src/Data/API/NormalForm.hs b/src/Data/API/NormalForm.hs index 00da053..e8e871c 100644 --- a/src/Data/API/NormalForm.hs +++ b/src/Data/API/NormalForm.hs @@ -124,6 +124,7 @@ typeDeclFreeVars (NNewtype _) = Set.empty -- | Find the set of type names used in an type typeFreeVars :: APIType -> Set TypeName typeFreeVars (TyList t) = typeFreeVars t +typeFreeVars (TySet t) = typeFreeVars t typeFreeVars (TyMaybe t) = typeFreeVars t typeFreeVars (TyName n) = Set.singleton n typeFreeVars (TyBasic _) = Set.empty @@ -223,6 +224,7 @@ substTypeDecl _ d@(NNewtype _) = d -- | Substitute types for type names in a type substType :: (TypeName -> APIType) -> APIType -> APIType substType f (TyList t) = TyList (substType f t) +substType f (TySet t) = TySet (substType f t) substType f (TyMaybe t) = TyMaybe (substType f t) substType f (TyName n) = f n substType _ t@(TyBasic _) = t diff --git a/src/Data/API/PP.hs b/src/Data/API/PP.hs index 722912b..f804c22 100644 --- a/src/Data/API/PP.hs +++ b/src/Data/API/PP.hs @@ -62,6 +62,7 @@ instance PP FieldName where instance PP APIType where pp (TyList ty) = "[" ++ pp ty ++ "]" + pp (TySet ty) = "{" ++ pp ty ++ "}" pp (TyMaybe ty) = "? " ++ pp ty pp (TyName t) = pp t pp (TyBasic b) = pp b @@ -76,6 +77,7 @@ instance PP BasicType where instance PP DefaultValue where pp DefValList = "[]" + pp DefValSet = "{}" pp DefValMaybe = "nothing" pp (DefValString t) = show t pp (DefValBool True) = "true" diff --git a/src/Data/API/Parse.y b/src/Data/API/Parse.y index 8b49c40..04ad2e7 100644 --- a/src/Data/API/Parse.y +++ b/src/Data/API/Parse.y @@ -37,6 +37,8 @@ import Text.Regex '|' { (,) _ Bar } '[' { (,) _ Bra } ']' { (,) _ Ket } + '{' { (,) _ Cu } + '}' { (,) _ Rly } '::' { (,) _ ColCol } '=' { (,) _ Equals } '?' { (,) _ Query } @@ -188,6 +190,7 @@ Type :: { APIType } Type : '?' Type { TyMaybe $2 } | '[' Type ']' { TyList $2 } + | '{' Type '}' { TySet $2 } | TypeName { TyName $1 } | BasicType { TyBasic $1 } | json { TyJSON } @@ -265,6 +268,7 @@ MbDefaultValue :: { Maybe DefaultValue } DefaultValue :: { DefaultValue } : '[' ']' { DefValList } + | '{' '}' { DefValSet } | nothing { DefValMaybe } | strlit { DefValString (T.pack $1) } | true { DefValBool True } diff --git a/src/Data/API/Scan.x b/src/Data/API/Scan.x index 7d73ec7..7e225dc 100644 --- a/src/Data/API/Scan.x +++ b/src/Data/API/Scan.x @@ -37,6 +37,8 @@ tokens :- "|" { simple Bar } "[" { simple Bra } "]" { simple Ket } + "{" { simple Cu } + "}" { simple Rly } "::" { simple ColCol } ":" { simple Colon } "=" { simple Equals } @@ -98,6 +100,8 @@ data Token | BInary | Bra | Ket + | Cu + | Rly | ColCol | Colon | Comma diff --git a/src/Data/API/Tools/Datatypes.hs b/src/Data/API/Tools/Datatypes.hs index ad6cb0b..c1f61f9 100644 --- a/src/Data/API/Tools/Datatypes.hs +++ b/src/Data/API/Tools/Datatypes.hs @@ -27,6 +27,7 @@ import qualified Data.CaseInsensitive as CI import Data.Char import Data.Maybe import Data.String +import Data.Set (Set) import qualified Data.Text as T import Data.Time import Data.Typeable @@ -147,6 +148,7 @@ mk_type :: APIType -> Type mk_type ty = case ty of TyList ty' -> AppT ListT $ mk_type ty' + TySet ty' -> AppT (ConT ''Set) $ mk_type ty' TyMaybe ty' -> AppT (ConT ''Maybe) $ mk_type ty' TyName nm -> ConT $ mkNameText $ _TypeName nm TyBasic bt -> basic_type bt diff --git a/src/Data/API/Tools/Example.hs b/src/Data/API/Tools/Example.hs index e087675..b830bba 100644 --- a/src/Data/API/Tools/Example.hs +++ b/src/Data/API/Tools/Example.hs @@ -22,6 +22,7 @@ import Data.Monoid import Data.Time import Language.Haskell.TH import Test.QuickCheck as QC +import qualified Data.Set as Set import qualified Data.Text as T import Prelude @@ -42,6 +43,9 @@ instance Example a => Example (Maybe a) where instance Example a => Example [a] where example = listOf example +instance (Ord a, Example a) => Example (Set.Set a) where + example = Set.fromList <$> listOf example + instance Example Int where example = arbitrarySizedBoundedIntegral `suchThat` (> 0) diff --git a/src/Data/API/Tools/Traversal.hs b/src/Data/API/Tools/Traversal.hs index 91cd5fc..43567b4 100644 --- a/src/Data/API/Tools/Traversal.hs +++ b/src/Data/API/Tools/Traversal.hs @@ -75,6 +75,7 @@ traverser napi targets x ty = fromMaybe [| const pure |] $ traverser' napi targe -- or return 'Nothing' if there are no substructures to traverse traverser' :: NormAPI -> Set.Set TypeName -> TypeName -> APIType -> Maybe ExpQ traverser' napi targets x (TyList ty) = fmap (appE [e|(.) traverse|]) $ traverser' napi targets x ty +traverser' napi targets x (TySet ty) = fmap (appE [e|(.) traverse|]) $ traverser' napi targets x ty traverser' napi targets x (TyMaybe ty) = fmap (appE [e|(.) traverse|]) $ traverser' napi targets x ty traverser' napi targets x (TyName tn) | tn == x = Just [e| id |] diff --git a/src/Data/API/Types.hs b/src/Data/API/Types.hs index 6bf41fb..9c66fd2 100644 --- a/src/Data/API/Types.hs +++ b/src/Data/API/Types.hs @@ -42,9 +42,10 @@ import Control.DeepSeq import qualified Data.CaseInsensitive as CI import Data.String import Data.Time -import Data.Aeson +import Data.Aeson as JS import Data.Aeson.Types import Data.Aeson.TH +import Data.Binary.Serialise.CBOR.Extra import qualified Codec.Serialise as CBOR import Data.Maybe import Data.SafeCopy @@ -264,6 +265,7 @@ type Conversion = Maybe (FieldName,FieldName) -- | Type is either a list, Maybe, a named element of the API or a basic type data APIType = TyList APIType -- ^ list elements are types + | TySet APIType -- ^ set elements are types | TyMaybe APIType -- ^ Maybe elements are types | TyName TypeName -- ^ the referenced type must be defined by the API | TyBasic BasicType -- ^ a JSON string, int, bool etc. @@ -276,6 +278,7 @@ instance IsString APIType where instance NFData APIType where rnf (TyList ty) = rnf ty + rnf (TySet ty) = rnf ty rnf (TyMaybe ty) = rnf ty rnf (TyName tn) = rnf tn rnf (TyBasic bt) = rnf bt @@ -296,6 +299,7 @@ instance NFData BasicType where -- | A default value for a field data DefaultValue = DefValList + | DefValSet | DefValMaybe | DefValString T.Text -- used for binary fields (base64 encoded) | DefValBool Bool @@ -305,6 +309,7 @@ data DefaultValue instance NFData DefaultValue where rnf DefValList = () + rnf DefValSet = () rnf DefValMaybe = () rnf (DefValString t) = rnf t rnf (DefValBool b) = rnf b @@ -316,6 +321,7 @@ instance NFData DefaultValue where -- values are turned into strings. defaultValueAsJsValue :: DefaultValue -> Value defaultValueAsJsValue DefValList = toJSON ([] :: [()]) +defaultValueAsJsValue DefValSet = JSONCBORSet [toJSON ()] defaultValueAsJsValue DefValMaybe = Null defaultValueAsJsValue (DefValString s) = String s defaultValueAsJsValue (DefValBool b) = Bool b @@ -436,6 +442,7 @@ instance Lift RegEx where instance Lift DefaultValue where lift DefValList = [e| DefValList |] + lift DefValSet = [e| DefValSet |] lift DefValMaybe = [e| DefValMaybe |] lift (DefValString s) = [e| DefValString $(liftText s) |] lift (DefValBool b) = [e| DefValBool b |] @@ -444,6 +451,7 @@ instance Lift DefaultValue where #if MIN_VERSION_template_haskell(2,16,0) liftTyped DefValList = [e|| DefValList ||] + liftTyped DefValSet = [e|| DefValSet ||] liftTyped DefValMaybe = [e|| DefValMaybe ||] liftTyped (DefValString s) = [e|| DefValString $$(liftTypedText s) ||] liftTyped (DefValBool b) = [e|| DefValBool b ||] diff --git a/src/Data/API/Value.hs b/src/Data/API/Value.hs index a8b230e..8c675ca 100644 --- a/src/Data/API/Value.hs +++ b/src/Data/API/Value.hs @@ -1,5 +1,6 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} -- | This module defines a generic representation of values belonging -- to a schema, for use during data migration. @@ -22,6 +23,7 @@ module Data.API.Value , expectEnum , expectUnion , expectList + , expectSet , expectMaybe , lookupType @@ -93,6 +95,7 @@ data Value = String !T.Text | Bool !Bool | Int !Int | List ![Value] + | Set !(Set.Set Value) | Maybe !(Maybe Value) | Union !FieldName !Value | Enum !FieldName @@ -120,6 +123,7 @@ instance NFData Value where rnf (Bool b) = rnf b rnf (Int i) = rnf i rnf (List xs) = rnf xs + rnf (Set xs) = rnf xs rnf (Maybe mb) = rnf mb rnf (Union fn v) = rnf fn `seq` rnf v rnf (Enum fn) = rnf fn @@ -137,6 +141,7 @@ instance NFData Field where fromDefaultValue :: NormAPI -> APIType -> DefaultValue -> Maybe Value fromDefaultValue api ty0 dv = case (ty0, dv) of (TyList _, DefValList) -> pure (List []) + (TySet _, DefValSet) -> pure (Maybe Nothing) (TyMaybe _, DefValMaybe) -> pure (Maybe Nothing) (TyMaybe ty, _) -> Maybe . Just <$> fromDefaultValue api ty dv (TyBasic bt, _) -> fromDefaultValueBasic bt dv @@ -172,6 +177,7 @@ instance JS.ToJSON Value where Bool b -> JS.Bool b Int i -> JS.toJSON i List vs -> JS.toJSON vs + Set xs -> JSONCBORSet (map JS.toJSON . Set.toAscList $ xs) Maybe Nothing -> JS.Null Maybe (Just v) -> JS.toJSON v Union fn v -> JS.object [fieldNameToKey fn JS..= v] @@ -191,6 +197,9 @@ parseJSON api ty0 v = case ty0 of TyList ty -> case v of JS.Array arr -> List <$> traverse (parseJSON api ty) (V.toList arr) _ -> failWith (expectedArray v) + TySet ty -> case v of + JS.Array arr -> Set . Set.fromDistinctAscList <$> traverse (parseJSON api ty) (V.toList arr) + _ -> failWith (expectedArray v) TyMaybe ty -> case v of JS.Null -> pure (Maybe Nothing) _ -> Maybe . Just <$> parseJSON api ty v @@ -231,6 +240,7 @@ encode v0 = case v0 of Bool b -> CBOR.encode b Int i -> CBOR.encode i List vs -> encodeListWith encode vs + Set vs -> encodeSetLikeWith encode (Set.toAscList vs) Maybe mb_v -> encodeMaybeWith encode mb_v Union fn v -> encodeUnion (_FieldName fn) (encode v) Enum fn -> CBOR.encode (_FieldName fn) @@ -246,6 +256,7 @@ decode :: NormAPI -> APIType -> CBOR.Decoder s Value decode api ty0 = case ty0 of TyName tn -> decodeDecl api (lookupTyName api tn) TyList ty -> List <$!> decodeListWith (decode api ty) + TySet ty -> Set . Set.fromDistinctAscList <$!> decodeSetLikeWith (decode api ty) TyMaybe ty -> Maybe <$!> decodeMaybeWith (decode api ty) TyJSON -> JSON <$!> decodeJSON TyBasic bt -> decodeBasic bt @@ -289,6 +300,9 @@ matchesNormAPI api ty0 v0 p = case ty0 of TyList ty -> case v0 of List vs -> mapM_ (\ (i, v) -> matchesNormAPI api ty v (InElem i : p)) (zip [0..] vs) _ -> Left (JSONError (expectedArray js_v), p) + TySet ty -> case v0 of + Set vs -> mapM_ (\ (i, v) -> matchesNormAPI api ty v (InElem i : p)) (zip [0..] $ Set.toAscList vs) + _ -> Left (JSONError (expectedSet js_v), p) TyMaybe ty -> case v0 of Maybe Nothing -> return () Maybe (Just v) -> matchesNormAPI api ty v p @@ -351,6 +365,10 @@ expectList :: Value -> Position -> Either (ValueError, Position) [Value] expectList (List xs) _ = pure xs expectList v p = Left (JSONError (Expected ExpArray "List" (JS.toJSON v)), p) +expectSet :: Value -> Position -> Either (ValueError, Position) [Value] +expectSet (Set xs) _ = pure $ Set.toAscList $ xs +expectSet v p = Left (JSONError (Expected ExpArray "List" (JS.toJSON v)), p) + expectMaybe :: Value -> Position -> Either (ValueError, Position) (Maybe Value) expectMaybe (Maybe v) _ = pure v expectMaybe v p = Left (JSONError (Expected ExpArray "Maybe" (JS.toJSON v)), p) @@ -372,6 +390,7 @@ arbitraryOfType :: NormAPI -> APIType -> QC.Gen Value arbitraryOfType api ty0 = case ty0 of TyName tn -> arbitraryOfDecl api (lookupTyName api tn) TyList ty -> List <$> QC.listOf (arbitraryOfType api ty) + TySet ty -> Set . Set.fromDistinctAscList <$> QC.listOf (arbitraryOfType api ty) TyMaybe ty -> Maybe <$> QC.oneof [pure Nothing, Just <$> arbitraryOfType api ty] TyJSON -> JSON <$> arbitraryJSONValue TyBasic bt -> arbitraryOfBasicType bt @@ -405,6 +424,7 @@ arbitraryJSONValue = QC.sized $ \ size -> 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) + , JSONCBORSet <$> QC.arbitrary , JS.String <$> QC.arbitrary , JS.Number . fromInteger <$> QC.arbitrary , JS.Bool <$> QC.arbitrary diff --git a/src/Data/Binary/Serialise/CBOR/Extra.hs b/src/Data/Binary/Serialise/CBOR/Extra.hs index eb7dc7d..31ff9ad 100644 --- a/src/Data/Binary/Serialise/CBOR/Extra.hs +++ b/src/Data/Binary/Serialise/CBOR/Extra.hs @@ -1,23 +1,36 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ViewPatterns #-} module Data.Binary.Serialise.CBOR.Extra ( encodeListWith + , encodeSetLikeWith , encodeMaybeWith , encodeRecordFields , encodeUnion , decodeUnion , decodeListWith + , decodeSetLikeWith , decodeMaybeWith , (<$!>) + , cborSetTag + , pattern TSetI + , pattern JSONCBORSet ) where +import Codec.CBOR.Decoding (decodeListLenCanonical) +import Codec.CBOR.Term import Codec.Serialise.Decoding import Codec.Serialise.Encoding -import Data.List (foldl1') +import Data.Word +import qualified Data.Aeson as JS import qualified Data.Text as T +import qualified Data.Vector as V #if MIN_VERSION_base(4,8,0) -import Control.Monad ((<$!>)) +import Control.Monad ((<$!>), when) #else -- | Strict version of '<$>', which is available in base >= 4.8.0 (<$!>) :: Monad m => (a -> b) -> m a -> m b @@ -70,3 +83,91 @@ decodeMaybeWith dec = do 1 -> do !x <- dec return (Just x) _ -> fail "unknown tag" + +-- +-- Encoding and decoding sets +-- + +encodeSetLikeWith :: (a -> Encoding) -> [a] -> Encoding +encodeSetLikeWith f xs = encodeSetSkel f length foldr xs + + +-- | This is the tag for the CBOR_SETS specification as defined +-- [here](https://github.com/input-output-hk/cbor-sets-spec/blob/master/CBOR_SETS.md) and +-- approved by IANA [here](https://www.iana.org/assignments/cbor-tags/cbor-tags.xhtml). +cborSetTag :: Word64 +cborSetTag = 258 + +encodeSetTag :: Encoding +encodeSetTag = encodeTag64 cborSetTag + +encodeSetSkel + :: (a -> Encoding) + -> (s -> Int) + -> ((a -> Encoding -> Encoding) -> Encoding -> s -> Encoding) + -> s + -> Encoding +encodeSetSkel encode size foldFunction = mappend encodeSetTag . encodeContainerSkel + encodeListLen + size + foldFunction + (\a b -> encode a <> b) +{-# INLINE encodeSetSkel #-} + +encodeContainerSkel :: (Word -> Encoding) + -> (container -> Int) + -> (accumFunc -> Encoding -> container -> Encoding) + -> accumFunc + -> container + -> Encoding +encodeContainerSkel encodeLen size foldFunction f c = + encodeLen (fromIntegral (size c)) <> foldFunction f mempty c +{-# INLINE encodeContainerSkel #-} + +-- | It's not a 'Set' because we need to use this in the JSON conversion, +-- and a 'Value' doesn't have an 'Ord' instance. +decodeSetLikeWith :: Decoder s a -> Decoder s [a] +decodeSetLikeWith dec = decodeSetSkel dec id + +-- | Cribbed from 'cardano-base' and 'cardano-sl', functions that I (adinapoli) +-- wrote eons ago anyway. +decodeSetTag :: Decoder s () +decodeSetTag = do + t <- decodeTag64 + when (t /= cborSetTag) $ cborError $ ("decodeSetTag: this doesn't appear to be a Set. Found tag: " <> show t) + +cborError :: String -> Decoder s a +cborError = toCborError . Left + where + toCborError :: Either String a -> Decoder s a + toCborError = either fail return + +decodeSetSkel :: forall s a. Decoder s a -> ([a] -> [a]) -> Decoder s [a] +decodeSetSkel decode fromDistinctAscList = do + decodeSetTag + n <- decodeListLenCanonical + case n of + 0 -> return (fromDistinctAscList []) + _ -> do + firstValue <- decode + decodeEntries (n - 1) firstValue [firstValue] + where + decodeEntries :: Int -> a -> [a] -> Decoder s [a] + decodeEntries 0 _ acc = pure $ reverse acc + decodeEntries !remainingEntries _previousValue !acc = do + newValue <- decode + decodeEntries (remainingEntries - 1) newValue (newValue : acc) +{-# INLINE decodeSetSkel #-} + +-- | This pattern uses the CBOR_SETS specification as defined +-- [here](https://github.com/input-output-hk/cbor-sets-spec/blob/master/CBOR_SETS.md) and +-- approved by IANA [here](https://www.iana.org/assignments/cbor-tags/cbor-tags.xhtml). +pattern TSetI :: [Term] -> Term +pattern TSetI xs <- TTagged 258 (TListI xs) where + TSetI xs = TTagged cborSetTag (TListI xs) + +pattern JSONCBORSet :: [JS.Value] -> JS.Value +pattern JSONCBORSet xs <- JS.Array (V.toList -> xs) where + JSONCBORSet xs = JS.object [ "_api_tools_set_tag" JS..= JS.toJSON cborSetTag + , "_api_tools_set_values" JS..= JS.toJSON xs + ] diff --git a/src/Data/Binary/Serialise/CBOR/JSON.hs b/src/Data/Binary/Serialise/CBOR/JSON.hs index c8417fc..05e6579 100644 --- a/src/Data/Binary/Serialise/CBOR/JSON.hs +++ b/src/Data/Binary/Serialise/CBOR/JSON.hs @@ -1,9 +1,11 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} module Data.Binary.Serialise.CBOR.JSON ( cborToJson, jsonToCbor, encodeJSON, decodeJSON, + jsonParseCborSet ) where import Data.API.JSON.Compat @@ -12,6 +14,7 @@ import qualified Data.Aeson as JSON import qualified Data.Scientific as Scientific import qualified Data.Vector as Vec +import Data.Binary.Serialise.CBOR.Extra import Data.Text (Text) import qualified Data.Text as Text import qualified Data.Text.Encoding as Text @@ -28,6 +31,7 @@ import Codec.CBOR.Term as CBOR import Codec.Serialise import Control.Applicative +import Control.Monad import Prelude @@ -133,6 +137,10 @@ cborToJson (TTagged 21 (CBOR.TBytes bs)) = JSON.String (base64url bs) cborToJson (TTagged 22 (CBOR.TBytes bs)) = JSON.String (base64 bs) cborToJson (TTagged 23 (CBOR.TBytes bs)) = JSON.String (base16 bs) +-- o A list of terms tagged with 258 is a CBOR Set as per +-- https://www.iana.org/assignments/cbor-tags/cbor-tags.xhtml +cborToJson (TSetI xs) = cborToJson (TList xs) + -- o For all other tags (major type 6, any other tag value), the -- embedded CBOR item is represented as a JSON value; the tag value -- is ignored. @@ -168,10 +176,19 @@ base64 = Text.decodeLatin1 . Base64.encode base16 :: ByteString -> Text base16 = Text.decodeLatin1 . Base16.encode +jsonParseCborSet :: JSON.Object -> Maybe JSON.Array +jsonParseCborSet kvs = case liftM2 (,) (lookupKey "_api_tools_set_tag" kvs) (lookupKey "_api_tools_set_values" kvs) of + Just (JSON.Number x, JSON.Array xs) + | 258 <- Scientific.coefficient x + -> Just xs + _ -> Nothing jsonToCbor :: JSON.Value -> CBOR.Term -jsonToCbor (JSON.Object kvs) = CBOR.TMap [ (CBOR.TString k, jsonToCbor v) - | (k, v) <- objectToList kvs ] +jsonToCbor (JSON.Object kvs) = + case jsonParseCborSet kvs of + Nothing -> CBOR.TMap [ (CBOR.TString k, jsonToCbor v) + | (k, v) <- objectToList kvs ] + Just vs -> TSetI [ jsonToCbor v | v <- Vec.toList vs ] 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/tests/Data/API/Test/DSL.hs b/tests/Data/API/Test/DSL.hs index c11c88e..a9394a9 100644 --- a/tests/Data/API/Test/DSL.hs +++ b/tests/Data/API/Test/DSL.hs @@ -127,4 +127,9 @@ nu :: NewUnion = union | bb :: BasicBinary | j :: JSON + +mrec :: MyRecordWithSet + = record + anIntSet :: {integer} // A set of integers + things :: ? {MaybeThing} // An optional set of things |] diff --git a/tests/Data/API/Test/Gen.hs b/tests/Data/API/Test/Gen.hs index c60b1b2..b43c192 100644 --- a/tests/Data/API/Test/Gen.hs +++ b/tests/Data/API/Test/Gen.hs @@ -5,6 +5,7 @@ {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE DeriveDataTypeable #-} {-# OPTIONS_GHC -fno-warn-orphans #-} +{-# LANGUAGE StandaloneDeriving #-} module Data.API.Test.Gen where @@ -129,6 +130,8 @@ instance SafeCopy JS.Value where getCopy = error "Not implemented" putCopy = error "Not implemented" +deriving instance Ord MaybeThing + $(generateAPIToolsWith (defaultToolSettings { newtypeSmartConstructors = True }) example2 [ enumTool , jsonTool'