diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,14 @@ # Dev +# 1.2.0 + +- Widen QuickCheck bounds. +- Remove MonadError from the top-level API. +- Use strict, rather than lazy, bytestrings for parser input. This fixes issues + with resource safety. +- Test with GHC 8.8.4. +- Change `stack.yaml` to use LTS 15.15. + # 1.1.2 - Ship our .hspec file to ensure all tests pass from an sdist. diff --git a/LICENSE.md b/LICENSE.md new file mode 100644 --- /dev/null +++ b/LICENSE.md @@ -0,0 +1,21 @@ +# MIT License + +Copyright (c) 2020 Juspay Technologies + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/TUTORIAL.md b/TUTORIAL.md --- a/TUTORIAL.md +++ b/TUTORIAL.md @@ -287,7 +287,6 @@ To validate a JSON value using Medea from Haskell: ```Haskell -import Control.Monad.Trans.Except (runExcept, runExceptT) import Data.Aeson (Value) import Data.Medea.Loader (loadSchemaFromFile) import Data.Medea (validate) @@ -295,12 +294,12 @@ main :: IO () main = do -- Compile a Medea schema graph from its file representation - result <- runExceptT . loadSchemaFromFile $ "./my-schema.medea" + result <- loadSchemaFromFile "./my-schema.medea" case result of Left e -> print e Right scm -> do -- Validate against the schema graph we just compiled - validation <- runExcept $ validate scm (myJson :: Value) + validation <- validate scm (myJson :: Value) case validation of Left e -> print e Right _ -> putStrLn "JSON is valid against schema" diff --git a/medea.cabal b/medea.cabal --- a/medea.cabal +++ b/medea.cabal @@ -1,6 +1,6 @@ cabal-version: 2.2 name: medea -version: 1.1.2 +version: 1.2.0 synopsis: A schema language for JSON. description: A reference implementation of a schema language, together with a conformance @@ -9,6 +9,7 @@ homepage: https://github.com/juspay/medea bug-reports: https://github.com/juspay/medea/issues license: MIT +license-file: LICENSE.md author: Koz Ross, Shaurya Gupta @@ -17,7 +18,7 @@ copyright: Juspay Technologies Pvt Ltd (C) 2020 category: Data build-type: Simple -tested-with: GHC ==8.6.5 || ==8.8.3 || ==8.10.1 +tested-with: GHC ==8.6.5 || ==8.8.4 || ==8.10.1 extra-source-files: CHANGELOG.md README.md @@ -36,13 +37,24 @@ common lang-common default-language: Haskell2010 + build-depends: base >=4.11.1 && <5 ghc-options: -Wall -Wcompat -Wincomplete-record-updates -Wincomplete-uni-patterns -Wredundant-constraints common test-common - ghc-options: -threaded -with-rtsopts=-N + import: lang-common + other-modules: TestM + build-depends: + , directory ^>=1.3.3.0 + , filepath ^>=1.4.2.1 + , hspec ^>=2.7.1 + , medea + , mtl + ghc-options: -threaded -with-rtsopts=-N + hs-source-dirs: test + library import: lang-common exposed-modules: Data.Medea @@ -63,9 +75,8 @@ Data.Medea.ValidJSON build-depends: - , aeson ^>=1.4.6.0 + , aeson >=1.4.6.0 && <2.0.0.0 , algebraic-graphs ^>=0.5 - , base >=4.11.1 && <5 , bytestring ^>=0.10.8.2 , containers ^>=0.6.0.1 , deepseq ^>=1.4.4.0 @@ -77,6 +88,7 @@ , nonempty-containers ^>=0.3.3.0 , parser-combinators >=1.1.0 && <2.0.0 , scientific ^>=0.3.6.2 + , smash ^>=0.1.1.0 , text ^>=1.2.3.1 , unordered-containers ^>=0.2.10.0 , vector ^>=0.12.0.3 @@ -85,56 +97,30 @@ hs-source-dirs: src test-suite conformance-parser - import: lang-common, test-common + import: test-common type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: TestM - build-depends: - , base - , directory ^>=1.3.3.0 - , filepath ^>=1.4.2.1 - , hspec ^>=2.7.1 - , medea - , mtl - - hs-source-dirs: test/parser test + hs-source-dirs: test/parser test-suite conformance-schema-builder - import: lang-common, test-common + import: test-common type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: TestM - build-depends: - , base - , directory ^>=1.3.3.0 - , filepath ^>=1.4.2.1 - , hspec ^>=2.7.1 - , medea - , mtl - - hs-source-dirs: test/schema-builder test + hs-source-dirs: test/schema-builder test-suite quickcheck-validator - import: lang-common, test-common + import: test-common type: exitcode-stdio-1.0 main-is: Main.hs - other-modules: - Data.Aeson.Arbitrary - TestM - + other-modules: Data.Aeson.Arbitrary build-depends: , aeson - , base - , directory ^>=1.3.3.0 - , filepath ^>=1.4.2.1 - , hspec ^>=2.7.1 + , bytestring , hspec-core ^>=2.7.1 - , medea - , mtl - , QuickCheck ^>=2.13.2 + , QuickCheck >=2.13.2 && <2.15.0 , quickcheck-instances ^>=0.3.22 , text , unordered-containers ^>=0.2.10.0 , vector - hs-source-dirs: test/validator-quickcheck test + hs-source-dirs: test/validator-quickcheck diff --git a/src/Data/Medea.hs b/src/Data/Medea.hs --- a/src/Data/Medea.hs +++ b/src/Data/Medea.hs @@ -4,6 +4,8 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Trustworthy #-} {-# LANGUAGE TupleSections #-} @@ -27,17 +29,16 @@ -- loaded. -- -- > import Data.Medea (loadSchemaFromFile, validateFromFile) --- > import Control.Monad.Except (runExceptT) -- > -- > main :: IO () -- > main = do -- > -- try to load the schema graph file --- > loaded <- runExceptT . loadSchemaFromFile $ "/path/to/schema.medea" +-- > loaded <- loadSchemaFromFile "/path/to/schema.medea" -- > case loaded of -- > Left err -> print err -- or some other handling -- > Right scm -> do -- > -- try to validate --- > validated <- runExceptT . validateFromFile scm $ "/path/to/my.json" +-- > validated <- validateFromFile scm "/path/to/my.json" -- > case validated of -- > Left err -> print err -- or some other handling -- > Right validJson -> print validJson -- or some other useful thing @@ -66,26 +67,28 @@ ) where -import Control.Applicative ((<|>), Alternative) +import Control.Applicative (Alternative (..)) import Control.Comonad.Cofree (Cofree (..)) import Control.DeepSeq (NFData (..)) -import Control.Monad (MonadPlus, unless, when) +import Control.Monad (unless) import Control.Monad.Except (MonadError (..)) import Control.Monad.IO.Class (MonadIO (..)) -import Control.Monad.Reader (MonadReader, asks, runReaderT) -import Control.Monad.State.Strict (MonadState (..), evalStateT, gets) -import Data.Aeson (Array, Object, Value (..), decode) -import qualified Data.ByteString.Lazy as BS -import Data.ByteString.Lazy (ByteString) +import Control.Monad.RWS.Strict (RWST (..), evalRWST) +import Control.Monad.Reader (MonadReader, asks) +import Control.Monad.State.Strict (MonadState (..), gets) +import Data.Aeson (Array, Object, Value (..), decodeStrict) +import qualified Data.ByteString as BS +import Data.ByteString (ByteString) +import Data.Can (Can (..)) import Data.Coerce (coerce) import Data.Data (Data) import Data.Foldable (asum, traverse_) import Data.Functor (($>)) +import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM import Data.Hashable (Hashable (..)) import qualified Data.Map.Strict as M -import Data.Maybe (isNothing) -import Data.Medea.Analysis (ArrayType (..), CompiledSchema (..), TypeNode (..)) +import Data.Medea.Analysis (ArrayType (..), CompiledSchema (..), TypeNode (..), arrayBounds) import Data.Medea.JSONType (JSONType (..), typeOf) import Data.Medea.Loader ( LoaderError (..), @@ -94,7 +97,7 @@ loadSchemaFromHandle, ) import Data.Medea.Parser.Primitive (Identifier (..), ReservedIdentifier (..), identFromReserved) -import Data.Medea.Parser.Types (ParseError(..)) +import Data.Medea.Parser.Types (ParseError (..)) import Data.Medea.Schema (Schema (..)) import Data.Medea.ValidJSON (ValidJSONF (..)) import qualified Data.Set as S @@ -108,7 +111,7 @@ import Data.Text (Text) import qualified Data.Vector as V import GHC.Generics (Generic) -import System.IO (Handle, hSetBinaryMode) +import System.IO (Handle) -- | An annotation, describing which schema a given chunk of JSON was deemed to -- be valid against. @@ -172,28 +175,36 @@ | -- | We could not parse JSON out of what we were provided. NotJSON | -- | We got a type different to what we expected. - WrongType - !Value -- ^ The chunk of JSON. - !JSONType -- ^ What we expected the type to be. + WrongType + !Value + -- ^ The chunk of JSON. + !JSONType + -- ^ What we expected the type to be. | -- | We expected one of several possibilities, but got something that fits -- none. NotOneOfOptions !Value | -- | We found a JSON object with a property that wasn't specified in its -- schema, and additional properties are forbidden. - AdditionalPropFoundButBanned - {-# UNPACK #-} !Text -- ^ The property in question. - {-# UNPACK #-} !Text -- ^ The name of the specifying schema. + AdditionalPropFoundButBanned + {-# UNPACK #-} !Text + -- ^ The property in question. + {-# UNPACK #-} !Text + -- ^ The name of the specifying schema. | -- | We found a JSON object which is missing a property its schema requires. - RequiredPropertyIsMissing - {-# UNPACK #-} !Text -- ^ The property in question. - {-# UNPACK #-} !Text -- ^ The name of the specifying schema. - | -- | We found a JSON array which falls outside of the minimum or maximum + RequiredPropertyIsMissing + {-# UNPACK #-} !Text + -- ^ The property in question. + {-# UNPACK #-} !Text + -- ^ The name of the specifying schema. + | -- | We found a JSON array which falls outside of the minimum or maximum -- length constraints its corresponding schema demands. - OutOfBoundsArrayLength - {-# UNPACK #-} !Text -- ^ The name of the specifying schema. - !Value -- ^ The JSON chunk corresponding to the invalid array. + OutOfBoundsArrayLength + {-# UNPACK #-} !Text + -- ^ The name of the specifying schema. + !Value + -- ^ The JSON chunk corresponding to the invalid array. | -- | This is a bug - please report it to us! - ImplementationError + ImplementationError {-# UNPACK #-} !Text -- some descriptive text deriving stock (Eq, Show, Generic) deriving anyclass (Hashable) @@ -205,174 +216,195 @@ instance Monoid ValidationError where mempty = EmptyError --- | Attempt to construct validated JSON from a bytestring. +-- | Attempt to construct validated JSON from a strict bytestring. -- This will attempt to decode using Aeson before validating. -validate :: - (MonadPlus m, MonadError ValidationError m) => - Schema -> - ByteString -> - m ValidatedJSON -validate scm bs = case decode bs of +-- +-- If this fails, it will return the first failure condition; that is, the one +-- caused by the first node in a depth-first, right-to-left, document-order +-- traversal of the input JSON. +validate :: Schema -> ByteString -> Either ValidationError ValidatedJSON +validate scm bs = case decodeStrict bs of Nothing -> throwError NotJSON Just v -> ValidatedJSON <$> go v where - go v = runReaderT (evalStateT (checkTypes v) (initialSet, Nothing)) scm + go v = + fmap fst . evalRWST (runValidationM . checkTypes $ v) scm $ (initialSet, Nothing) initialSet = singleton . CustomNode . identFromReserved $ RStart -- | Helper for construction of validated JSON from a JSON file. --- This will attempt to decode using Aeson before validating. +-- This will attempt to decode using Aeson before validating. This will return +-- errors on failure in the same way as 'validate' does. +-- +-- This will clean up any file handle(s) if any exceptions are thrown. validateFromFile :: - (MonadPlus m, MonadError ValidationError m, MonadIO m) => + (MonadIO m) => Schema -> FilePath -> - m ValidatedJSON -validateFromFile scm fp = do - bs <- liftIO (BS.readFile fp) - validate scm bs + m (Either ValidationError ValidatedJSON) +validateFromFile scm = fmap (validate scm) . liftIO . BS.readFile --- | Helper for construction of validated JSON from a 'Handle'. --- This will set the argument 'Handle' to binary mode, as this function won't --- work otherwise. This function will close the 'Handle' once it finds EOF. --- This will attempt to decode using Aeson before validating. +-- | Helper for construction of validated JSON from a 'Handle'. This will +-- attempt to decode using Aeson before validating. This will return errors on +-- failure in the same way as 'validate' does. +-- +-- This will close the 'Handle' upon finding EOF, or if an exception is thrown. validateFromHandle :: - (MonadPlus m, MonadError ValidationError m, MonadIO m) => + (MonadIO m) => Schema -> Handle -> - m ValidatedJSON -validateFromHandle scm h = do - liftIO (hSetBinaryMode h True) - bs <- liftIO (BS.hGetContents h) - validate scm bs + m (Either ValidationError ValidatedJSON) +validateFromHandle scm = fmap (validate scm) . liftIO . BS.hGetContents -- Helpers +newtype ValidationM a = ValidationM + { runValidationM :: + RWST + Schema + () + (NESet TypeNode, Maybe Identifier) + (Either ValidationError) + a + } + deriving newtype + ( Functor, + Applicative, + Monad, + MonadReader Schema, + MonadState (NESet TypeNode, Maybe Identifier), + MonadError ValidationError + ) + +instance Alternative ValidationM where + empty = ValidationM . RWST $ \_ _ -> Left EmptyError + ValidationM comp1 <|> ValidationM comp2 = ValidationM . RWST $ go + where + go r s = case runRWST comp1 r s of + Left err -> case runRWST comp2 r s of + Left _ -> Left err + Right res -> Right res + Right res -> Right res + +failWith :: ValidationError -> ValidationM a +failWith err = ValidationM . RWST $ \_ _ -> Left err + -- We have 3 different cases: -- 1. If we are checking against AnyNode, we ALWAYS succeed. -- 2. If we are checking against PrimitiveNode, we can match with EXACTLY ONE -- kind of PrimitiveNode. -- 3. If we are checking against CustomNode, we can match against ANY CustomNode. -- Thus, we must try all of them. -checkTypes :: - (Alternative m, MonadReader Schema m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) => - Value -> - m (Cofree ValidJSONF SchemaInformation) +checkTypes :: Value -> ValidationM (Cofree ValidJSONF SchemaInformation) checkTypes v = checkAny v <|> checkPrim v <|> checkCustoms v -- checkAny throws EmptyError if AnyNode is not found. This lets checkTypes -- use the error thrown by checkPrim/checkCustoms if checkAny fails. -checkAny :: - (Alternative m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) => - Value -> - m (Cofree ValidJSONF SchemaInformation) +checkAny :: Value -> ValidationM (Cofree ValidJSONF SchemaInformation) checkAny v = do - minNode <- gets $ findMin . fst -- AnyNode is the smallest possible TypeNode. + minNode <- gets (findMin . fst) case minNode of - AnyNode -> pure $ AnySchema :< AnythingF v - _ -> throwError EmptyError + AnyNode -> pure (AnySchema :< AnythingF v) + _ -> failWith EmptyError -- checkPrim searches the NESet for the PrimitiveNode corresponding to the Value, otherwise throws an error. -checkPrim :: - (Alternative m, MonadReader Schema m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) => - Value -> - m (Cofree ValidJSONF SchemaInformation) +checkPrim :: Value -> ValidationM (Cofree ValidJSONF SchemaInformation) checkPrim v = do - (nodes, par) <- gets id - unless (member (PrimitiveNode . typeOf $ v) nodes) $ throwError . NotOneOfOptions $ v + (nodes, par) <- get + unless (member (PrimitiveNode . typeOf $ v) nodes) (failWith . NotOneOfOptions $ v) case v of - Null -> pure $ NullSchema :< NullF - Bool b -> pure $ BooleanSchema :< BooleanF b - Number n -> pure $ NumberSchema :< NumberF n + Null -> pure (NullSchema :< NullF) + Bool b -> pure (BooleanSchema :< BooleanF b) + Number n -> pure (NumberSchema :< NumberF n) String s -> case par of - -- if we are checking against a dependant string, we match against the supplied values - Nothing -> pure $ StringSchema :< StringF s + -- if we are checking a dependent string, we match against the supplied + -- values + Nothing -> pure (StringSchema :< StringF s) Just parIdent -> do scm <- lookupSchema parIdent let validVals = stringVals scm - if s `V.elem` validVals || null validVals - then pure $ StringSchema :< StringF s - else throwError $ NotOneOfOptions v + if + | V.length validVals == 0 -> pure (StringSchema :< StringF s) + | s `V.elem` validVals -> pure (StringSchema :< StringF s) + | otherwise -> failWith . NotOneOfOptions $ v Array arr -> case par of Nothing -> put (anySet, Nothing) >> (ArraySchema :<) . ArrayF <$> traverse checkTypes arr Just parIdent -> checkArray arr parIdent Object obj -> case par of - -- Fast Path (no object spec) - Nothing -> put (anySet, Nothing) >> (ObjectSchema :<) . ObjectF <$> traverse checkTypes obj + -- Fast path (no object spec) + Nothing -> + put (anySet, Nothing) >> (ObjectSchema :<) . ObjectF <$> traverse checkTypes obj Just parIdent -> checkObject obj parIdent --- check if the array length is within the specification range. -checkArray :: - (Alternative m, MonadReader Schema m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) => - Array -> - Identifier -> - m (Cofree ValidJSONF SchemaInformation) +-- check if the array satisfies the corresponding specification. +checkArray :: Array -> Identifier -> ValidationM (Cofree ValidJSONF SchemaInformation) checkArray arr parIdent = do scm <- lookupSchema parIdent - let arrLen = fromIntegral $ V.length arr - when - ( maybe False (arrLen <) (minArrayLen scm) - || maybe False (arrLen >) (maxArrayLen scm) - ) - $ throwError . OutOfBoundsArrayLength (textify parIdent) . Array - $ arr - let valsAndTypes = pairValsWithTypes $ arrayTypes scm - checkedArray <- traverse (\(val, typeNode) -> put (singleton typeNode, Nothing) >> checkTypes val) valsAndTypes - pure $ ArraySchema :< ArrayF checkedArray + let arrLen = fromIntegral . V.length $ arr + maybe (failWith outOfBounds) pure $ case arrayBounds scm of + Non -> Just () -- no bounds, so any array will do + One lo -> unless (arrLen >= lo) Nothing + Eno hi -> unless (arrLen <= hi) Nothing + Two lo hi -> unless (arrLen >= lo && arrLen <= hi) Nothing + let valsAndTypes = pairValsWithTypes . arrayTypes $ scm + checkedArray <- traverse go valsAndTypes + pure (ArraySchema :< ArrayF checkedArray) where - pairValsWithTypes Nothing = fmap (,AnyNode) arr - pairValsWithTypes (Just (ListType node)) = fmap (,node) arr - pairValsWithTypes (Just (TupleType nodes)) = V.zip arr nodes + outOfBounds = OutOfBoundsArrayLength (textify parIdent) . Array $ arr + pairValsWithTypes = \case + Nothing -> (,AnyNode) <$> arr + Just (ListType node) -> (,node) <$> arr + Just (TupleType nodes) -> V.zip arr nodes + go (val, typeNode) = do + put (singleton typeNode, Nothing) + checkTypes val -- check if object properties satisfy the corresponding specification. -checkObject :: - (Alternative m, MonadReader Schema m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) => - Object -> - Identifier -> - m (Cofree ValidJSONF SchemaInformation) +checkObject :: Object -> Identifier -> ValidationM (Cofree ValidJSONF SchemaInformation) checkObject obj parIdent = do valsAndTypes <- pairPropertySchemaAndVal obj parIdent - checkedObj <- traverse (\(val, typeNode) -> put (singleton typeNode, Nothing) >> checkTypes val) valsAndTypes - pure $ ObjectSchema :< ObjectF checkedObj + checkedObj <- traverse go valsAndTypes + pure (ObjectSchema :< ObjectF checkedObj) + where + go (val, typeNode) = do + put (singleton typeNode, Nothing) + checkTypes val pairPropertySchemaAndVal :: - (Alternative m, MonadReader Schema m, MonadError ValidationError m) => - HM.HashMap Text Value -> - Identifier -> - m (HM.HashMap Text (Value, TypeNode)) + HashMap Text Value -> Identifier -> ValidationM (HashMap Text (Value, TypeNode)) pairPropertySchemaAndVal obj parIdent = do scm <- lookupSchema parIdent - mappedObj <- traverse (pairProperty scm) $ HM.mapWithKey (,) obj - traverse_ isMatched . HM.mapWithKey (,) $ props scm + mappedObj <- traverse (pairProperty scm) . HM.mapWithKey (,) $ obj + traverse_ isMatched . HM.mapWithKey (,) . props $ scm pure mappedObj where - -- maps each property-value with the schema(typeNode) it should validate against - pairProperty scm (propName, v) = case HM.lookup propName $ props scm of + -- maps each property value with the schema it should validate against + pairProperty scm (propName, v) = case HM.lookup propName . props $ scm of Just (typeNode, _) -> pure (v, typeNode) - Nothing - | additionalProps scm -> pure (v, additionalPropSchema scm) - | otherwise -> throwError . AdditionalPropFoundButBanned (textify parIdent) $ propName - -- throws ann error if a non-optional property was not found in the object - isMatched (propName, (_, optional)) = - when (isNothing (HM.lookup propName obj) && not optional) - $ throwError . RequiredPropertyIsMissing (textify parIdent) - $ propName + Nothing -> + if additionalProps scm + then pure (v, additionalPropSchema scm) + else failWith . AdditionalPropFoundButBanned (textify parIdent) $ propName + -- throws an error if a non-optional property was not found in the object + isMatched (propName, (_, optional)) = case HM.lookup propName obj of + Nothing -> + unless optional . failWith . RequiredPropertyIsMissing (textify parIdent) $ propName + Just _ -> pure () -- checkCustoms removes all non custom nodes from the typeNode set and -- checks the Value against each until one succeeds. -checkCustoms :: - (Alternative m, MonadReader Schema m, MonadState (NESet TypeNode, Maybe Identifier) m, MonadError ValidationError m) => - Value -> - m (Cofree ValidJSONF SchemaInformation) +checkCustoms :: Value -> ValidationM (Cofree ValidJSONF SchemaInformation) checkCustoms v = do - -- Here we drop all non custom nodes. - customNodes <- gets $ dropWhileAntitone (not . isCustom) . fst + -- Here we drop all non-custom nodes + customNodes <- gets (dropWhileAntitone (not . isCustom) . fst) asum . fmap checkCustom . S.toList $ customNodes where - -- Check value against successfors of a custom node. - checkCustom (CustomNode ident) = do - neighbourhood <- typesAs <$> lookupSchema ident - put (neighbourhood, Just ident) - ($> (UserDefined . textify $ ident)) <$> checkTypes v - checkCustom _ = throwError $ ImplementationError "Unreachable code: All these nodes MUST be custom." + checkCustom = \case + CustomNode ident -> do + neighbourhood <- typesAs <$> lookupSchema ident + put (neighbourhood, Just ident) + ($> (UserDefined . textify $ ident)) <$> checkTypes v + -- TODO: Implement a safer filter to avoid having this. + _ -> failWith . ImplementationError $ "Unreachable code: these nodes must be custom." lookupSchema :: (MonadReader Schema m, MonadError ValidationError m) => Identifier -> m CompiledSchema diff --git a/src/Data/Medea/Analysis.hs b/src/Data/Medea/Analysis.hs --- a/src/Data/Medea/Analysis.hs +++ b/src/Data/Medea/Analysis.hs @@ -9,6 +9,7 @@ CompiledSchema (..), TypeNode (..), compileSchemata, + arrayBounds, ) where @@ -17,6 +18,7 @@ import Control.Applicative ((<|>)) import Control.Monad (foldM, when) import Control.Monad.Except (MonadError (..)) +import Data.Can (Can (..)) import Data.Coerce (coerce) import Data.HashMap.Strict (HashMap) import qualified Data.HashMap.Strict as HM @@ -97,6 +99,13 @@ stringVals :: {-# UNPACK #-} !(Vector Text) } deriving stock (Eq, Show) + +arrayBounds :: CompiledSchema -> Can Natural Natural +arrayBounds scm = case (minArrayLen scm, maxArrayLen scm) of + (Nothing, Nothing) -> Non + (Just lo, Nothing) -> One lo + (Nothing, Just hi) -> Eno hi + (Just lo, Just hi) -> Two lo hi data ArrayType = ListType !TypeNode diff --git a/src/Data/Medea/Loader.hs b/src/Data/Medea/Loader.hs --- a/src/Data/Medea/Loader.hs +++ b/src/Data/Medea/Loader.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} module Data.Medea.Loader ( LoaderError (..), @@ -9,8 +10,9 @@ ) where -import Control.Monad.Except (MonadError (..), runExcept) +import Control.Monad.Except (runExcept) import Control.Monad.IO.Class (MonadIO (..)) +import Data.Bifunctor (bimap) import Data.ByteString (ByteString, hGetContents, readFile) import Data.Medea.Analysis ( AnalysisError (..), @@ -32,140 +34,126 @@ NotUtf8 | -- | Parsing failed. ParsingFailed - !(ParseErrorBundle Text ParseError) -- ^ The errors we got. + !(ParseErrorBundle Text ParseError) | -- | No schema labelled @$start@ was provided. StartSchemaMissing | -- | A schema was typed in terms of itself. SelfTypingSchema | -- | A schema was defined more than once. - MultipleSchemaDefinition - {-# UNPACK #-} !Text -- ^ The multiply-defined schema name. - | -- | We expected a schema, but couldn't find it. - MissingSchemaDefinition - {-# UNPACK #-} !Text -- ^ Name of the schema we were expecting. - {-# UNPACK #-} !Text -- ^ Name of the schema that referenced it. - | -- | A schema was named with a reserved identifier (other than @start@). - SchemaNameReserved - {-# UNPACK #-} !Text -- ^ The schema name. + MultipleSchemaDefinition + {-# UNPACK #-} !Text + | -- | We expected a schema, but couldn't find it. + MissingSchemaDefinition + {-# UNPACK #-} !Text + -- ^ Name of the schema we were expecting. + {-# UNPACK #-} !Text + -- ^ Name of the schema that referenced it. + | -- | A schema was named with a reserved identifier (other than @start@). + SchemaNameReserved + {-# UNPACK #-} !Text | -- | An isolated schema was found. - IsolatedSchemata - {-# UNPACK #-} !Text -- ^ The schema name. + IsolatedSchemata + {-# UNPACK #-} !Text | -- | A property schema refers to a non-existent schema. - MissingPropSchemaDefinition - {-# UNPACK #-} !Text -- ^ Name of the non-existent schema being referenced. - {-# UNPACK #-} !Text -- ^ Name of the referencing schema. - | -- | A minimum length specification was more than its corresponding + MissingPropSchemaDefinition + {-# UNPACK #-} !Text + -- ^ Name of the non-existent schema being referenced. + {-# UNPACK #-} !Text + -- ^ Name of the referencing schema. + | -- | A minimum length specification was more than its corresponding -- maximum length specification. - MinimumLengthGreaterThanMaximum - {-# UNPACK #-} !Text -- ^ The name of the schema with the faulty specification. - | -- | A property was specified more than once. - MultiplePropSchemaDefinition - {-# UNPACK #-} !Text -- ^ Name of the parent schema. - {-# UNPACK #-} !Text -- ^ Name of the property that was defined more than once. - | -- | A list specification did not provide an element type. - MissingListSchemaDefinition - {-# UNPACK #-} !Text -- ^ Name of the missing list element type schema. - {-# UNPACK #-} !Text -- ^ Name of the parent schema. - | -- | A tuple specification does not provide a positional schema. - MissingTupleSchemaDefinition - {-# UNPACK #-} !Text -- ^ Name of the missing tuple positional schema. - {-# UNPACK #-} !Text -- ^ Name of the parent schema. + MinimumLengthGreaterThanMaximum + {-# UNPACK #-} !Text + | -- | A property was specified more than once. + MultiplePropSchemaDefinition + {-# UNPACK #-} !Text + -- ^ Name of the parent schema. + {-# UNPACK #-} !Text + -- ^ Name of the property that was defined more than once. + | -- | A list specification did not provide an element type. + MissingListSchemaDefinition + {-# UNPACK #-} !Text + -- ^ Name of the missing list element type schema. + {-# UNPACK #-} !Text + -- ^ Name of the parent schema. + | -- | A tuple specification does not provide a positional schema. + MissingTupleSchemaDefinition + {-# UNPACK #-} !Text + -- ^ Name of the missing tuple positional schema. + {-# UNPACK #-} !Text + -- ^ Name of the parent schema. | -- | Schema had a property specification, but no @$object@ type. - PropertySpecWithoutObjectType - {-# UNPACK #-} !Text -- ^ Schema name. + PropertySpecWithoutObjectType + {-# UNPACK #-} !Text | -- | Schema had a list specification, but no @$array@ type. - ListSpecWithoutArrayType - {-# UNPACK #-} !Text -- ^ Schema name. + ListSpecWithoutArrayType + {-# UNPACK #-} !Text | -- | Schema had a tuple specification, but no @$array@ type. - TupleSpecWithoutArrayType - {-# UNPACK #-} !Text -- ^ Schema name. + TupleSpecWithoutArrayType + {-# UNPACK #-} !Text | -- | Schema had a string specification, but no @$string@ type. - StringSpecWithoutStringType - {-# UNPACK #-} !Text -- ^ Schema name. + StringSpecWithoutStringType + {-# UNPACK #-} !Text deriving stock (Eq, Show) -- | Attempt to produce a schema from UTF-8 data in memory. -buildSchema :: - (MonadError LoaderError m) => - ByteString -> - m Schema +buildSchema :: ByteString -> Either LoaderError Schema buildSchema bs = do utf8 <- parseUtf8 bs spec <- fromUtf8 ":memory:" utf8 analyze spec -- | Parse and process a Medea schema graph file. -loadSchemaFromFile :: - (MonadIO m, MonadError LoaderError m) => - FilePath -> - m Schema +-- +-- Any file handle(s) will be closed if an exception is thrown. +loadSchemaFromFile :: (MonadIO m) => FilePath -> m (Either LoaderError Schema) loadSchemaFromFile fp = do contents <- liftIO . readFile $ fp - utf8 <- parseUtf8 contents - spec <- fromUtf8 fp utf8 - analyze spec + pure (parseUtf8 contents >>= fromUtf8 fp >>= analyze) -- | Load data corresponding to a Medea schema graph file from a 'Handle'. -loadSchemaFromHandle :: - (MonadIO m, MonadError LoaderError m) => - Handle -> - m Schema +-- +-- This relies on 'hGetContents' to do its work, and all caveats about the state +-- a 'Handle' can be left in afterwards apply here. +loadSchemaFromHandle :: (MonadIO m) => Handle -> m (Either LoaderError Schema) loadSchemaFromHandle h = do contents <- liftIO . hGetContents $ h - utf8 <- parseUtf8 contents - spec <- fromUtf8 (show h) utf8 - analyze spec + pure (parseUtf8 contents >>= fromUtf8 (show h) >>= analyze) -- Helper -parseUtf8 :: - (MonadError LoaderError m) => - ByteString -> - m Text -parseUtf8 = either (const (throwError NotUtf8)) pure . decodeUtf8' +parseUtf8 :: ByteString -> Either LoaderError Text +parseUtf8 = either (const (Left NotUtf8)) pure . decodeUtf8' -fromUtf8 :: - (MonadError LoaderError m) => - String -> - Text -> - m Schemata.Specification +fromUtf8 :: String -> Text -> Either LoaderError Schemata.Specification fromUtf8 sourceName utf8 = case parse Schemata.parseSpecification sourceName utf8 of - Left err -> throwError . ParsingFailed $ err + Left err -> Left . ParsingFailed $ err Right scm -> pure scm -analyze :: - (MonadError LoaderError m) => - Schemata.Specification -> - m Schema -analyze scm = case runExcept $ compileSchemata scm of - Left (DuplicateSchemaName ident) -> - throwError $ MultipleSchemaDefinition (toText ident) - Left NoStartSchema -> throwError StartSchemaMissing - Left (DanglingTypeReference danglingRef parSchema) -> - throwError $ MissingSchemaDefinition (toText danglingRef) (toText parSchema) - Left TypeRelationIsCyclic -> throwError SelfTypingSchema - Left (ReservedDefined ident) -> - throwError $ SchemaNameReserved (toText ident) - Left (DefinedButNotUsed ident) -> - throwError $ IsolatedSchemata (toText ident) - Left (DanglingTypeRefProp danglingRef parSchema) -> - throwError $ MissingPropSchemaDefinition (toText danglingRef) (toText parSchema) - Left (MinMoreThanMax ident) -> - throwError $ MinimumLengthGreaterThanMaximum (toText ident) - Left (DuplicatePropName ident prop) -> - throwError $ - MultiplePropSchemaDefinition (toText ident) (unwrap prop) - Left (DanglingTypeRefList danglingRef parSchema) -> - throwError $ MissingListSchemaDefinition (toText danglingRef) (toText parSchema) - Left (DanglingTypeRefTuple danglingRef parSchema) -> - throwError $ MissingTupleSchemaDefinition (toText danglingRef) (toText parSchema) - Left (PropertyWithoutObject schema) -> - throwError $ PropertySpecWithoutObjectType (toText schema) - Left (ListWithoutArray schema) -> - throwError $ ListSpecWithoutArrayType (toText schema) - Left (TupleWithoutArray schema) -> - throwError $ TupleSpecWithoutArrayType (toText schema) - Left (StringValsWithoutString schema) -> - throwError $ StringSpecWithoutStringType (toText schema) - Right g -> pure . Schema $ g +analyze :: Schemata.Specification -> Either LoaderError Schema +analyze = bimap translateError Schema . runExcept . compileSchemata + where + translateError = \case + DuplicateSchemaName ident -> MultipleSchemaDefinition . toText $ ident + NoStartSchema -> StartSchemaMissing + DanglingTypeReference danglingRef parSchema -> + MissingSchemaDefinition (toText danglingRef) (toText parSchema) + TypeRelationIsCyclic -> SelfTypingSchema + ReservedDefined ident -> SchemaNameReserved . toText $ ident + DefinedButNotUsed ident -> IsolatedSchemata . toText $ ident + MinMoreThanMax ident -> MinimumLengthGreaterThanMaximum . toText $ ident + DanglingTypeRefProp danglingRef parSchema -> + MissingPropSchemaDefinition (toText danglingRef) (toText parSchema) + DanglingTypeRefList danglingRef parSchema -> + MissingListSchemaDefinition (toText danglingRef) (toText parSchema) + DanglingTypeRefTuple danglingRef parSchema -> + MissingTupleSchemaDefinition (toText danglingRef) (toText parSchema) + DuplicatePropName ident prop -> + MultiplePropSchemaDefinition (toText ident) (unwrap prop) + PropertyWithoutObject schema -> + PropertySpecWithoutObjectType . toText $ schema + ListWithoutArray schema -> ListSpecWithoutArrayType . toText $ schema + TupleWithoutArray schema -> TupleSpecWithoutArrayType . toText $ schema + StringValsWithoutString schema -> + StringSpecWithoutStringType . toText $ schema diff --git a/test/TestM.hs b/test/TestM.hs --- a/test/TestM.hs +++ b/test/TestM.hs @@ -1,27 +1,14 @@ -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} - module TestM - ( TestM (..), - isParseError, + ( isParseError, isSchemaError, listMedeaFiles, - runTestM, ) where -import Control.Monad.Except (ExceptT, MonadError, runExceptT) -import Control.Monad.IO.Class (MonadIO) import Data.List (sort) import Data.Medea (LoaderError (..)) import System.Directory (listDirectory) import System.FilePath ((), isExtensionOf) - -newtype TestM a = TestM (ExceptT LoaderError IO a) - deriving (Functor, Applicative, Monad, MonadError LoaderError, MonadIO) - -runTestM :: TestM a -> IO (Either LoaderError a) -runTestM (TestM comp) = runExceptT comp isParseError :: Either LoaderError a -> Bool isParseError (Left NotUtf8) = True diff --git a/test/parser/Main.hs b/test/parser/Main.hs --- a/test/parser/Main.hs +++ b/test/parser/Main.hs @@ -3,7 +3,7 @@ import Data.Foldable (traverse_) import Data.Medea (loadSchemaFromFile) import Test.Hspec (Spec, describe, hspec, it, runIO, shouldNotSatisfy, shouldSatisfy) -import TestM (isParseError, listMedeaFiles, runTestM) +import TestM (isParseError, listMedeaFiles) main :: IO () main = do @@ -18,10 +18,10 @@ makeParseTestFail :: FilePath -> Spec makeParseTestFail fp = do - result <- runIO . runTestM . loadSchemaFromFile $ fp + result <- runIO . loadSchemaFromFile $ fp it ("Shouldn't parse: " ++ fp) (result `shouldSatisfy` isParseError) makeParseTestPass :: FilePath -> Spec makeParseTestPass fp = do - result <- runIO . runTestM . loadSchemaFromFile $ fp + result <- runIO . loadSchemaFromFile $ fp it ("Should parse: " ++ fp) (result `shouldNotSatisfy` isParseError) diff --git a/test/schema-builder/Main.hs b/test/schema-builder/Main.hs --- a/test/schema-builder/Main.hs +++ b/test/schema-builder/Main.hs @@ -11,7 +11,7 @@ runIO, shouldSatisfy, ) -import TestM (isSchemaError, listMedeaFiles, runTestM) +import TestM (isSchemaError, listMedeaFiles) main :: IO () main = do @@ -27,10 +27,10 @@ makeFailTest :: FilePath -> Spec makeFailTest fp = do - result <- runIO . runTestM . loadSchemaFromFile $ fp + result <- runIO . loadSchemaFromFile $ fp it ("Shouldn't build: " ++ fp) (result `shouldSatisfy` isSchemaError) makePassTest :: FilePath -> Spec makePassTest fp = do - result <- runIO . runTestM . loadSchemaFromFile $ fp + result <- runIO . loadSchemaFromFile $ fp it ("Should build: " ++ fp) (result `shouldSatisfy` isRight) diff --git a/test/validator-quickcheck/Main.hs b/test/validator-quickcheck/Main.hs --- a/test/validator-quickcheck/Main.hs +++ b/test/validator-quickcheck/Main.hs @@ -2,7 +2,6 @@ module Main where -import Control.Monad.Except (runExcept) import Data.Aeson (Array, Object, ToJSON, Value, Value (..), encode) import Data.Aeson.Arbitrary ( ObjGenOpts (..), @@ -16,6 +15,7 @@ isObject, isString, ) +import Data.ByteString.Lazy (toStrict) import Data.Either (isLeft, isRight) import Data.HashMap.Strict (filterWithKey, lookup) import Data.Medea (Schema, loadSchemaFromFile, validate) @@ -25,7 +25,7 @@ import Test.Hspec.Core.Spec (SpecM) import Test.QuickCheck ((==>), Gen, Property, arbitrary, forAll, property) import qualified Test.QuickCheck.Gen as Gen -import TestM (isParseError, isSchemaError, runTestM) +import TestM (isParseError, isSchemaError) import Prelude hiding (lookup) main :: IO () @@ -211,29 +211,26 @@ tuplePreds = [isObject .|| isNull, isString .|| isNumber] } -data ObjTestParams - = ObjTestParams - { objTestOpts :: ObjGenOpts, - objTestPath :: FilePath, - objTestPred :: Object -> Bool, - -- | The predice to be used on additional properties - objAdditionalPred :: Value -> Bool - } +data ObjTestParams = ObjTestParams + { objTestOpts :: ObjGenOpts, + objTestPath :: FilePath, + objTestPred :: Object -> Bool, + -- | The predice to be used on additional properties + objAdditionalPred :: Value -> Bool + } -data ListTestParams - = ListTestParams - { listTestOpts :: (Int, Int), - listTestPath :: FilePath, - elementPred :: Value -> Bool, - lenPred :: Array -> Bool - } +data ListTestParams = ListTestParams + { listTestOpts :: (Int, Int), + listTestPath :: FilePath, + elementPred :: Value -> Bool, + lenPred :: Array -> Bool + } -data TupleTestParams - = TupleTestParams - { tupleTestOpts :: (Int, Int), - tupleTestPath :: FilePath, - tuplePreds :: [Value -> Bool] - } +data TupleTestParams = TupleTestParams + { tupleTestOpts :: (Int, Int), + tupleTestPath :: FilePath, + tuplePreds :: [Value -> Bool] + } -- Helpers @@ -285,13 +282,13 @@ validationSuccess :: (ToJSON a, Show a) => Gen a -> (a -> Bool) -> Schema -> Property validationSuccess gen p scm = property $ forAll gen prop where - prop v = p v ==> isRight . runExcept . validate scm . encode $ v + prop v = p v ==> isRight . validate scm . toStrict . encode $ v -- "validation failed" property validationFail :: (ToJSON a, Show a) => Gen a -> (a -> Bool) -> Schema -> Property validationFail gen p scm = property $ forAll gen prop where - prop v = p v ==> isLeft . runExcept . validate scm . encode $ v + prop v = p v ==> isLeft . validate scm . toStrict . encode $ v -- Returns true iff the value is an object with the given property and the -- property-value satisfies the predicate. @@ -319,11 +316,11 @@ loadAndParse :: FilePath -> SpecM () Schema loadAndParse fp = do - result <- runIO . runTestM . loadSchemaFromFile $ fp + result <- runIO . loadSchemaFromFile $ fp it ("Should parse: " ++ fp) (result `shouldNotSatisfy` isParseError) it ("Should build: " ++ fp) (result `shouldNotSatisfy` isSchemaError) case result of - Left e -> error ("This should never happen: " ++ show e) + Left e -> error ("This should never happen: " <> show e) Right scm -> pure scm prependTestDir :: FilePath -> FilePath