Skip to content
New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Adds support for extensible validation #41

Closed
wants to merge 2 commits into from
+513 −134
Closed

Adds support for extensible validation #41

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
d5d98fe
Adds support for extensible validation
jlavelle Aug 16, 2024
77a30b8
Adds `Name` to `ValidatorInfo` example
jlavelle Aug 19, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
2 changes: 1 addition & 1 deletion json-fleece-aeson-beeline/json-fleece-aeson-beeline.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
2 changes: 1 addition & 1 deletion json-fleece-aeson-beeline/package.yaml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

6 changes: 3 additions & 3 deletions json-fleece-aeson/json-fleece-aeson.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand All @@ -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.*
Expand Down
8 changes: 4 additions & 4 deletions json-fleece-aeson/package.yaml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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"
Expand All @@ -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:
Expand Down
2 changes: 1 addition & 1 deletion json-fleece-aeson/src/Fleece/Aeson/AnyJSON.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down
6 changes: 4 additions & 2 deletions json-fleece-aeson/src/Fleece/Aeson/Decoder.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -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

Expand Down
6 changes: 4 additions & 2 deletions json-fleece-aeson/src/Fleece/Aeson/Encoder.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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

Expand Down Expand Up @@ -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
Expand Down
8 changes: 5 additions & 3 deletions json-fleece-aeson/src/Fleece/Aeson/EncoderDecoder.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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 =
Expand Down Expand Up @@ -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 =
Expand Down
27 changes: 27 additions & 0 deletions json-fleece-aeson/test/Spec.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
3 changes: 2 additions & 1 deletion json-fleece-core/json-fleece-core.cabal
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand All @@ -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:
Expand Down
4 changes: 2 additions & 2 deletions json-fleece-core/package.yaml
View file
Open in desktop
Original file line number Diff line number Diff line change
@@ -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"
Expand Down Expand Up @@ -63,4 +63,4 @@ library:
- Fleece.Core.Class
- Fleece.Core.Name
- Fleece.Core.Schemas

- Fleece.Core.Validator
17 changes: 15 additions & 2 deletions json-fleece-core/src/Fleece/Core.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -37,8 +37,6 @@ module Fleece.Core
, nullable
, validate
, validateNamed
, transform
, transformNamed
, coerceSchema
, coerceSchemaNamed

Expand Down Expand Up @@ -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
5 changes: 3 additions & 2 deletions json-fleece-core/src/Fleece/Core/AnyJSON.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down
12 changes: 7 additions & 5 deletions json-fleece-core/src/Fleece/Core/Class.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -11,6 +11,7 @@ module Fleece.Core.Class
, Object
, UnionMembers
, TaggedUnionMembers
, Validator
, schemaName
, text
, number
Expand Down Expand Up @@ -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
Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

This is the biggest drawback of the PR, I think. It means coming into the library the base thing to learn isn't a schema, but is now a Validator. That said, I don't have at the moment a great idea on how to change this, but the introduction/beginner friendliness is something we should consider.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

The use of type family features means the internals of fleece have never been beginner friendly. So I don't think any potential user base is lost. But it would be good to add more comments to explain the context. Something like "FleeceValidator means you can run arbitrary validation, but still have that validation serialize to e.g. OpenAPI." Not sure if that documentation should be here though.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@ysangkok Notably this isn't about the internals. This is about what you'd be exposed to as a user of the library. One might say "Oh I need an implementation of the Fleece class. Let me see what that is.." after which they would immediately be hit by another class to understand.

Copy link
Contributor

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I call it internals because you can achieve so much with Fleece by just working with examples using #+, FC.object, FC.required and FC.constructor and the base schemas. Without ever looking inside Class.hs. It wasn't the first thing I when starting to work with Fleece. So I think it's still fair to call these internals. If what's in Class.hs isn't internals, I don't know what would be. class Fleece is the very heart of it to me.

Maybe it's not important anyway, whether the heart is internal or not. Regardless of whether these are internals or not, maybe it's too complicated. It's my impression that it's worth the cost, when I heard about how even the stock schemas can be represented using these validation primitives.

If we can't get sufficient consensus that this is worthwhile, I'd prefer for this to be closed with a conclusion instead of having this linger for months.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I don't think this is the right place to worry about being beginner friendly because implementing the Fleece class isn't something that a beginner is expected to do.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

but the introduction/beginner friendliness is something we should consider

Thinking about this more. You're right that we should consider those things, and I agree that the superclass constraint makes it more difficult to understand the Fleece class. I think the superclass is an ergonomic way to model the relationship between the two classes.

Another option I considered was renaming Fleece to FleeceSchema and exporting a constraint:

type Fleece schema = (FleeceSchema schema, FleeceValidator (Validator schema))

That's probably fine too but is less pleasant to work with.

Or we could flatten the classes like this instead:

class Fleece schema where
  -- ...
  -- Use data instead of type
  data Validator schema :: Type -> Type -> Type
  
  -- ...
  -- Add the methods from the FleeceValidator class directly to Fleece
  mkValidator :: (b -> a) -> (a -> Either String b) -> Validator schema a b
  compose :: Validator schema b c -> Validator schema a b -> Validator schema a c

With the flattened approach you lose the ability to treat a validator as something distinct from a schema. I don't think it simplifies things enough to justify losing the separate FleeceValidator class.

Copy link
Member Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

@telser do you have further concerns regarding your original comment that haven't been addressed?

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

Expand Down Expand Up @@ -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) =>
Expand Down
Loading