diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,5 @@ +# Revision history for schematic + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2017, Denis Redozubov + +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. + + * Neither the name of Denis Redozubov nor the names of other + contributors may 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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/schematic.cabal b/schematic.cabal new file mode 100644 --- /dev/null +++ b/schematic.cabal @@ -0,0 +1,121 @@ +-- Initial schematic.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/ + +name: schematic +version: 0.1.0.0 +synopsis: JSON-biased spec and validation tool +-- description: +license: BSD3 +license-file: LICENSE +author: Denis Redozubov +maintainer: denis.redozubov@gmail.com +-- copyright: +category: Data +build-type: Simple +extra-source-files: ChangeLog.md +cabal-version: >=1.10 + +library + exposed-modules: Data.Schematic + , Data.Schematic.Instances + , Data.Schematic.Path + , Data.Schematic.Schema + , Data.Schematic.Validation + , Data.Schematic.Utils + ghc-options: -Wall + -- other-modules: + default-extensions: ConstraintKinds + , DataKinds + , DefaultSignatures + , DeriveFunctor + , DeriveFoldable + , DeriveGeneric + , DeriveDataTypeable + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GADTs + , KindSignatures + , InstanceSigs + , LambdaCase + , MultiParamTypeClasses + , OverloadedLists + , OverloadedStrings + , PolyKinds + , QuasiQuotes + , PartialTypeSignatures + , RankNTypes + , RecordWildCards + , StandaloneDeriving + , ScopedTypeVariables + , TemplateHaskell + , TypeApplications + , TypeFamilies + , TypeInType + , TypeOperators + , TypeSynonymInstances + , UndecidableInstances + build-depends: base >=4.9 && <4.10 + , aeson >= 1 + , deriving-compat + , regex-compat + , scientific + , singletons + , smallcheck + , smallcheck-series + , text + , unordered-containers + , validationt >= 0.1.0.1 + , vector + , vinyl + hs-source-dirs: src + default-language: Haskell2010 + +test-suite spec + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + default-language: Haskell2010 + default-extensions: ConstraintKinds + , DataKinds + , DeriveFunctor + , DeriveFoldable + , DeriveGeneric + , DeriveDataTypeable + , FlexibleContexts + , FlexibleInstances + , FunctionalDependencies + , GADTs + , KindSignatures + , InstanceSigs + , MultiParamTypeClasses + , OverloadedLists + , OverloadedStrings + , PolyKinds + , QuasiQuotes + , PartialTypeSignatures + , RecordWildCards + , ScopedTypeVariables + , TemplateHaskell + , TypeApplications + , TypeFamilies + , TypeInType + , TypeOperators + , TypeSynonymInstances + build-depends: HUnit + , aeson >= 1 + , base >=4.9 && <4.10 + , hspec >= 2.2.0 + , hspec-core + , hspec-discover + , hspec-smallcheck + , regex-compat + , schematic + , smallcheck + , smallcheck-series + , singletons + , text + , unordered-containers + , validationt >= 0.1.0.1 + , vinyl + other-modules: SchemaSpec diff --git a/src/Data/Schematic.hs b/src/Data/Schematic.hs new file mode 100644 --- /dev/null +++ b/src/Data/Schematic.hs @@ -0,0 +1,31 @@ +module Data.Schematic + ( module Data.Schematic.Schema + , module Data.Schematic.Utils + , parseAndValidateJson + ) where + +import Control.Monad.Validation +import Data.Aeson as J +import Data.Aeson.Types as J +import Data.Functor.Identity +import Data.Schematic.Schema +import Data.Schematic.Utils +import Data.Schematic.Validation +import Data.Text as T + + +parseAndValidateJson + :: forall schema + . (J.FromJSON (JsonRepr schema), TopLevel schema, Known (Sing schema)) + => J.Value + -> ParseResult (JsonRepr schema) +parseAndValidateJson v = + case parseEither parseJSON v of + Left s -> DecodingError $ T.pack s + Right jsonRepr -> + let + validate = validateJsonRepr (known :: Sing schema) [] jsonRepr + res = runIdentity . runValidationTEither $ validate + in case res of + Left em -> ValidationError em + Right () -> Valid jsonRepr diff --git a/src/Data/Schematic/Instances.hs b/src/Data/Schematic/Instances.hs new file mode 100644 --- /dev/null +++ b/src/Data/Schematic/Instances.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Data.Schematic.Instances where + +import Data.Scientific +import Data.Vector as V +import Data.Vinyl +import Test.SmallCheck.Series + + +instance Monad m => Serial m (Rec f '[]) where + series = cons0 RNil + +instance (Serial m (f a), Serial m (Rec f as), Monad m) + => Serial m (Rec f (a ': as)) where + series = cons2 (:&) + +instance Serial m a => Serial m (V.Vector a) where + series = V.fromList <$> series + +instance Monad m => Serial m Scientific where + series = scientific <$> series <*> series diff --git a/src/Data/Schematic/Path.hs b/src/Data/Schematic/Path.hs new file mode 100644 --- /dev/null +++ b/src/Data/Schematic/Path.hs @@ -0,0 +1,50 @@ +module Data.Schematic.Path where + +import Data.Foldable as F +import Data.Monoid +import Data.Schematic.Utils +import Data.Singletons +import Data.Singletons.Prelude +import Data.Singletons.TypeLits +import Data.Text as T + + +data PathSegment = Key Symbol | Ix Nat + +data instance Sing (jp :: PathSegment) where + SKey :: (KnownSymbol k, Known (Sing k)) => Sing (k :: Symbol) -> Sing ('Key k) + SIx :: (KnownNat n, Known (Sing n)) => Sing (n :: Nat) -> Sing ('Ix n) + +instance (KnownSymbol k, Known (Sing k)) + => Known (Sing ('Key k)) where + known = SKey known + +instance (KnownNat n, Known (Sing n)) + => Known (Sing ('Ix n)) where + known = SIx known + +data DemotedPathSegment = DKey Text | DIx Integer + deriving (Show) + +-- | Textual representation of json path. +newtype JSONPath = JSONPath Text + deriving (Show) + +demotePath :: Sing (ps :: [PathSegment]) -> [DemotedPathSegment] +demotePath = go [] + where + go :: [DemotedPathSegment] -> Sing (ps :: [PathSegment]) -> [DemotedPathSegment] + go acc SNil = acc + go acc (SCons p ps) = go (acc ++ [demote p]) ps + demote :: Sing (ps :: PathSegment) -> DemotedPathSegment + demote (SKey s) = DKey $ T.pack $ symbolVal s + demote (SIx n) = DIx $ natVal n + +demotedPathToText :: [DemotedPathSegment] -> JSONPath +demotedPathToText = JSONPath . F.foldl' renderPathSegment "" + where + renderPathSegment acc (DKey t) = acc <> "." <> t + renderPathSegment acc (DIx n) = acc <> "[" <> T.pack (show n) <> "]" + +pathToText :: Sing (ps :: [PathSegment]) -> JSONPath +pathToText = demotedPathToText . demotePath diff --git a/src/Data/Schematic/Schema.hs b/src/Data/Schematic/Schema.hs new file mode 100644 --- /dev/null +++ b/src/Data/Schematic/Schema.hs @@ -0,0 +1,300 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE OverloadedLists #-} +{-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -fprint-explicit-kinds #-} + +module Data.Schematic.Schema where + +import Control.Applicative +import Control.Monad +import Data.Aeson as J +import Data.Aeson.Types as J +import Data.HashMap.Strict as H +import Data.Kind +import Data.Maybe +import Data.Schematic.Instances () +import Data.Schematic.Utils +import Data.Scientific +import Data.Singletons.Prelude.List hiding (All) +import Data.Singletons.TH +import Data.Singletons.TypeLits +import Data.Text as T +import Data.Vector as V +import Data.Vinyl hiding (Dict) +import Data.Vinyl.TypeLevel hiding (Nat) +import GHC.Generics (Generic) +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 + CRepr ('SchemaObject fs) = (String, Schema) + CRepr ('SchemaArray ar s) = ArrayConstraint + +data TextConstraint + = TEq Nat + | TLe Nat + | TGt Nat + | TRegex Symbol + | TEnum [Symbol] + deriving (Generic) + +data instance Sing (tc :: TextConstraint) where + STEq :: (KnownNat n) => Sing n -> Sing ('TEq n) + STLe :: (KnownNat n) => Sing n -> Sing ('TLe n) + STGt :: (KnownNat n) => Sing n -> Sing ('TGt n) + STRegex :: (KnownSymbol s, Known (Sing s)) => Sing s -> Sing ('TRegex s) + STEnum :: (All KnownSymbol ss, Known (Sing ss)) => Sing ss -> Sing ('TEnum ss) + +instance (KnownNat n) => Known (Sing ('TEq n)) where known = STEq known +instance (KnownNat n) => Known (Sing ('TGt n)) where known = STGt known +instance (KnownNat n) => Known (Sing ('TLe n)) where known = STLe known +instance (KnownSymbol s, Known (Sing s)) => Known (Sing ('TRegex s)) where known = STRegex known +instance (All KnownSymbol ss, Known (Sing ss)) => Known (Sing ('TEnum ss)) where known = STEnum known + +instance Eq (Sing ('TEq n)) where _ == _ = True +instance Eq (Sing ('TLe n)) where _ == _ = True +instance Eq (Sing ('TGt n)) where _ == _ = True +instance Eq (Sing ('TRegex t)) where _ == _ = True +instance Eq (Sing ('TEnum ss)) where _ == _ = True + +data NumberConstraint + = NLe Nat + | NGt Nat + | NEq Nat + deriving (Generic) + +data instance Sing (nc :: NumberConstraint) where + SNEq :: KnownNat n => Sing n -> Sing ('NEq n) + SNGt :: KnownNat n => Sing n -> Sing ('NGt n) + SNLe :: KnownNat n => Sing n -> Sing ('NLe n) + +instance KnownNat n => Known (Sing ('NEq n)) where known = SNEq known +instance KnownNat n => Known (Sing ('NGt n)) where known = SNGt known +instance KnownNat n => Known (Sing ('NLe n)) where known = SNLe known + +instance Eq (Sing ('NEq n)) where _ == _ = True +instance Eq (Sing ('NLe n)) where _ == _ = True +instance Eq (Sing ('NGt n)) where _ == _ = True + +data ArrayConstraint + = AEq Nat + deriving (Generic) + +data instance Sing (ac :: ArrayConstraint) where + SAEq :: KnownNat n => Sing n -> Sing ('AEq n) + +instance KnownNat n => Known (Sing ('AEq n)) where known = SAEq known + +instance Eq (Sing ('AEq n)) where _ == _ = True + +data Schema + = SchemaText [TextConstraint] + | SchemaNumber [NumberConstraint] + | SchemaObject [(Symbol, Schema)] + | SchemaArray [ArrayConstraint] Schema + | SchemaNull + | SchemaOptional Schema + deriving (Generic) + +data instance Sing (schema :: Schema) where + SSchemaText :: Known (Sing tcs) => Sing tcs -> Sing ('SchemaText tcs) + SSchemaNumber :: Known (Sing ncs) => Sing ncs -> Sing ('SchemaNumber ncs) + SSchemaArray :: (Known (Sing acs), Known (Sing schema)) => Sing acs -> Sing schema -> Sing ('SchemaArray acs schema) + SSchemaObject :: Known (Sing fields) => Sing fields -> Sing ('SchemaObject fields) + SSchemaOptional :: Known (Sing s) => Sing s -> Sing ('SchemaOptional s) + SSchemaNull :: Sing 'SchemaNull + +instance Known (Sing sl) => Known (Sing ('SchemaText sl)) where + known = SSchemaText known +instance Known (Sing sl) => Known (Sing ('SchemaNumber sl)) where + known = SSchemaNumber known +instance Known (Sing 'SchemaNull) where + known = SSchemaNull +instance (Known (Sing ac), Known (Sing s)) => Known (Sing ('SchemaArray ac s)) where + known = SSchemaArray known known +instance Known (Sing stl) => Known (Sing ('SchemaObject stl)) where + known = SSchemaObject known +instance Known (Sing s) => Known (Sing ('SchemaOptional s)) where + known = SSchemaOptional known + +instance Eq (Sing ('SchemaText cs)) where _ == _ = True +instance Eq (Sing ('SchemaNumber cs)) where _ == _ = True +instance Eq (Sing 'SchemaNull) where _ == _ = True +instance Eq (Sing ('SchemaArray as s)) where _ == _ = True +instance Eq (Sing ('SchemaObject cs)) where _ == _ = True +instance Eq (Sing ('SchemaOptional s)) where _ == _ = True + +data FieldRepr :: (Symbol, Schema) -> Type where + FieldRepr + :: (Known (Sing schema), KnownSymbol name) + => JsonRepr schema + -> FieldRepr '(name, schema) + +knownFieldName + :: forall proxy (fieldName :: Symbol) schema + . KnownSymbol fieldName + => proxy '(fieldName, schema) + -> Text +knownFieldName _ = T.pack $ symbolVal (Proxy @fieldName) + +knownFieldSchema + :: forall proxy fieldName schema + . Known (Sing schema) + => proxy '(fieldName, schema) + -> Sing schema +knownFieldSchema _ = known + +deriving instance Show (JsonRepr schema) => Show (FieldRepr '(name, schema)) + +instance Eq (JsonRepr schema) => Eq (FieldRepr '(name, schema)) where + FieldRepr a == FieldRepr b = a == b + +instance + ( KnownSymbol name + , Known (Sing schema) + , Serial m (JsonRepr schema) ) + => Serial m (FieldRepr '(name, schema)) where + series = FieldRepr <$> series + +data JsonRepr :: Schema -> Type where + ReprText :: Text -> JsonRepr ('SchemaText cs) + ReprNumber :: Scientific -> JsonRepr ('SchemaNumber cs) + ReprNull :: JsonRepr 'SchemaNull + ReprArray :: V.Vector (JsonRepr s) -> JsonRepr ('SchemaArray cs s) + ReprObject :: Rec FieldRepr fs -> JsonRepr ('SchemaObject fs) + ReprOptional :: Maybe (JsonRepr s) -> JsonRepr ('SchemaOptional s) + +instance Show (JsonRepr ('SchemaText cs)) where + show (ReprText t) = "ReprText " P.++ show t + +instance Show (JsonRepr ('SchemaNumber cs)) where + show (ReprNumber n) = "ReprNumber " P.++ show n + +instance Show (JsonRepr 'SchemaNull) where show _ = "ReprNull" + +instance Show (JsonRepr s) => Show (JsonRepr ('SchemaArray acs s)) where + show (ReprArray v) = "ReprArray " P.++ show v + +instance RecAll FieldRepr fs Show => Show (JsonRepr ('SchemaObject fs)) where + show (ReprObject fs) = "ReprObject " P.++ show fs + +instance Show (JsonRepr s) => Show (JsonRepr ('SchemaOptional s)) where + show (ReprOptional s) = "ReprOptional " P.++ show s + +instance (Monad m, Serial m Text) + => Serial m (JsonRepr ('SchemaText cs)) where + series = cons1 ReprText + +instance (Monad m, Serial m Scientific) + => Serial m (JsonRepr ('SchemaNumber cs)) where + series = cons1 ReprNumber + +instance Monad m => Serial m (JsonRepr 'SchemaNull) where + series = cons0 ReprNull + +instance (Serial m (V.Vector (JsonRepr s))) + => Serial m (JsonRepr ('SchemaArray cs s)) where + series = cons1 ReprArray + +instance (Serial m (JsonRepr s)) + => Serial m (JsonRepr ('SchemaOptional s)) where + series = cons1 ReprOptional + +instance (Monad m, Serial m (Rec FieldRepr fs)) + => Serial m (JsonRepr ('SchemaObject fs)) where + series = cons1 ReprObject + +instance Eq (Rec FieldRepr fs) => Eq (JsonRepr ('SchemaObject fs)) where + ReprObject a == ReprObject b = a == b + +instance Eq (JsonRepr ('SchemaText cs)) where + ReprText a == ReprText b = a == b + +instance Eq (JsonRepr ('SchemaNumber cs)) where + ReprNumber a == ReprNumber b = a == b + +instance Eq (JsonRepr 'SchemaNull) where + ReprNull == ReprNull = True + +instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaArray as s)) where + ReprArray a == ReprArray b = a == b + +instance Eq (JsonRepr s) => Eq (JsonRepr ('SchemaOptional s)) where + ReprOptional a == ReprOptional b = a == b + +fromOptional + :: (Known (Sing s)) + => Sing ('SchemaOptional s) + -> J.Value + -> Parser (Maybe (JsonRepr s)) +fromOptional _ = parseJSON + +instance Known (Sing schema) => J.FromJSON (JsonRepr schema) where + parseJSON value = case known :: Sing schema of + SSchemaText _ -> withText "String" (pure . ReprText) value + SSchemaNumber _ -> withScientific "Number" (pure . ReprNumber) value + SSchemaNull -> case value of + J.Null -> pure ReprNull + _ -> typeMismatch "Null" value + so@(SSchemaOptional _) -> ReprOptional <$> fromOptional so value + SSchemaArray _ _ -> withArray "Array" (fmap ReprArray . traverse parseJSON) value + SSchemaObject fs -> do + let + demoteFields :: SList s -> H.HashMap Text J.Value -> Parser (Rec FieldRepr s) + demoteFields SNil _ = pure RNil + demoteFields (SCons (STuple2 (n :: Sing fn) s) tl) h = withKnownSymbol n $ do + let fieldName = T.pack $ symbolVal (Proxy @fn) + fieldRepr <- case s of + SSchemaText _ -> case H.lookup fieldName h of + Just v -> FieldRepr <$> parseJSON v + Nothing -> fail "schematext" + SSchemaNumber _ -> case H.lookup fieldName h of + Just v -> FieldRepr <$> parseJSON v + Nothing -> fail "schemanumber" + SSchemaNull -> case H.lookup fieldName h of + Just v -> FieldRepr <$> parseJSON v + Nothing -> fail "schemanull" + SSchemaArray _ _ -> case H.lookup fieldName h of + Just v -> FieldRepr <$> parseJSON v + Nothing -> fail "schemaarray" + SSchemaObject _ -> case H.lookup fieldName h of + Just v -> FieldRepr <$> parseJSON v + Nothing -> fail "schemaobject" + SSchemaOptional _ -> case H.lookup fieldName h of + Just v -> FieldRepr <$> parseJSON v + Nothing -> fail "schemaoptional" + (fieldRepr :&) <$> demoteFields tl h + ReprObject <$> withObject "Object" (demoteFields fs) value + +instance J.ToJSON (JsonRepr a) where + toJSON ReprNull = J.Null + toJSON (ReprText t) = J.String t + toJSON (ReprNumber n) = J.Number n + toJSON (ReprOptional s) = case s of + Just v -> toJSON v + Nothing -> J.Null + toJSON (ReprArray v) = J.Array $ toJSON <$> v + toJSON (ReprObject r) = J.Object . H.fromList . fold $ r + where + extract :: forall name s . (KnownSymbol name) + => FieldRepr '(name, s) + -> (Text, Value) + extract (FieldRepr s) = (T.pack $ symbolVal $ Proxy @name, toJSON s) + fold :: Rec FieldRepr fs -> [(Text, J.Value)] + fold = \case + RNil -> [] + fr@(FieldRepr _) :& tl -> (extract fr) : fold tl + +class FalseConstraint a + +type family TopLevel (schema :: Schema) :: Constraint where + TopLevel ('SchemaArray acs s) = () + TopLevel ('SchemaObject o) = () + TopLevel spec = FalseConstraint spec diff --git a/src/Data/Schematic/Utils.hs b/src/Data/Schematic/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/Schematic/Utils.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} + +module Data.Schematic.Utils where + +import Data.Proxy +import Data.Singletons +import Data.Singletons.Prelude +import Data.Singletons.TypeLits +import Data.Vinyl hiding (Dict) + + +class Known a where + known :: a + +instance Known (Proxy a) where + known = Proxy + +instance KnownNat n => Known (Sing n) where + known = SNat + +instance KnownSymbol s => Known (Sing s) where + known = SSym + +instance (Known (Sing a), Known (Sing b)) => Known (Sing '(a,b)) where + known = STuple2 known known + +instance Known (Sing '[]) where known = SNil + +instance (Known (Sing a), Known (Sing as)) => Known (Sing (a ': as)) where + known = SCons known known + +instance Known (Rec Sing '[]) where + known = RNil + +instance (Known (Sing a), Known (Rec Sing tl)) => Known (Rec Sing (a ': tl)) where + known = known :& known diff --git a/src/Data/Schematic/Validation.hs b/src/Data/Schematic/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Data/Schematic/Validation.hs @@ -0,0 +1,165 @@ +module Data.Schematic.Validation where + +import Control.Monad +import Control.Monad.Validation +import Data.Foldable +import Data.Functor.Identity +import Data.Monoid +import Data.Schematic.Path +import Data.Schematic.Schema +import Data.Schematic.Utils () +import Data.Scientific +import Data.Singletons.Prelude +import Data.Singletons.TypeLits +import Data.Text as T +import Data.Vector as V +import Data.Vinyl +import Prelude as P +import Text.Regex + + +type Validation a = ValidationT ErrorMap Identity a + +type ErrorMap = MonoidMap Text [Text] + +data ParseResult a + = Valid a + | DecodingError Text + | ValidationError ErrorMap + deriving (Show, Eq, Functor) + +validateTextConstraint + :: JSONPath + -> Text + -> Sing (tcs :: TextConstraint) + -> Validation () +validateTextConstraint (JSONPath path) t = \case + STEq n -> do + let + nlen = natVal n + predicate = nlen == (fromIntegral $ T.length t) + errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen) + warn = vWarning $ mmSingleton path (pure errMsg) + unless predicate warn + STLe n -> do + let + nlen = natVal n + predicate = nlen <= (fromIntegral $ T.length t) + errMsg = "length of " <> path <> " should be <= " <> T.pack (show nlen) + warn = vWarning $ mmSingleton path (pure errMsg) + unless predicate warn + STGt n -> do + let + nlen = natVal n + predicate = nlen > (fromIntegral $ T.length t) + errMsg = "length of " <> path <> " should be > " <> T.pack (show nlen) + warn = vWarning $ mmSingleton path (pure errMsg) + unless predicate warn + STRegex r -> do + let + regex = symbolVal r + predicate = maybe False (const True) $ matchRegex (mkRegex regex) (T.unpack t) + errMsg = path <> " must match " <> T.pack (show regex) + warn = vWarning $ mmSingleton path (pure errMsg) + unless predicate warn + STEnum ss -> do + let + matching :: Sing (s :: [Symbol]) -> Bool + matching SNil = False + matching (SCons s@SSym fs) = T.pack (symbolVal s) == t || matching fs + errMsg = path <> " must be one of " <> T.pack (show (fromSing ss)) + warn = vWarning $ mmSingleton path (pure errMsg) + unless (matching ss) warn + +validateNumberConstraint + :: JSONPath + -> Scientific + -> Sing (tcs :: NumberConstraint) + -> Validation () +validateNumberConstraint (JSONPath path) num = \case + SNEq n -> do + let + nlen = natVal n + predicate = fromIntegral nlen == num + errMsg = path <> " should be == " <> T.pack (show nlen) + warn = vWarning $ mmSingleton path (pure errMsg) + unless predicate warn + SNGt n -> do + let + nlen = natVal n + predicate = num > fromIntegral nlen + errMsg = path <> " should be > " <> T.pack (show nlen) + warn = vWarning $ mmSingleton path (pure errMsg) + unless predicate warn + SNLe n -> do + let + nlen = natVal n + predicate = fromIntegral nlen <= num + errMsg = path <> " should be <= " <> T.pack (show nlen) + warn = vWarning $ mmSingleton path (pure errMsg) + unless predicate warn + +validateArrayConstraint + :: JSONPath + -> V.Vector a + -> Sing (tcs :: ArrayConstraint) + -> Validation () +validateArrayConstraint (JSONPath path) v = \case + SAEq n -> do + let + nlen = natVal n + predicate = nlen == fromIntegral (V.length v) + errMsg = "length of " <> path <> " should be == " <> T.pack (show nlen) + warn = vWarning $ mmSingleton path (pure errMsg) + unless predicate warn + +validateJsonRepr + :: Sing schema + -> [DemotedPathSegment] + -> JsonRepr schema + -> Validation () +validateJsonRepr sschema dpath jr = case jr of + ReprText t -> case sschema of + SSchemaText scs -> do + let + process :: Sing (cs :: [TextConstraint]) -> Validation () + process SNil = pure () + process (SCons c cs) = do + validateTextConstraint (demotedPathToText dpath) t c + process cs + process scs + ReprNumber n -> case sschema of + SSchemaNumber scs -> do + let + process :: Sing (cs :: [NumberConstraint]) -> Validation () + process SNil = pure () + process (SCons c cs) = do + validateNumberConstraint (demotedPathToText dpath) n c + process cs + process scs + ReprNull -> pure () + ReprArray v -> case sschema of + SSchemaArray acs s -> do + let + process :: Sing (cs :: [ArrayConstraint]) -> Validation () + process SNil = pure () + process (SCons c cs) = do + validateArrayConstraint (demotedPathToText dpath) v c + process cs + process acs + for_ (V.indexed v) $ \(ix, jr') -> do + let newPath = dpath <> pure (DIx $ fromIntegral ix) + validateJsonRepr s newPath jr' + ReprOptional d -> case sschema of + SSchemaOptional ss -> case d of + Just x -> validateJsonRepr ss dpath x + Nothing -> pure () + ReprObject fs -> case sschema of + SSchemaObject _ -> go fs + where + go :: Rec FieldRepr (ts :: [ (Symbol, Schema) ] ) -> Validation () + go RNil = pure () + go (f@(FieldRepr d) :& ftl) = do + let newPath = dpath <> [DKey (knownFieldName f)] + validateJsonRepr (knownFieldSchema f) newPath d + go ftl diff --git a/test/SchemaSpec.hs b/test/SchemaSpec.hs new file mode 100644 --- /dev/null +++ b/test/SchemaSpec.hs @@ -0,0 +1,51 @@ +module SchemaSpec (spec, main) where + +import Control.Monad +import Data.Aeson +import Data.Proxy +import Data.Schematic +import Data.Singletons +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 '[TRegex "\\w+"]))] + +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] + +exampleObject :: JsonRepr SchemaExample +exampleObject = ReprObject $ FieldRepr exampleArray + :& FieldRepr (ReprOptional (Just (ReprText "barval"))) + :& RNil + +jsonExample :: JsonRepr SchemaExample +jsonExample = ReprObject $ + FieldRepr (ReprArray [ReprNumber 12]) + :& FieldRepr (ReprOptional (Just (ReprText "tes"))) + :& RNil + +-- schemaExample :: Sing SchemaExample +-- schemaExample = known + +spec :: Spec +spec = do + -- it "show/read JsonRepr properly" $ + -- read (show example) == example + it "decode/encode JsonRepr properly" $ + decode (encode jsonExample) == Just jsonExample + +main :: IO () +main = hspec spec diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}