Adds support for extensible validation

The new `Validator` associated type and `FleeceValidator` superclass constraint on the `Fleece` class allow extensions to validation beyond lifting Haskell functions via constraints on the `Validator schema` type. See the `CustomValidator` class and `SchemaValidatorInfo` instance in `json-fleece-examples` for an example.
flipstone · Aug 16, 2024 · d5d98fe · d5d98fe
1 parent 21c4214
commit d5d98fe
Show file tree

Hide file tree

Showing 35 changed files with 504 additions and 134 deletions.
diff --git a/json-fleece-aeson-beeline/json-fleece-aeson-beeline.cabal b/json-fleece-aeson-beeline/json-fleece-aeson-beeline.cabal
@@ -37,7 +37,7 @@ library
     , beeline-http-client >=0.2 && <0.9
     , bytestring ==0.11.*
     , http-client ==0.7.*
-    , json-fleece-aeson >=0.1 && <0.4
+    , json-fleece-aeson >=0.1 && <0.5
   default-language: Haskell2010
   if flag(strict)
     ghc-options: -Weverything -Werror -Wno-missing-local-signatures -Wno-monomorphism-restriction -Wno-missing-kind-signatures -Wno-prepositive-qualified-module -Wno-implicit-prelude -Wno-safe -Wno-unsafe -Wno-missing-safe-haskell-mode -Wno-missing-deriving-strategies -Wno-all-missed-specialisations -Wno-missed-specialisations -Wno-unticked-promoted-constructors

diff --git a/json-fleece-aeson-beeline/package.yaml b/json-fleece-aeson-beeline/package.yaml
@@ -49,10 +49,10 @@ when:
 library:
   source-dirs: src
   dependencies:
-    - json-fleece-aeson >= 0.1 && < 0.4
     - beeline-http-client >= 0.2 && < 0.9
     - bytestring >= 0.11 && < 0.12
     - http-client >= 0.7 && < 0.8
+    - json-fleece-aeson >= 0.1 && < 0.5
   exposed-modules:
     - Fleece.Aeson.Beeline
 
diff --git a/json-fleece-aeson/json-fleece-aeson.cabal b/json-fleece-aeson/json-fleece-aeson.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           json-fleece-aeson
-version:        0.3.5.0
+version:        0.4.0.0
 description:    Please see the README on GitHub at <https://github.com/githubuser/json-fleece-aeson#readme>
 homepage:       https://github.com/flipstone/json-fleece#readme
 bug-reports:    https://github.com/flipstone/json-fleece/issues
@@ -41,7 +41,7 @@ library
     , base >=4.7 && <5
     , bytestring ==0.11.*
     , containers ==0.6.*
-    , json-fleece-core ==0.7.*
+    , json-fleece-core ==0.8.*
     , shrubbery ==0.2.*
     , text >=1.2 && <2.1
     , vector >=0.12 && <0.14
@@ -66,7 +66,7 @@ test-suite json-fleece-aeson-test
     , containers ==0.6.*
     , hedgehog
     , json-fleece-aeson
-    , json-fleece-core ==0.7.*
+    , json-fleece-core ==0.8.*
     , json-fleece-examples
     , scientific >=0.3.7 && <0.4
     , shrubbery ==0.2.*

diff --git a/json-fleece-aeson/package.yaml b/json-fleece-aeson/package.yaml
@@ -1,5 +1,5 @@
 name:                json-fleece-aeson
-version:             0.3.5.0
+version:             0.4.0.0
 github:              "flipstone/json-fleece/json-fleece-aeson"
 license:             BSD3
 author:              "Author name here"
@@ -16,14 +16,14 @@ copyright:           "2023 Author name here"
 description:         Please see the README on GitHub at <https://github.com/githubuser/json-fleece-aeson#readme>
 
 dependencies:
-- base >= 4.7 && < 5
 - aeson >= 2.0 && < 2.2
+- base >= 4.7 && < 5
 - bytestring >= 0.11 && < 0.12
 - containers >= 0.6 && < 0.7
-- json-fleece-core >= 0.7 && < 0.8
+- json-fleece-core >= 0.8 && < 0.9
+- shrubbery >= 0.2 && < 0.3
 - text >= 1.2 && < 2.1
 - vector >= 0.12 && < 0.14
-- shrubbery >= 0.2 && < 0.3
 
 flags:
   strict:

diff --git a/json-fleece-aeson/src/Fleece/Aeson/AnyJSON.hs b/json-fleece-aeson/src/Fleece/Aeson/AnyJSON.hs
@@ -14,7 +14,7 @@ import qualified Fleece.Core as FC
 
 aesonValue :: FC.Fleece schema => schema Aeson.Value
 aesonValue =
-  FC.transform valueToAnyJSON anyJSONToValue FC.anyJSON
+  FC.validate (FC.transform valueToAnyJSON anyJSONToValue) FC.anyJSON
 
 anyJSONToValue :: FC.AnyJSON -> Aeson.Value
 anyJSONToValue =

diff --git a/json-fleece-aeson/src/Fleece/Aeson/Decoder.hs b/json-fleece-aeson/src/Fleece/Aeson/Decoder.hs
@@ -71,6 +71,8 @@ instance FC.Fleece Decoder where
   newtype TaggedUnionMembers Decoder allTags _handledTags
     = TaggedUnionMembers (Map.Map T.Text (Aeson.Object -> AesonTypes.Parser (Shrubbery.TaggedUnion allTags)))
 
+  type Validator Decoder = FC.StandardValidator
+
   schemaName (Decoder name _parseValue) =
     name
 
@@ -172,10 +174,10 @@ instance FC.Fleece Decoder where
                   <> " enum: "
                   <> show textValue
 
-  validateNamed name _uncheck check (Decoder _unvalidatedName parseValue) =
+  validateNamed name validator (Decoder _unvalidatedName parseValue) =
     Decoder name $ \jsonValue -> do
       uncheckedValue <- parseValue jsonValue
-      case check uncheckedValue of
+      case FC.check validator uncheckedValue of
         Right checkedValue -> pure checkedValue
         Left err -> fail $ "Error validating " <> FC.nameToString name <> ": " <> err
 

diff --git a/json-fleece-aeson/src/Fleece/Aeson/Encoder.hs b/json-fleece-aeson/src/Fleece/Aeson/Encoder.hs
@@ -56,6 +56,8 @@ instance FC.Fleece Encoder where
   newtype TaggedUnionMembers Encoder _allTags handledTags
     = TaggedUnionMembers (Shrubbery.TaggedBranchBuilder handledTags (T.Text, Aeson.Series))
 
+  type Validator Encoder = FC.StandardValidator
+
   schemaName (Encoder name _toEncoding) =
     name
 
@@ -128,8 +130,8 @@ instance FC.Fleece Encoder where
   boundedEnumNamed name toText =
     Encoder name (Aeson.toEncoding . toText)
 
-  validateNamed name uncheck _check (Encoder _unvalidatedName toEncoding) =
-    Encoder name (toEncoding . uncheck)
+  validateNamed name validator (Encoder _unvalidatedName toEncoding) =
+    Encoder name (toEncoding . FC.uncheck validator)
 
   unionNamed name (UnionMembers builder) =
     let

diff --git a/json-fleece-aeson/src/Fleece/Aeson/EncoderDecoder.hs b/json-fleece-aeson/src/Fleece/Aeson/EncoderDecoder.hs
@@ -39,6 +39,8 @@ instance FC.Fleece EncoderDecoder where
     , taggedUnionMembersDecoder :: FC.TaggedUnionMembers Decoder allTags handledTags
     }
 
+  type Validator EncoderDecoder = FC.StandardValidator
+
   schemaName = FC.schemaName . encoder
 
   number =
@@ -127,10 +129,10 @@ instance FC.Fleece EncoderDecoder where
           FC.additional (objectDecoder object) (additionalFieldsDecoder addFields)
       }
 
-  validateNamed name uncheck check itemEncoderDecoder =
+  validateNamed name validator itemEncoderDecoder =
     EncoderDecoder
-      { encoder = FC.validateNamed name uncheck check $ encoder itemEncoderDecoder
-      , decoder = FC.validateNamed name uncheck check $ decoder itemEncoderDecoder
+      { encoder = FC.validateNamed name validator $ encoder itemEncoderDecoder
+      , decoder = FC.validateNamed name validator $ decoder itemEncoderDecoder
       }
 
   boundedEnumNamed name toText =

diff --git a/json-fleece-aeson/test/Spec.hs b/json-fleece-aeson/test/Spec.hs
@@ -72,6 +72,7 @@ tests =
   , ("prop_decode_taggedUnion", prop_decode_taggedUnion)
   , ("prop_encode_taggedUnion", prop_encode_taggedUnion)
   , ("prop_utcTimeAndZonedTime", prop_utcTimeAndZonedTime)
+  , ("prop_decode_CustomValidatorObject", prop_decode_CustomValidatorObject)
   ]
 
 prop_decode_number :: HH.Property
@@ -779,6 +780,32 @@ prop_utcTimeAndZonedTime =
         Right (Time.zonedTimeToUTC originalZonedTime)
           === decodedUTCTime
 
+prop_decode_CustomValidatorObject :: HH.Property
+prop_decode_CustomValidatorObject = HH.property $ do
+  positiveInt <- HH.forAll . Gen.int $ Range.linear 0 10
+  negativeInt <- HH.forAll . Gen.int $ Range.linear (-10) (-1)
+  let
+    validTestObject =
+      encodeTestObject $
+        [ "positive_int" .= positiveInt
+        , "negative_int" .= negativeInt
+        ]
+
+    invalidTestObject =
+      encodeTestObject $
+        [ "positive_int" .= positiveInt
+        , "negative_int" .= positiveInt
+        ]
+
+    expected =
+      Examples.CustomValidatorObject
+        { Examples.customValidatorObjectPositiveInt = Examples.PositiveInt positiveInt
+        , Examples.customValidatorObjectNegativeInt = Examples.NegativeInt negativeInt
+        }
+
+  FA.decode (FA.decoder Examples.customValidatorObjectExampleSchema) validTestObject === Right expected
+  FA.decode (FA.decoder Examples.customValidatorObjectExampleSchema) invalidTestObject === Left "Error in $['negative_int']: Error validating Fleece.Examples.NegativeInt: Too big"
+
 genAnyJSON :: HH.Gen FC.AnyJSON
 genAnyJSON =
   Gen.choice

diff --git a/json-fleece-core/json-fleece-core.cabal b/json-fleece-core/json-fleece-core.cabal
@@ -5,7 +5,7 @@ cabal-version: 1.12
 -- see: https://github.com/sol/hpack
 
 name:           json-fleece-core
-version:        0.7.0.0
+version:        0.8.0.0
 description:    Please see the README on GitHub at <https://github.com/flipstone/json-fleece-core#readme>
 homepage:       https://github.com/flipstone/json-fleece#readme
 bug-reports:    https://github.com/flipstone/json-fleece/issues
@@ -32,6 +32,7 @@ library
       Fleece.Core.Class
       Fleece.Core.Name
       Fleece.Core.Schemas
+      Fleece.Core.Validator
   other-modules:
       Paths_json_fleece_core
   hs-source-dirs:

diff --git a/json-fleece-core/package.yaml b/json-fleece-core/package.yaml
@@ -1,5 +1,5 @@
 name:                json-fleece-core
-version:             0.7.0.0
+version:             0.8.0.0
 github:              "flipstone/json-fleece/json-fleece-core"
 license:             BSD3
 author:              "Author name here"
@@ -63,4 +63,4 @@ library:
     - Fleece.Core.Class
     - Fleece.Core.Name
     - Fleece.Core.Schemas
-
+    - Fleece.Core.Validator
diff --git a/json-fleece-core/src/Fleece/Core.hs b/json-fleece-core/src/Fleece/Core.hs
@@ -37,8 +37,6 @@ module Fleece.Core
   , nullable
   , validate
   , validateNamed
-  , transform
-  , transformNamed
   , coerceSchema
   , coerceSchemaNamed
 
@@ -129,9 +127,24 @@ module Fleece.Core
   , autoQualifiedName
   , nameToString
   , annotateName
+  , defaultSchemaName
+
+    -- * Validators
+  , Validator
+  , FleeceValidator
+  , mkValidator
+  , mapUncheck
+  , mapCheck
+  , compose
+  , coercion
+  , transform
+  , identity
+  , StandardValidator (..)
+  , NoOpValidator (..)
   ) where
 
 import Fleece.Core.AnyJSON
 import Fleece.Core.Class
 import Fleece.Core.Name
 import Fleece.Core.Schemas
+import Fleece.Core.Validator
diff --git a/json-fleece-core/src/Fleece/Core/AnyJSON.hs b/json-fleece-core/src/Fleece/Core/AnyJSON.hs
@@ -38,7 +38,8 @@ import Fleece.Core.Class
   , (#|)
   )
 import Fleece.Core.Name (unqualifiedName)
-import Fleece.Core.Schemas (list, transform, unionMember)
+import Fleece.Core.Schemas (list, unionMember, validate)
+import Fleece.Core.Validator (transform)
 
 newtype AnyJSON
   = AnyJSON
@@ -150,7 +151,7 @@ handleAnyJSON handleText handleBool handleNumber handleArray handleObject handle
 
 anyJSON :: Fleece schema => schema AnyJSON
 anyJSON =
-  transform (\(AnyJSON u) -> u) AnyJSON $
+  validate (transform (\(AnyJSON u) -> u) AnyJSON) $
     unionNamed (unqualifiedName "AnyJSON") $
       unionMember text
         #| unionMember boolean

diff --git a/json-fleece-core/src/Fleece/Core/Class.hs b/json-fleece-core/src/Fleece/Core/Class.hs
@@ -11,6 +11,7 @@ module Fleece.Core.Class
       , Object
       , UnionMembers
       , TaggedUnionMembers
+      , Validator
       , schemaName
       , text
       , number
@@ -53,13 +54,15 @@ import Shrubbery (BranchIndex, Tag, TagIndex, TagType, TaggedTypes, TaggedUnion,
 import Shrubbery.TypeList (Append, Length)
 
 import Fleece.Core.Name (Name)
+import Fleece.Core.Validator (FleeceValidator)
 
-class Fleece schema where
+class FleeceValidator (Validator schema) => Fleece schema where
   data Object schema :: Type -> Type -> Type
   data Field schema :: Type -> Type -> Type
   data AdditionalFields schema :: Type -> Type -> Type
   data UnionMembers schema :: [Type] -> [Type] -> Type
   data TaggedUnionMembers schema :: [Tag] -> [Tag] -> Type
+  type Validator schema :: Type -> Type -> Type
 
   schemaName :: schema a -> Name
 
@@ -118,10 +121,9 @@ class Fleece schema where
 
   validateNamed ::
     Name ->
-    (a -> b) ->
-    (b -> Either String a) ->
-    (schema b) ->
-    (schema a)
+    Validator schema a b ->
+    schema a ->
+    schema b
 
   boundedEnumNamed ::
     (Bounded a, Enum a) =>