medea 1.1.2 → 1.2.0

raw patch · 11 files changed

+354/−326 lines, 11 filesdep +smashdep ~QuickCheckdep ~basedep ~bytestringPVP ok

version bump matches the API change (PVP)

Dependencies added: smash

Dependency ranges changed: QuickCheck, base, bytestring, hspec, hspec-core, megaparsec

API changes (from Hackage documentation)

Files

• CHANGELOG.md +9/−0
• LICENSE.md +21/−0
• TUTORIAL.md +2/−3
• medea.cabal +26/−40
• src/Data/Medea.hs +165/−133
• src/Data/Medea/Analysis.hs +9/−0
• src/Data/Medea/Loader.hs +91/−103
• test/TestM.hs +1/−14
• test/parser/Main.hs +3/−3
• test/schema-builder/Main.hs +3/−3
• test/validator-quickcheck/Main.hs +24/−27

@@ -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.

@@ -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.

@@ -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"

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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)

@@ -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)

@@ -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