diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,8 @@ # Revision history for schematic +## 0.2.0.0 -- 2017-09-26 + +Migratable is deprecated, migrations are now possible in an arbitrary monad. ## 0.1.5.0 -- 2017-08-22 diff --git a/schematic.cabal b/schematic.cabal --- a/schematic.cabal +++ b/schematic.cabal @@ -2,7 +2,7 @@ -- documentation, see http://haskell.org/cabal/users-guide/ name: schematic -version: 0.1.6.0 +version: 0.2.0.0 synopsis: JSON-biased spec and validation tool -- description: license: BSD3 @@ -18,6 +18,7 @@ library exposed-modules: Data.Schematic , Data.Schematic.Instances + , Data.Schematic.JsonSchema , Data.Schematic.Lens , Data.Schematic.Migration , Data.Schematic.Path @@ -31,6 +32,7 @@ , DefaultSignatures , DeriveFunctor , DeriveFoldable + , DeriveTraversable , DeriveGeneric , DeriveDataTypeable , FlexibleContexts @@ -61,9 +63,12 @@ build-depends: base >=4.9 && <4.10 , bytestring , aeson >= 1 + , containers + , hjsonschema + , mtl , regex-compat , scientific - , singletons + , singletons >= 2.2 , smallcheck , smallcheck-series , tagged @@ -92,6 +97,7 @@ , GADTs , KindSignatures , InstanceSigs + , LambdaCase , MultiParamTypeClasses , OverloadedLists , OverloadedStrings @@ -110,6 +116,8 @@ , aeson >= 1 , base >=4.9 && <4.10 , bytestring + , containers + , hjsonschema , hspec >= 2.2.0 , hspec-core , hspec-discover @@ -127,3 +135,4 @@ , vinyl other-modules: SchemaSpec , LensSpec + , JsonSchemaSpec diff --git a/src/Data/Schematic.hs b/src/Data/Schematic.hs --- a/src/Data/Schematic.hs +++ b/src/Data/Schematic.hs @@ -2,23 +2,21 @@ {-# LANGUAGE AllowAmbiguousTypes #-} module Data.Schematic - ( module Data.Schematic.Schema + ( module Data.Schematic.JsonSchema + , module Data.Schematic.Schema , module Data.Schematic.Lens , module Data.Schematic.Migration , module Data.Schematic.Utils , decodeAndValidateJson , parseAndValidateJson , parseAndValidateJsonBy - , parseAndValidateVersionedJson , parseAndValidateTopVersionJson - , decodeAndValidateVersionedJson , parseAndValidateWithMList , decodeAndValidateVersionedWithMList , isValid , isDecodingError , isValidationError , ParseResult(..) - , Migratable ) where import Control.Monad.Validation @@ -26,6 +24,7 @@ import Data.Aeson.Types as J import Data.ByteString.Lazy as BL import Data.Functor.Identity +import Data.Schematic.JsonSchema import Data.Schematic.Lens import Data.Schematic.Migration import Data.Schematic.Schema @@ -76,44 +75,22 @@ Left em -> ValidationError em Right () -> Valid jsonRepr -class Migratable (revisions :: [(Revision, Schema)]) where - mparse - :: Sing revisions - -> J.Value - -> ParseResult (JsonRepr (Snd (Head revisions))) - -instance - {-# OVERLAPPING #-} - ( TopLevel (Snd rev), SingI (Snd rev) ) - => Migratable '[rev] where - mparse _ = parseAndValidateJson - -instance {-# OVERLAPPABLE #-} - ( Migratable (Tail revisions) - , MigrateSchema (Snd (Head (Tail revisions))) (Snd (Head revisions)) - , SingI (Snd (Head revisions))) - => Migratable revisions where - mparse s v = case parseEither parseJSON v of - Left _ -> - migrate <$> (mparse (sTail s) v :: ParseResult (JsonRepr (Snd (Head (Tail revisions))))) - Right x -> Valid x - -parseAndValidateVersionedJson - :: forall proxy v. (SingI (AllVersions v), Migratable (AllVersions v)) - => proxy v - -> J.Value - -> ParseResult (JsonRepr (Snd (Head (AllVersions v)))) -parseAndValidateVersionedJson _ v = mparse (sing :: Sing (AllVersions v)) v - parseAndValidateWithMList - :: MList revisions + :: Monad m + => MList m revisions -> J.Value - -> ParseResult (JsonRepr (Head revisions)) -parseAndValidateWithMList MNil v = parseAndValidateJson v + -> m (ParseResult (JsonRepr (Head revisions))) +parseAndValidateWithMList MNil v = pure $ parseAndValidateJson v parseAndValidateWithMList ((:&&) p f tl) v = case parseAndValidateJsonBy p v of - Valid a -> Valid a - DecodingError _ -> f <$> parseAndValidateWithMList tl v - ValidationError _ -> f <$> parseAndValidateWithMList tl v + Valid a -> pure $ Valid a + DecodingError _ -> do + pr <- parseAndValidateWithMList tl v + let pr' = f <$> pr + sequence pr' + ValidationError _ -> do + pr <- parseAndValidateWithMList tl v + let pr' = f <$> pr + sequence pr' decodeAndValidateJson :: forall schema @@ -124,24 +101,16 @@ Nothing -> DecodingError "malformed json" Just x -> parseAndValidateJson x -decodeAndValidateVersionedJson - :: (Migratable (AllVersions versioned), SingI (AllVersions versioned)) - => proxy versioned - -> BL.ByteString - -> ParseResult (JsonRepr (Snd (Head (AllVersions versioned)))) -decodeAndValidateVersionedJson vp bs = case decode bs of - Nothing -> DecodingError "malformed json" - Just x -> parseAndValidateVersionedJson vp x - type family MapSnd (l :: [(a,k)]) = (r :: [k]) where MapSnd '[] = '[] MapSnd ( '(a, b) ': tl) = b ': MapSnd tl decodeAndValidateVersionedWithMList - :: proxy versioned - -> MList (MapSnd (AllVersions versioned)) + :: Monad m + => proxy versioned + -> MList m (MapSnd (AllVersions versioned)) -> BL.ByteString - -> ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned)))) + -> m (ParseResult (JsonRepr (Head (MapSnd (AllVersions versioned))))) decodeAndValidateVersionedWithMList _ mlist bs = case decode bs of - Nothing -> DecodingError "malformed json" + Nothing -> pure $ DecodingError "malformed json" Just x -> parseAndValidateWithMList mlist x diff --git a/src/Data/Schematic/JsonSchema.hs b/src/Data/Schematic/JsonSchema.hs new file mode 100644 --- /dev/null +++ b/src/Data/Schematic/JsonSchema.hs @@ -0,0 +1,75 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE OverloadedLabels #-} + +module Data.Schematic.JsonSchema + ( toJsonSchema + , toJsonSchema' + ) where + +import Control.Monad.State.Strict +import Data.Foldable +import Data.HashMap.Strict as H +import Data.List.NonEmpty +import Data.Schematic.Schema as S +import Data.Singletons +import Data.Text +import JSONSchema.Draft4.Schema as D4 +import JSONSchema.Validator.Draft4 as D4 + + +draft4 :: Text +draft4 = "http://Jason-schema.org/draft-04/schema#" + +-- FIXME: implement all this later +textConstraint :: DemotedTextConstraint -> State D4.Schema () +textConstraint (DTEq _) = pure () +textConstraint (DTLt _) = pure () +textConstraint (DTLe _) = pure () +textConstraint (DTGt _) = pure () +textConstraint (DTGe _) = pure () +textConstraint (DTRegex _) = pure () +textConstraint (DTEnum _) = pure () + +numberConstraint :: DemotedNumberConstraint -> State D4.Schema () +numberConstraint (DNLe _) = pure () +numberConstraint (DNLt _) = pure () +numberConstraint (DNGt _) = pure () +numberConstraint (DNGe _) = pure () +numberConstraint (DNEq _) = pure () + +arrayConstraint :: DemotedArrayConstraint -> State D4.Schema () +arrayConstraint (DAEq _) = pure () + +toJsonSchema + :: forall proxy schema + . SingI schema + => proxy (schema :: S.Schema) + -> D4.Schema +toJsonSchema _ = (toJsonSchema' $ fromSing (sing :: Sing schema)) + { _schemaVersion = pure draft4 } + +toJsonSchema' + :: DemotedSchema + -> D4.Schema +toJsonSchema' = \case + DSchemaText tcs -> + execState (traverse_ textConstraint tcs) $ emptySchema + { _schemaType = pure $ TypeValidatorString D4.SchemaString } + DSchemaNumber ncs -> + execState (traverse_ numberConstraint ncs) $ emptySchema + { _schemaType = pure $ TypeValidatorString D4.SchemaNumber } + DSchemaBoolean -> emptySchema + { _schemaType = pure $ TypeValidatorString D4.SchemaBoolean } + DSchemaObject objs -> emptySchema + { _schemaType = pure $ TypeValidatorString D4.SchemaObject + , _schemaProperties = pure $ H.fromList $ (\(n,s) -> (n, toJsonSchema' s)) + <$> objs } + DSchemaArray acs sch -> + execState (traverse_ arrayConstraint acs) $ emptySchema + { _schemaType = pure $ TypeValidatorString D4.SchemaArray + , _schemaItems = pure $ ItemsArray [toJsonSchema' sch] } + DSchemaNull -> emptySchema + { _schemaType = pure $ TypeValidatorString D4.SchemaNull } + DSchemaOptional sch -> emptySchema + { _schemaOneOf = pure $ toJsonSchema' DSchemaNull :| [toJsonSchema' sch] } diff --git a/src/Data/Schematic/Migration.hs b/src/Data/Schematic/Migration.hs --- a/src/Data/Schematic/Migration.hs +++ b/src/Data/Schematic/Migration.hs @@ -99,9 +99,6 @@ type family TopVersion (rs :: [(Revision, Schema)]) :: Schema where TopVersion ( '(rh, sh) ': tl) = sh -class MigrateSchema (a :: Schema) (b :: Schema) where - migrate :: JsonRepr a -> JsonRepr b - data Action = AddKey Symbol Schema | Update Schema | DeleteKey Symbol data instance Sing (a :: Action) where @@ -141,13 +138,13 @@ -> Sing (ms :: [Migration]) -- a bunch of migrations -> Sing ('Versioned s ms) -data MList :: [Schema] -> Type where - MNil :: (SingI s, TopLevel s) => MList '[s] +data MList :: (* -> *) -> [Schema] -> Type where + MNil :: (Monad m, SingI s, TopLevel s) => MList m '[s] (:&&) :: (TopLevel s, SingI s) => proxy s - -> (JsonRepr h -> JsonRepr s) - -> MList (h ': tl) - -> MList (s ': h ': tl) + -> (JsonRepr h -> m (JsonRepr s)) + -> MList m (h ': tl) + -> MList m (s ': h ': tl) infixr 7 :&& diff --git a/src/Data/Schematic/Schema.hs b/src/Data/Schematic/Schema.hs --- a/src/Data/Schematic/Schema.hs +++ b/src/Data/Schematic/Schema.hs @@ -22,14 +22,11 @@ import Data.Vinyl hiding (Dict) import qualified Data.Vinyl.TypeLevel as V import GHC.Generics (Generic) +import GHC.TypeLits (SomeNat(..), SomeSymbol(..), someSymbolVal, someNatVal) import Prelude as P import Test.SmallCheck.Series -type family All (c :: k -> Constraint) (s :: [k]) :: Constraint where - All c '[] = () - All c (a ': as) = (c a, All c as) - type family CRepr (s :: Schema) :: Type where CRepr ('SchemaText cs) = TextConstraint CRepr ('SchemaNumber cs) = NumberConstraint @@ -46,6 +43,51 @@ | TEnum [Symbol] deriving (Generic) +instance SingKind TextConstraint where + type DemoteRep TextConstraint = DemotedTextConstraint + fromSing = \case + STEq n -> withKnownNat n (DTEq $ natVal n) + STLt n -> withKnownNat n (DTLt $ natVal n) + STLe n -> withKnownNat n (DTLe $ natVal n) + STGt n -> withKnownNat n (DTGt $ natVal n) + STGe n -> withKnownNat n (DTGe $ natVal n) + STRegex s -> withKnownSymbol s (DTRegex $ T.pack $ symbolVal s) + STEnum s -> let + d :: Sing (s :: [Symbol]) -> [Text] + d SNil = [] + d (SCons ss@SSym fs) = T.pack (symbolVal ss) : d fs + in DTEnum $ d s + toSing = \case + DTEq n -> case someNatVal n of + Just (SomeNat (_ :: Proxy n)) -> SomeSing (STEq (SNat :: Sing n)) + Nothing -> error "Negative singleton nat" + DTLt n -> case someNatVal n of + Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLt (SNat :: Sing n)) + Nothing -> error "Negative singleton nat" + DTLe n -> case someNatVal n of + Just (SomeNat (_ :: Proxy n)) -> SomeSing (STLe (SNat :: Sing n)) + Nothing -> error "Negative singleton nat" + DTGt n -> case someNatVal n of + Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGt (SNat :: Sing n)) + Nothing -> error "Negative singleton nat" + DTGe n -> case someNatVal n of + Just (SomeNat (_ :: Proxy n)) -> SomeSing (STGe (SNat :: Sing n)) + Nothing -> error "Negative singleton nat" + DTRegex s -> case someSymbolVal (T.unpack s) of + SomeSymbol (_ :: Proxy n) -> SomeSing (STRegex (SSym :: Sing n)) + DTEnum ss -> case toSing (T.unpack <$> ss) of + SomeSing l -> SomeSing (STEnum l) + +data DemotedTextConstraint + = DTEq Integer + | DTLt Integer + | DTLe Integer + | DTGt Integer + | DTGe Integer + | DTRegex Text + | DTEnum [Text] + deriving (Generic) + data instance Sing (tc :: TextConstraint) where STEq :: Sing n -> Sing ('TEq n) STLt :: Sing n -> Sing ('TLt n) @@ -53,7 +95,7 @@ STGt :: Sing n -> Sing ('TGt n) STGe :: Sing n -> Sing ('TGe n) STRegex :: Sing s -> Sing ('TRegex s) - STEnum :: All KnownSymbol ss => Sing ss -> Sing ('TEnum ss) + STEnum :: Sing ss -> Sing ('TEnum ss) instance (KnownNat n) => SingI ('TEq n) where sing = STEq sing instance (KnownNat n) => SingI ('TGt n) where sing = STGt sing @@ -61,7 +103,7 @@ instance (KnownNat n) => SingI ('TLt n) where sing = STLt sing instance (KnownNat n) => SingI ('TLe n) where sing = STLe sing instance (KnownSymbol s, SingI s) => SingI ('TRegex s) where sing = STRegex sing -instance (All KnownSymbol ss, SingI ss) => SingI ('TEnum ss) where sing = STEnum sing +instance (SingI ss) => SingI ('TEnum ss) where sing = STEnum sing instance Eq (Sing ('TEq n)) where _ == _ = True instance Eq (Sing ('TLt n)) where _ == _ = True @@ -79,6 +121,14 @@ | NEq Nat deriving (Generic) +data DemotedNumberConstraint + = DNLe Integer + | DNLt Integer + | DNGt Integer + | DNGe Integer + | DNEq Integer + deriving (Generic) + data instance Sing (nc :: NumberConstraint) where SNEq :: Sing n -> Sing ('NEq n) SNGt :: Sing n -> Sing ('NGt n) @@ -98,10 +148,39 @@ instance Eq (Sing ('NGt n)) where _ == _ = True instance Eq (Sing ('NGe n)) where _ == _ = True +instance SingKind NumberConstraint where + type DemoteRep NumberConstraint = DemotedNumberConstraint + fromSing = \case + SNEq n -> withKnownNat n (DNEq $ natVal n) + SNGt n -> withKnownNat n (DNGt $ natVal n) + SNGe n -> withKnownNat n (DNGe $ natVal n) + SNLt n -> withKnownNat n (DNLt $ natVal n) + SNLe n -> withKnownNat n (DNLe $ natVal n) + toSing = \case + DNEq n -> case someNatVal n of + Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNEq (SNat :: Sing n)) + Nothing -> error "Negative singleton nat" + DNGt n -> case someNatVal n of + Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGt (SNat :: Sing n)) + Nothing -> error "Negative singleton nat" + DNGe n -> case someNatVal n of + Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNGe (SNat :: Sing n)) + Nothing -> error "Negative singleton nat" + DNLt n -> case someNatVal n of + Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLt (SNat :: Sing n)) + Nothing -> error "Negative singleton nat" + DNLe n -> case someNatVal n of + Just (SomeNat (_ :: Proxy n)) -> SomeSing (SNLe (SNat :: Sing n)) + Nothing -> error "Negative singleton nat" + data ArrayConstraint = AEq Nat deriving (Generic) +data DemotedArrayConstraint + = DAEq Integer + deriving (Generic) + data instance Sing (ac :: ArrayConstraint) where SAEq :: Sing n -> Sing ('AEq n) @@ -109,8 +188,18 @@ instance Eq (Sing ('AEq n)) where _ == _ = True +instance SingKind ArrayConstraint where + type DemoteRep ArrayConstraint = DemotedArrayConstraint + fromSing = \case + SAEq n -> withKnownNat n (DAEq $ natVal n) + toSing = \case + DAEq n -> case someNatVal n of + Just (SomeNat (_ :: Proxy n)) -> SomeSing (SAEq (SNat :: Sing n)) + Nothing -> error "Negative singleton nat" + data Schema = SchemaText [TextConstraint] + | SchemaBoolean | SchemaNumber [NumberConstraint] | SchemaObject [(Symbol, Schema)] | SchemaArray [ArrayConstraint] Schema @@ -118,9 +207,20 @@ | SchemaOptional Schema deriving (Generic) +data DemotedSchema + = DSchemaText [DemotedTextConstraint] + | DSchemaNumber [DemotedNumberConstraint] + | DSchemaBoolean + | DSchemaObject [(Text, DemotedSchema)] + | DSchemaArray [DemotedArrayConstraint] DemotedSchema + | DSchemaNull + | DSchemaOptional DemotedSchema + deriving (Generic) + data instance Sing (schema :: Schema) where SSchemaText :: Sing tcs -> Sing ('SchemaText tcs) SSchemaNumber :: Sing ncs -> Sing ('SchemaNumber ncs) + SSchemaBoolean :: Sing 'SchemaBoolean SSchemaArray :: Sing acs -> Sing schema -> Sing ('SchemaArray acs schema) SSchemaObject :: Sing fields -> Sing ('SchemaObject fields) SSchemaOptional :: Sing s -> Sing ('SchemaOptional s) @@ -132,6 +232,8 @@ sing = SSchemaNumber sing instance SingI 'SchemaNull where sing = SSchemaNull +instance SingI 'SchemaBoolean where + sing = SSchemaBoolean instance (SingI ac, SingI s) => SingI ('SchemaArray ac s) where sing = SSchemaArray sing sing instance SingI stl => SingI ('SchemaObject stl) where @@ -142,10 +244,40 @@ instance Eq (Sing ('SchemaText cs)) where _ == _ = True instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True instance Eq (Sing 'SchemaNull) where _ == _ = True +instance Eq (Sing 'SchemaBoolean) where _ == _ = True instance Eq (Sing ('SchemaArray as s)) where _ == _ = True instance Eq (Sing ('SchemaObject cs)) where _ == _ = True instance Eq (Sing ('SchemaOptional s)) where _ == _ = True +instance SingKind Schema where + type DemoteRep Schema = DemotedSchema + fromSing = \case + SSchemaText cs -> DSchemaText $ fromSing cs + SSchemaNumber cs -> DSchemaNumber $ fromSing cs + SSchemaBoolean -> DSchemaBoolean + SSchemaArray cs s -> DSchemaArray (fromSing cs) (fromSing s) + SSchemaOptional s -> DSchemaOptional $ fromSing s + SSchemaNull -> DSchemaNull + SSchemaObject cs -> let + dem :: Sing (s :: [(Symbol, Schema)]) -> [(Text, DemotedSchema)] + dem SNil = [] + dem (SCons (STuple2 ss ssch) fs) = withKnownSymbol ss + $ (T.pack (symbolVal ss), fromSing ssch) : dem fs + in DSchemaObject $ dem cs + toSing = \case + DSchemaText cs -> case toSing cs of + SomeSing scs -> SomeSing $ SSchemaText scs + DSchemaNumber cs -> case toSing cs of + SomeSing scs -> SomeSing $ SSchemaNumber scs + DSchemaBoolean -> SomeSing $ SSchemaBoolean + DSchemaArray cs sch -> case (toSing cs, toSing sch) of + (SomeSing scs, SomeSing ssch) -> SomeSing $ SSchemaArray scs ssch + DSchemaOptional sch -> case toSing sch of + SomeSing ssch -> SomeSing $ SSchemaOptional ssch + DSchemaNull -> SomeSing SSchemaNull + DSchemaObject cs -> case toSing ((\(sym,sch) -> (T.unpack sym, sch)) <$> cs) of + SomeSing scs -> SomeSing $ SSchemaObject scs + data FieldRepr :: (Symbol, Schema) -> Type where FieldRepr :: (SingI schema, KnownSymbol name) @@ -185,6 +317,7 @@ data JsonRepr :: Schema -> Type where ReprText :: Text -> JsonRepr ('SchemaText cs) ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs) + ReprBoolean :: Bool -> JsonRepr 'SchemaBoolean ReprNull :: JsonRepr 'SchemaNull ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s) ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs) @@ -259,6 +392,7 @@ parseJSON value = case sing :: Sing schema of SSchemaText _ -> withText "String" (pure . ReprText) value SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value + SSchemaBoolean -> ReprBoolean <$> parseJSON value SSchemaNull -> case value of J.Null -> pure ReprNull _ -> typeMismatch "Null" value @@ -278,6 +412,9 @@ SSchemaNumber so -> case H.lookup fieldName h of Just v -> withSingI so $ FieldRepr <$> parseJSON v Nothing -> fail "schemanumber" + SSchemaBoolean -> case H.lookup fieldName h of + Just v -> FieldRepr <$> parseJSON v + Nothing -> fail "schemaboolean" SSchemaNull -> case H.lookup fieldName h of Just v -> FieldRepr <$> parseJSON v Nothing -> fail "schemanull" @@ -295,6 +432,7 @@ instance J.ToJSON (JsonRepr a) where toJSON ReprNull = J.Null + toJSON (ReprBoolean b) = J.Bool b toJSON (ReprText t) = J.String t toJSON (ReprNumber n) = J.Number n toJSON (ReprOptional s) = case s of diff --git a/src/Data/Schematic/Validation.hs b/src/Data/Schematic/Validation.hs --- a/src/Data/Schematic/Validation.hs +++ b/src/Data/Schematic/Validation.hs @@ -12,6 +12,7 @@ import Data.Singletons.Prelude import Data.Singletons.TypeLits import Data.Text as T +import Data.Traversable import Data.Vector as V import Data.Vinyl import Prelude as P @@ -26,7 +27,7 @@ = Valid a | DecodingError Text -- static | ValidationError ErrorMap -- runtime - deriving (Show, Eq, Functor) + deriving (Show, Eq, Functor, Foldable, Traversable) isValid :: ParseResult a -> Bool isValid (Valid _) = True @@ -178,6 +179,7 @@ process cs process scs ReprNull -> pure () + ReprBoolean _ -> pure () ReprArray v -> case sschema of SSchemaArray acs s -> do let diff --git a/test/JsonSchemaSpec.hs b/test/JsonSchemaSpec.hs new file mode 100644 --- /dev/null +++ b/test/JsonSchemaSpec.hs @@ -0,0 +1,43 @@ +module JsonSchemaSpec (spec, main) where + +import Data.Aeson as J +import Data.Proxy +import Data.Schematic +import Data.Vinyl +import JSONSchema.Draft4 as D4 +import Test.Hspec + + +type ArraySchema = 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]) + +type ArrayField = '("foo", ArraySchema) + +type FieldsSchema = + '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))] + +type SchemaExample = 'SchemaObject FieldsSchema + +arrayData :: JsonRepr ArraySchema +arrayData = ReprArray [ReprNumber 13] + +arrayField :: FieldRepr ArrayField +arrayField = FieldRepr arrayData + +objectData :: Rec FieldRepr FieldsSchema +objectData = FieldRepr arrayData + :& FieldRepr (ReprOptional (Just (ReprText "foo"))) + :& RNil + +exampleData :: JsonRepr SchemaExample +exampleData = ReprObject objectData + +spec :: Spec +spec = do + it "validates simple schema" $ do + let schema = D4.SchemaWithURI (toJsonSchema (Proxy @SchemaExample)) Nothing + fetchHTTPAndValidate schema (toJSON exampleData) >>= \case + Left _ -> fail "failed to validate test example" + Right _ -> pure () + +main :: IO () +main = hspec spec diff --git a/test/LensSpec.hs b/test/LensSpec.hs --- a/test/LensSpec.hs +++ b/test/LensSpec.hs @@ -8,12 +8,12 @@ import Test.Hspec -type ArraySchema = 'SchemaArray '[AEq 1] ('SchemaNumber '[NGt 10]) +type ArraySchema = 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10]) type ArrayField = '("foo", ArraySchema) type FieldsSchema = - '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[TEnum '["foo", "bar"]]))] + '[ ArrayField, '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))] type SchemaExample = 'SchemaObject FieldsSchema @@ -31,22 +31,289 @@ exampleData :: JsonRepr SchemaExample exampleData = ReprObject objectData +type BigRecord = Rec FieldRepr + '[ '("f1", 'SchemaNumber '[]) + , '("f2", 'SchemaNumber '[]) + , '("f3", 'SchemaNumber '[]) + , '("f4", 'SchemaNumber '[]) + , '("f5", 'SchemaNumber '[]) + , '("f6", 'SchemaNumber '[]) + , '("f7", 'SchemaNumber '[]) + , '("f8", 'SchemaNumber '[]) + , '("f9", 'SchemaNumber '[]) + , '("f10", 'SchemaNumber '[]) + , '("f11", 'SchemaNumber '[]) + , '("f12", 'SchemaNumber '[]) + , '("f13", 'SchemaNumber '[]) + , '("f14", 'SchemaNumber '[]) + , '("f15", 'SchemaNumber '[]) + , '("f16", 'SchemaNumber '[]) + , '("f17", 'SchemaNumber '[]) + , '("f18", 'SchemaNumber '[]) + , '("f19", 'SchemaNumber '[]) + , '("f20", 'SchemaNumber '[]) + , '("f21", 'SchemaNumber '[]) + , '("f22", 'SchemaNumber '[]) + , '("f23", 'SchemaNumber '[]) + , '("f24", 'SchemaNumber '[]) + , '("f25", 'SchemaNumber '[]) + , '("f26", 'SchemaNumber '[]) + , '("f27", 'SchemaNumber '[]) + , '("f28", 'SchemaNumber '[]) + , '("f29", 'SchemaNumber '[]) + , '("f30", 'SchemaNumber '[]) + , '("f31", 'SchemaNumber '[]) + , '("f32", 'SchemaNumber '[]) + , '("f33", 'SchemaNumber '[]) + , '("f34", 'SchemaNumber '[]) + , '("f35", 'SchemaNumber '[]) + , '("f36", 'SchemaNumber '[]) + , '("f37", 'SchemaNumber '[]) + , '("f38", 'SchemaNumber '[]) + , '("f39", 'SchemaNumber '[]) + , '("f40", 'SchemaNumber '[]) + , '("f41", 'SchemaNumber '[]) + , '("f42", 'SchemaNumber '[]) + , '("f43", 'SchemaNumber '[]) + , '("f44", 'SchemaNumber '[]) + , '("f45", 'SchemaNumber '[]) + , '("f46", 'SchemaNumber '[]) + , '("f47", 'SchemaNumber '[]) + , '("f48", 'SchemaNumber '[]) + , '("f49", 'SchemaNumber '[]) + , '("f50", 'SchemaNumber '[]) + , '("f51", 'SchemaNumber '[]) + , '("f52", 'SchemaNumber '[]) + , '("f53", 'SchemaNumber '[]) + , '("f54", 'SchemaNumber '[]) + , '("f55", 'SchemaNumber '[]) + , '("f56", 'SchemaNumber '[]) + , '("f57", 'SchemaNumber '[]) + , '("f58", 'SchemaNumber '[]) + , '("f59", 'SchemaNumber '[]) + , '("f60", 'SchemaNumber '[]) + , '("f61", 'SchemaNumber '[]) + , '("f62", 'SchemaNumber '[]) + , '("f63", 'SchemaNumber '[]) + , '("f64", 'SchemaNumber '[]) + , '("f65", 'SchemaNumber '[]) + , '("f66", 'SchemaNumber '[]) + , '("f67", 'SchemaNumber '[]) + , '("f68", 'SchemaNumber '[]) + , '("f69", 'SchemaNumber '[]) + , '("f70", 'SchemaNumber '[]) + , '("f71", 'SchemaNumber '[]) + , '("f72", 'SchemaNumber '[]) + , '("f73", 'SchemaNumber '[]) + , '("f74", 'SchemaNumber '[]) + , '("f75", 'SchemaNumber '[]) + , '("f76", 'SchemaNumber '[]) + , '("f77", 'SchemaNumber '[]) + , '("f78", 'SchemaNumber '[]) + , '("f79", 'SchemaNumber '[]) + , '("f80", 'SchemaNumber '[]) + , '("f81", 'SchemaNumber '[]) + , '("f82", 'SchemaNumber '[]) + , '("f83", 'SchemaNumber '[]) + , '("f84", 'SchemaNumber '[]) + , '("f85", 'SchemaNumber '[]) + , '("f86", 'SchemaNumber '[]) + , '("f87", 'SchemaNumber '[]) + , '("f88", 'SchemaNumber '[]) + , '("f89", 'SchemaNumber '[]) + , '("f90", 'SchemaNumber '[]) + , '("f91", 'SchemaNumber '[]) + , '("f92", 'SchemaNumber '[]) + , '("f93", 'SchemaNumber '[]) + , '("f94", 'SchemaNumber '[]) + , '("f95", 'SchemaNumber '[]) + , '("f96", 'SchemaNumber '[]) + , '("f97", 'SchemaNumber '[]) + , '("f98", 'SchemaNumber '[]) + , '("f99", 'SchemaNumber '[]) + , '("f100", 'SchemaNumber '[]) + , '("f101", 'SchemaNumber '[]) + , '("f102", 'SchemaNumber '[]) + , '("f103", 'SchemaNumber '[]) + , '("f104", 'SchemaNumber '[]) + , '("f105", 'SchemaNumber '[]) + , '("f106", 'SchemaNumber '[]) + , '("f107", 'SchemaNumber '[]) + , '("f108", 'SchemaNumber '[]) + , '("f109", 'SchemaNumber '[]) + , '("f110", 'SchemaNumber '[]) + , '("f111", 'SchemaNumber '[]) + , '("f112", 'SchemaNumber '[]) + , '("f113", 'SchemaNumber '[]) + , '("f114", 'SchemaNumber '[]) + , '("f115", 'SchemaNumber '[]) + , '("f116", 'SchemaNumber '[]) + , '("f117", 'SchemaNumber '[]) + , '("f118", 'SchemaNumber '[]) + , '("f119", 'SchemaNumber '[]) + , '("f120", 'SchemaNumber '[]) + , '("f121", 'SchemaNumber '[]) + , '("f122", 'SchemaNumber '[]) + , '("f123", 'SchemaNumber '[]) + , '("f124", 'SchemaNumber '[]) + , '("f125", 'SchemaNumber '[]) + , '("f126", 'SchemaNumber '[]) + , '("f127", 'SchemaNumber '[]) + , '("f128", 'SchemaNumber '[]) + , '("f129", 'SchemaNumber '[]) + , '("f130", 'SchemaNumber '[]) + ] + +_bigRecord :: BigRecord +_bigRecord = + FieldRepr (ReprNumber 1) + :& FieldRepr (ReprNumber 2) + :& FieldRepr (ReprNumber 3) + :& FieldRepr (ReprNumber 4) + :& FieldRepr (ReprNumber 5) + :& FieldRepr (ReprNumber 6) + :& FieldRepr (ReprNumber 7) + :& FieldRepr (ReprNumber 8) + :& FieldRepr (ReprNumber 9) + :& FieldRepr (ReprNumber 10) + :& FieldRepr (ReprNumber 11) + :& FieldRepr (ReprNumber 12) + :& FieldRepr (ReprNumber 13) + :& FieldRepr (ReprNumber 14) + :& FieldRepr (ReprNumber 15) + :& FieldRepr (ReprNumber 16) + :& FieldRepr (ReprNumber 17) + :& FieldRepr (ReprNumber 18) + :& FieldRepr (ReprNumber 19) + :& FieldRepr (ReprNumber 20) + :& FieldRepr (ReprNumber 21) + :& FieldRepr (ReprNumber 22) + :& FieldRepr (ReprNumber 23) + :& FieldRepr (ReprNumber 24) + :& FieldRepr (ReprNumber 25) + :& FieldRepr (ReprNumber 26) + :& FieldRepr (ReprNumber 27) + :& FieldRepr (ReprNumber 28) + :& FieldRepr (ReprNumber 29) + :& FieldRepr (ReprNumber 30) + :& FieldRepr (ReprNumber 31) + :& FieldRepr (ReprNumber 32) + :& FieldRepr (ReprNumber 33) + :& FieldRepr (ReprNumber 34) + :& FieldRepr (ReprNumber 35) + :& FieldRepr (ReprNumber 36) + :& FieldRepr (ReprNumber 37) + :& FieldRepr (ReprNumber 38) + :& FieldRepr (ReprNumber 39) + :& FieldRepr (ReprNumber 40) + :& FieldRepr (ReprNumber 41) + :& FieldRepr (ReprNumber 42) + :& FieldRepr (ReprNumber 43) + :& FieldRepr (ReprNumber 44) + :& FieldRepr (ReprNumber 45) + :& FieldRepr (ReprNumber 46) + :& FieldRepr (ReprNumber 47) + :& FieldRepr (ReprNumber 48) + :& FieldRepr (ReprNumber 49) + :& FieldRepr (ReprNumber 50) + :& FieldRepr (ReprNumber 51) + :& FieldRepr (ReprNumber 52) + :& FieldRepr (ReprNumber 53) + :& FieldRepr (ReprNumber 54) + :& FieldRepr (ReprNumber 55) + :& FieldRepr (ReprNumber 56) + :& FieldRepr (ReprNumber 57) + :& FieldRepr (ReprNumber 58) + :& FieldRepr (ReprNumber 59) + :& FieldRepr (ReprNumber 60) + :& FieldRepr (ReprNumber 61) + :& FieldRepr (ReprNumber 62) + :& FieldRepr (ReprNumber 63) + :& FieldRepr (ReprNumber 64) + :& FieldRepr (ReprNumber 65) + :& FieldRepr (ReprNumber 66) + :& FieldRepr (ReprNumber 67) + :& FieldRepr (ReprNumber 68) + :& FieldRepr (ReprNumber 69) + :& FieldRepr (ReprNumber 70) + :& FieldRepr (ReprNumber 71) + :& FieldRepr (ReprNumber 72) + :& FieldRepr (ReprNumber 73) + :& FieldRepr (ReprNumber 74) + :& FieldRepr (ReprNumber 75) + :& FieldRepr (ReprNumber 76) + :& FieldRepr (ReprNumber 77) + :& FieldRepr (ReprNumber 78) + :& FieldRepr (ReprNumber 79) + :& FieldRepr (ReprNumber 80) + :& FieldRepr (ReprNumber 81) + :& FieldRepr (ReprNumber 82) + :& FieldRepr (ReprNumber 83) + :& FieldRepr (ReprNumber 84) + :& FieldRepr (ReprNumber 85) + :& FieldRepr (ReprNumber 86) + :& FieldRepr (ReprNumber 87) + :& FieldRepr (ReprNumber 88) + :& FieldRepr (ReprNumber 89) + :& FieldRepr (ReprNumber 90) + :& FieldRepr (ReprNumber 91) + :& FieldRepr (ReprNumber 92) + :& FieldRepr (ReprNumber 93) + :& FieldRepr (ReprNumber 94) + :& FieldRepr (ReprNumber 95) + :& FieldRepr (ReprNumber 96) + :& FieldRepr (ReprNumber 97) + :& FieldRepr (ReprNumber 98) + :& FieldRepr (ReprNumber 99) + :& FieldRepr (ReprNumber 100) + :& FieldRepr (ReprNumber 101) + :& FieldRepr (ReprNumber 102) + :& FieldRepr (ReprNumber 103) + :& FieldRepr (ReprNumber 104) + :& FieldRepr (ReprNumber 105) + :& FieldRepr (ReprNumber 106) + :& FieldRepr (ReprNumber 107) + :& FieldRepr (ReprNumber 108) + :& FieldRepr (ReprNumber 109) + :& FieldRepr (ReprNumber 110) + :& FieldRepr (ReprNumber 111) + :& FieldRepr (ReprNumber 112) + :& FieldRepr (ReprNumber 113) + :& FieldRepr (ReprNumber 114) + :& FieldRepr (ReprNumber 115) + :& FieldRepr (ReprNumber 116) + :& FieldRepr (ReprNumber 117) + :& FieldRepr (ReprNumber 118) + :& FieldRepr (ReprNumber 119) + :& FieldRepr (ReprNumber 120) + :& FieldRepr (ReprNumber 121) + :& FieldRepr (ReprNumber 122) + :& FieldRepr (ReprNumber 123) + :& FieldRepr (ReprNumber 124) + :& FieldRepr (ReprNumber 125) + :& FieldRepr (ReprNumber 126) + :& FieldRepr (ReprNumber 127) + :& FieldRepr (ReprNumber 128) + :& FieldRepr (ReprNumber 129) + :& FieldRepr (ReprNumber 130) + :& RNil + spec :: Spec spec = do let newFooVal = FieldRepr $ ReprArray [ReprNumber 15] fooProxy = Proxy @"foo" it "gets the field from an object" $ do - fget fooProxy objectData == arrayField + fget fooProxy objectData `shouldBe` arrayField it "sets the object field" $ do - fget fooProxy (fput newFooVal objectData) == newFooVal + fget fooProxy (fput newFooVal objectData) `shouldBe` newFooVal describe "(using lens library) " $ do it "get the field from an object" $ do - objectData ^. flens (Proxy @"foo") == arrayField + objectData ^. flens (Proxy @"foo") `shouldBe` arrayField it "sets the object field" $ do set (flens (Proxy @"foo")) newFooVal objectData ^. flens (Proxy @"foo") - == newFooVal + `shouldBe` newFooVal main :: IO () main = hspec spec diff --git a/test/SchemaSpec.hs b/test/SchemaSpec.hs --- a/test/SchemaSpec.hs +++ b/test/SchemaSpec.hs @@ -2,24 +2,18 @@ module SchemaSpec (spec, main) where -import Control.Monad import Data.ByteString.Lazy import Data.Aeson import Data.Proxy import Data.Schematic -import Data.Singletons -import Data.Singletons.Prelude import Data.Vinyl import Test.Hspec -import Test.Hspec.SmallCheck -import Test.SmallCheck -import Test.SmallCheck.Series.Instances type SchemaExample = 'SchemaObject - '[ '("foo", 'SchemaArray '[AEq 1] ('SchemaNumber '[NGt 10])) - , '("bar", 'SchemaOptional ('SchemaText '[TEnum '["foo", "bar"]]))] + '[ '("foo", 'SchemaArray '[ 'AEq 1] ('SchemaNumber '[ 'NGt 10])) + , '("bar", 'SchemaOptional ('SchemaText '[ 'TEnum '["foo", "bar"]]))] type TestMigration = 'Migration "test_revision" @@ -28,15 +22,6 @@ type VS = 'Versioned SchemaExample '[ TestMigration ] -exampleTest :: JsonRepr (SchemaOptional (SchemaText '[TEq 3])) -exampleTest = ReprOptional (Just (ReprText "lil")) - -exampleNumber :: JsonRepr (SchemaNumber '[NGt 10]) -exampleNumber = ReprNumber 12 - -exampleArray :: JsonRepr (SchemaArray '[AEq 1] (SchemaNumber '[NGt 10])) -exampleArray = ReprArray [exampleNumber] - jsonExample :: JsonRepr SchemaExample jsonExample = ReprObject $ FieldRepr (ReprArray [ReprNumber 12]) @@ -49,9 +34,6 @@ schemaJson2 :: ByteString schemaJson2 = "{\"foo\": [3], \"bar\": null}" -schemaJsonTopVersion :: ByteString -schemaJsonTopVersion = "{ \"foo\": 42, \"bar\": \"bar\" }" - topObject :: JsonRepr ('SchemaObject @@ -88,7 +70,7 @@ it "validates versioned json" $ do decodeAndValidateVersionedJson (Proxy @VS) schemaJson `shouldSatisfy` isValid - it "validates with Migration List" $ do + it "validates versioned json with a migration list" $ do decodeAndValidateVersionedWithMList (Proxy @VS) ((:&&) (Proxy @(SchemaByRevision "test_revision" VS)) (const topObject) MNil)