├── ChangeLog.md ├── test ├── Spec.hs └── Jijo │ ├── PathSpec.hs │ └── DefinitionSpec.hs ├── .gitignore ├── .github └── workflows │ └── ci.yml ├── LICENSE ├── lib └── Jijo │ ├── RecordField.hs │ ├── Path.hs │ ├── RecordField │ └── TH.hs │ ├── Validation.hs │ └── Definition.hs ├── jijo.cabal └── README.md /ChangeLog.md: -------------------------------------------------------------------------------- 1 | ## 0.1 2 | 3 | * First version. 4 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | # Cabal 2 | dist 3 | dist-newstyle 4 | .cabal-sandbox/ 5 | cabal.sandbox.config 6 | cabal.project.local 7 | .ghc.environment* 8 | 9 | # Profiling 10 | *.prof 11 | 12 | # Stack 13 | .stack-work 14 | 15 | # Emacs 16 | TAGS 17 | .dir-locals.el 18 | 19 | # Vim 20 | tags 21 | *.swp 22 | -------------------------------------------------------------------------------- /.github/workflows/ci.yml: -------------------------------------------------------------------------------- 1 | name: CI 2 | 3 | on: 4 | pull_request: 5 | push: 6 | branches: [ master ] 7 | 8 | jobs: 9 | cabal-build: 10 | strategy: 11 | matrix: 12 | ghc-version: 13 | - "8.4.4" 14 | - "8.6.5" 15 | - "8.8.4" 16 | - "8.10.4" 17 | runs-on: ubuntu-latest 18 | steps: 19 | - uses: actions/checkout@v2 20 | - uses: haskell/actions/setup@v1 21 | with: 22 | cabal-version: "3.4" 23 | ghc-version: ${{ matrix.ghc-version }} 24 | - name: Cache 25 | uses: actions/cache@v1 26 | with: 27 | path: ~/.cabal 28 | key: ${{ runner.os }}-${{ matrix.ghc-version }} 29 | - name: Install dependencies 30 | run: | 31 | cabal update 32 | cabal build --only-dependencies --enable-tests --enable-benchmarks 33 | - name: Build 34 | run: cabal build --enable-tests --enable-benchmarks all 35 | - name: Run tests 36 | run: cabal test all 37 | -------------------------------------------------------------------------------- /test/Jijo/PathSpec.hs: -------------------------------------------------------------------------------- 1 | module Jijo.PathSpec (spec) where 2 | 3 | import Control.Lens hiding ((.=)) 4 | 5 | import Test.Hspec 6 | 7 | import Jijo.Path 8 | 9 | spec :: Spec 10 | spec = do 11 | test_building 12 | test_rendering 13 | 14 | test_building :: Spec 15 | test_building = describe "Building" $ do 16 | it "emptyJPathBuilder == []" $ do 17 | buildJPath emptyJPathBuilder `shouldBe` JPath [] 18 | it "addJPathSegment works" $ do 19 | buildJPath (emptyJPathBuilder 20 | & addJPathSegment (JPSField "foo") 21 | & addJPathSegment (JPSField "bar")) 22 | `shouldBe` JPath [JPSField "foo", JPSField "bar"] 23 | 24 | test_rendering :: Spec 25 | test_rendering = describe "Rendering" $ do 26 | it "empty" $ do 27 | renderJPath (JPath []) `shouldBe` "$" 28 | it "index" $ do 29 | renderJPath (JPath [JPSIndex 0]) `shouldBe` "$[0]" 30 | it "simple key" $ do 31 | renderJPath (JPath [JPSField "foo"]) `shouldBe` "$.foo" 32 | it "weird key" $ do 33 | renderJPath (JPath [JPSField "'"]) `shouldBe` "$['\\'']" 34 | it "empty key" $ do 35 | renderJPath (JPath [JPSField ""]) `shouldBe` "$['']" 36 | it "numeric key" $ do 37 | renderJPath (JPath [JPSField "10"]) `shouldBe` "$['10']" 38 | it "key + key" $ do 39 | renderJPath (JPath [JPSField "foo", JPSField "bar"]) `shouldBe` "$.foo.bar" 40 | it "key + index" $ do 41 | renderJPath (JPath [JPSField "foo", JPSIndex 10]) `shouldBe` "$.foo[10]" 42 | it "index + index" $ do 43 | renderJPath (JPath [JPSIndex 5, JPSIndex 10]) `shouldBe` "$[5][10]" 44 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2018-2019, Vladislav Zavialov and Artyom Kazak 2 | 2018-2019, Monadfix 3 | 4 | All rights reserved. 5 | 6 | Redistribution and use in source and binary forms, with or without 7 | modification, are permitted provided that the following conditions are met: 8 | 9 | * Redistributions of source code must retain the above copyright 10 | notice, this list of conditions and the following disclaimer. 11 | 12 | * Redistributions in binary form must reproduce the above 13 | copyright notice, this list of conditions and the following 14 | disclaimer in the documentation and/or other materials provided 15 | with the distribution. 16 | 17 | * Neither the name of Monadfix nor the names of other 18 | contributors may be used to endorse or promote products derived 19 | from this software without specific prior written permission. 20 | 21 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 22 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 23 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 24 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 25 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 26 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 27 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 28 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 29 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 30 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 31 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 32 | -------------------------------------------------------------------------------- /lib/Jijo/RecordField.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE KindSignatures #-} 3 | 4 | -- | This module introduces 'Field', a newtype wrapper for named record fields, 5 | -- assuming a naming convention that adds a prefix to each record field name. 6 | -- Consider this record: 7 | -- 8 | -- @ 9 | -- data User = 10 | -- MkUser { _userId :: UUID, 11 | -- _userName :: Text, 12 | -- _userAddr :: Text 13 | -- } 14 | -- 15 | -- 'Jijo.RecordField.TH.makeRecBuilder' \"_user\" ''User 16 | -- @ 17 | -- 18 | -- It has three fields: 19 | -- 20 | -- @ 21 | -- 'Field' \"_user\" \"Id\" UUID 22 | -- 'Field' \"_user\" \"Name\" Text 23 | -- 'Field' \"_user\" \"Addr\" Text 24 | -- @ 25 | -- 26 | -- This allows us to ensure the correct field order during record construction: 27 | -- 28 | -- @ 29 | -- -- Correct definition (accepted by the compiler) 30 | -- jUser = 'Jijo.Definition.defineJObject' $ 31 | -- pure recUser -- recUser generated by 'Jijo.RecordField.TH.makeRecBuilder' 32 | -- \<*\> 'Jijo.Definition.jField' \@\"Id\" \"id\" jUUID 33 | -- \<*\> 'Jijo.Definition.jField' \@\"Name\" \"name\" jText 34 | -- \<*\> 'Jijo.Definition.jField' \@\"Email\" \"email\" jText 35 | -- 36 | -- -- Erroneous definition (rejected by the compiler) 37 | -- jUser = 'Jijo.Definition.defineJObject' $ 38 | -- pure recUser -- recUser generated by 'Jijo.RecordField.TH.makeRecBuilder' 39 | -- \<*\> 'Jijo.Definition.jField' \@\"Id\" \"id\" jUUID 40 | -- \<*\> 'Jijo.Definition.jField' \@\"Email\" \"email\" jText 41 | -- \<*\> 'Jijo.Definition.jField' \@\"Name\" \"name\" jText 42 | -- @ 43 | module Jijo.RecordField where 44 | 45 | import GHC.TypeLits 46 | 47 | -- | A named record field: 48 | -- 49 | -- @ 50 | -- Field \"John Doe\" :: Field \"_user\" \"Name\" String 51 | -- @ 52 | -- 53 | -- The name and the prefix are phantom type parameters. 54 | newtype Field (prefix :: Symbol) (name :: Symbol) ty = Field ty 55 | -------------------------------------------------------------------------------- /lib/Jijo/Path.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE LambdaCase #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | 4 | -- | JSONPath definition and rendering: 5 | -- 6 | -- @ 7 | -- b :: 'JPathBuilder' 8 | -- b = 'addJPathSegment' ('JPSIndex' 3) $ 9 | -- 'addJPathSegment' ('JPSField' "fld") $ 10 | -- 'addJPathSegment' ('JPSField' "dlf") $ 11 | -- 'emptyJPathBuilder' 12 | -- 13 | -- p :: 'JPath' 14 | -- p = 'buildJPath' b 15 | -- 16 | -- ghci> 'renderJPath' p 17 | -- "$.dlf.fld[3]" 18 | -- @ 19 | module Jijo.Path 20 | ( -- * Paths 21 | JPath(..), 22 | JPathSegment(..), 23 | -- * Building 24 | JPathBuilder, 25 | emptyJPathBuilder, 26 | addJPathSegment, 27 | buildJPath, 28 | -- * Rendering 29 | renderJPath, 30 | ) where 31 | 32 | import Data.Text (Text) 33 | import Data.Char (isAlpha, isAlphaNum) 34 | 35 | import qualified Data.List as List 36 | import qualified Data.Text as Text 37 | 38 | -- | A single JSONPath segment. 39 | data JPathSegment 40 | = JPSField Text -- ^ Record field name 41 | | JPSIndex Int -- ^ Array element index 42 | deriving (Eq, Ord, Show) 43 | 44 | -- | A complete JSONPath. 45 | newtype JPath = JPath [JPathSegment] 46 | deriving (Eq, Ord, Show) 47 | 48 | -- | JSONPath segments in reverse order. Useful for fast construction of paths 49 | -- by appending path segments. 50 | newtype JPathBuilder = JPathBuilder [JPathSegment] 51 | deriving (Eq, Show) 52 | 53 | -- | A 'JPathBuilder' that does not contain any path segments. 54 | emptyJPathBuilder :: JPathBuilder 55 | emptyJPathBuilder = JPathBuilder [] 56 | 57 | -- | Append a path segment to the path. 58 | addJPathSegment :: JPathSegment -> JPathBuilder -> JPathBuilder 59 | addJPathSegment ps (JPathBuilder pss) = JPathBuilder (ps:pss) 60 | 61 | -- | Finish building a JSONPath. \( O(n) \) in the amount of segments. 62 | buildJPath :: JPathBuilder -> JPath 63 | buildJPath (JPathBuilder pss) = JPath (List.reverse pss) 64 | 65 | -- | Render a JSONPath as text. 66 | renderJPath :: JPath -> Text 67 | renderJPath (JPath ps) = "$" <> foldMap formatSegment ps 68 | where 69 | formatSegment :: JPathSegment -> Text 70 | formatSegment = \case 71 | JPSField key 72 | | isIdentifierKey key -> "." <> key 73 | | otherwise -> "['" <> escapeKey key <> "']" 74 | JPSIndex idx -> "[" <> Text.pack (show idx) <> "]" 75 | 76 | isIdentifierKey :: Text -> Bool 77 | isIdentifierKey s = case Text.uncons s of 78 | Nothing -> False 79 | Just (x, xs) -> isAlpha x && Text.all isAlphaNum xs 80 | 81 | escapeKey :: Text -> Text 82 | escapeKey = Text.concatMap escapeChar 83 | 84 | escapeChar :: Char -> Text 85 | escapeChar '\'' = "\\'" 86 | escapeChar '\\' = "\\\\" 87 | escapeChar c = Text.singleton c 88 | -------------------------------------------------------------------------------- /jijo.cabal: -------------------------------------------------------------------------------- 1 | cabal-version: 2.2 2 | name: jijo 3 | version: 0.1 4 | synopsis: Bidirectional JSON serialization 5 | description: 6 | jijo (JSON in, JSON out) is a JSON schema EDSL based on 7 | composable abstractions, @Applicative@ and @Category@. 8 | . 9 | Features include: 10 | . 11 | * Schema is independent from the domain types, unlike derived instances. 12 | * Bidirectional definitions, no risk for serialization/deserialization code 13 | to get out of sync. 14 | * Structured validation errors, not strings. 15 | * Accumulation of validation errors, not failure on the first one. 16 | 17 | license: BSD-3-Clause 18 | license-file: LICENSE 19 | extra-source-files: 20 | ChangeLog.md 21 | 22 | author: Vladislav Zavialov, Artyom Kazak 23 | maintainer: Monadfix 24 | category: Text, Web, JSON 25 | 26 | homepage: https://github.com/monadfix/jijo 27 | bug-reports: https://github.com/monadfix/jijo/issues 28 | 29 | build-type: Simple 30 | 31 | tested-with: 32 | GHC==8.4.4 33 | GHC==8.6.5 34 | GHC==8.8.1 35 | 36 | source-repository head 37 | type: git 38 | location: git://github.com/monadfix/jijo.git 39 | 40 | library 41 | exposed-modules: 42 | Jijo.Definition 43 | Jijo.Path 44 | Jijo.Validation 45 | Jijo.RecordField 46 | Jijo.RecordField.TH 47 | build-depends: 48 | base < 5, 49 | text, 50 | containers, 51 | unordered-containers, 52 | transformers, 53 | tagged, 54 | profunctors, 55 | aeson, 56 | dlist, 57 | scientific, 58 | vector, 59 | template-haskell 60 | hs-source-dirs: 61 | lib 62 | default-language: 63 | Haskell2010 64 | ghc-options: 65 | -Wall 66 | -Wcompat 67 | 68 | test-suite jijo-test 69 | type: exitcode-stdio-1.0 70 | main-is: Spec.hs 71 | other-modules: 72 | Jijo.DefinitionSpec 73 | Jijo.PathSpec 74 | hs-source-dirs: 75 | test 76 | default-extensions: 77 | DataKinds 78 | TypeOperators 79 | DeriveFunctor 80 | DeriveGeneric 81 | FlexibleInstances 82 | KindSignatures 83 | MultiParamTypeClasses 84 | ScopedTypeVariables 85 | TypeApplications 86 | StrictData 87 | LambdaCase 88 | RecordWildCards 89 | OverloadedStrings 90 | GeneralizedNewtypeDeriving 91 | DerivingStrategies 92 | UndecidableInstances 93 | RankNTypes 94 | ghc-options: 95 | -Wall 96 | -Wcompat 97 | -threaded 98 | -rtsopts 99 | -with-rtsopts=-N 100 | build-depends: 101 | aeson, 102 | base, 103 | jijo, 104 | bytestring, 105 | containers, 106 | dlist, 107 | email-validate, 108 | hedgehog, 109 | hspec, 110 | hspec-discover, 111 | hw-hspec-hedgehog, 112 | lens, 113 | lens-aeson, 114 | megaparsec, 115 | optparse-applicative, 116 | profunctors, 117 | scientific, 118 | tagged, 119 | template-haskell, 120 | text, 121 | transformers, 122 | unordered-containers, 123 | uuid, 124 | vector 125 | build-tool-depends: hspec-discover:hspec-discover 126 | default-language: Haskell2010 127 | -------------------------------------------------------------------------------- /lib/Jijo/RecordField/TH.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TemplateHaskell #-} 2 | 3 | -- | Template Haskell utilities for 'Field'. 4 | module Jijo.RecordField.TH 5 | ( module Jijo.RecordField, 6 | makeRecBuilder 7 | ) where 8 | 9 | import Data.List (foldl') 10 | import Control.Monad (when) 11 | import qualified Language.Haskell.TH as TH 12 | import Data.Coerce 13 | import Jijo.RecordField 14 | 15 | -- | Generate a smart constructor for a record that expects every field to be 16 | -- wrapped in the 'Field' newtype. 17 | -- 18 | -- Consider this record: 19 | -- @ 20 | -- data User = 21 | -- MkUser { _userId :: UUID, 22 | -- _userName :: Text, 23 | -- _userAddr :: Text 24 | -- } 25 | -- @ 26 | -- 27 | -- @'makeRecBuilder' \"_user\" ''User@ generates the following function: 28 | -- 29 | -- @ 30 | -- recUser :: 31 | -- 'Field' \"_user\" \"Id\" UUID -> 32 | -- 'Field' \"_user\" \"Name\" Text -> 33 | -- 'Field' \"_user\" \"Addr\" Text -> 34 | -- User 35 | -- recUser = 'coerce' MkUser 36 | -- @ 37 | makeRecBuilder :: String -> TH.Name -> TH.DecsQ 38 | makeRecBuilder prefixStr tyName = do 39 | info <- TH.reify tyName 40 | dec <- case info of 41 | TH.TyConI dec -> pure dec 42 | _ -> fail "Not a type declaration" 43 | (dCon, dCxt, dTyVarBndrs) <- case dec of 44 | TH.DataD cxt _ tyVarBndrs _ [con] _ -> pure (con, cxt, tyVarBndrs) 45 | TH.NewtypeD cxt _ tyVarBndrs _ con _ -> pure (con, cxt, tyVarBndrs) 46 | _ -> fail "Not a single-constructor type" 47 | let 48 | tyParam (TH.PlainTV tvName) = TH.VarT tvName 49 | tyParam (TH.KindedTV tvName tvKind) = TH.VarT tvName `TH.SigT` tvKind 50 | ty = foldl' TH.AppT (TH.ConT tyName) (map tyParam dTyVarBndrs) 51 | (conName, vbts) <- case dCon of 52 | TH.RecC conName vbts -> pure (conName, vbts) 53 | _ -> fail "Not a record type" 54 | let 55 | prefixLen = length prefixStr 56 | mkField (fieldName, _, fieldTy) = do 57 | let 58 | fieldNameStr = TH.nameBase fieldName 59 | (prefixStr', strippedFieldNameStr) = splitAt prefixLen fieldNameStr 60 | when (prefixStr' /= prefixStr) $ 61 | TH.reportError $ 62 | "Field name " ++ fieldNameStr ++ 63 | " does not have the expected prefix " ++ prefixStr 64 | return (strippedFieldNameStr, fieldTy) 65 | fields <- traverse mkField vbts 66 | let 67 | builderName = TH.mkName ("rec" ++ TH.nameBase conName) 68 | mkFieldArg (fieldNameStr, fieldTy) = 69 | TH.ConT ''Field `TH.AppT` 70 | TH.LitT (TH.StrTyLit prefixStr) `TH.AppT` 71 | TH.LitT (TH.StrTyLit fieldNameStr) `TH.AppT` 72 | fieldTy 73 | mkConArg (_, fieldTy) = fieldTy 74 | argFunTy vbt r = TH.ArrowT `TH.AppT` mkFieldArg vbt `TH.AppT` r 75 | conFunTy vbt r = TH.ArrowT `TH.AppT` mkConArg vbt `TH.AppT` r 76 | builderTy :: TH.Type 77 | builderTy = TH.ForallT dTyVarBndrs dCxt (foldr argFunTy ty fields) 78 | builderExp :: TH.Exp 79 | builderExp = TH.AppE (TH.VarE 'coerce) (TH.SigE (TH.ConE conName) (foldr conFunTy ty fields)) 80 | return 81 | [ TH.SigD builderName builderTy, 82 | TH.FunD builderName [TH.Clause [] (TH.NormalB builderExp) []] ] 83 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # jijo: Bidirectional JSON serialization 2 | 3 | [![Build Status](https://github.com/monadfix/jijo/workflows/CI/badge.svg)](https://github.com/monadfix/jijo/actions) 4 | 5 | ## Design Goals 6 | 7 | * Explicitness – decouple types and encoders/decoders (unlike autoderived 8 | instances in Aeson). 9 | 10 | * Bidirectionality – use the same definition for encoding and decoding to 11 | prevent mistakes when one side of the definition is updated and the other 12 | is not. 13 | 14 | * Completeness – collect as many validation errors as possible, instead of 15 | stopping after the first error. 16 | 17 | ## Module Structure 18 | 19 | **Core:** 20 | 21 | * `JSON.Definition` – the core of the framework, includes combinators for 22 | defining complete JSON definitions, parsing primitives, objects, sums, and 23 | adding predicates to validate complex conditions. 24 | 25 | * `JSON.Validation` – the validation machinery, complex enough to deserve 26 | its own module. 27 | 28 | * `JSON.Path` – utilities for working with 29 | [JSONPath](https://goessner.net/articles/JsonPath/), which is used for 30 | error reporting. 31 | 32 | **Records:** 33 | 34 | * `RecordField.*` – helpers for generating record constructors that make it 35 | harder to mix up fields when decoding records from JSON. 36 | 37 | ## An Example 38 | 39 | ``` 40 | $ stack repl 41 | ``` 42 | 43 | Encoding: 44 | 45 | ```haskell 46 | > uuid <- Data.UUID.V4.nextRandom 47 | 48 | > encodeViaDefinition jUUID uuid 49 | String "c7d63bec-517b-48d8-b77a-bc44d05f24af" 50 | ``` 51 | 52 | Decoding, happy path: 53 | 54 | ```haskell 55 | > import Data.Aeson 56 | 57 | > validateViaDefinition jUUID (String "c7d63bec-517b-48d8-b77a-bc44d05f24af") 58 | Right c7d63bec-517b-48d8-b77a-bc44d05f24af 59 | ``` 60 | 61 | Decoding, type mismatch: 62 | 63 | ```haskell 64 | > validateViaDefinition jUUID (Number 42) 65 | Left (JValidationReport [JTypeNotOneOf (fromList [JTyString])] (fromList [])) 66 | ``` 67 | 68 | Decoding, malformed UUID: 69 | 70 | ```haskell 71 | > validateViaDefinition jUUID (String "invalid") 72 | Left (JValidationReport [JValidationFail InvalidUUID] (fromList [])) 73 | ``` 74 | 75 | The errors are returned as a prefix tree of `JValidationError`s indexed by 76 | `JPathSegment`. They can include domain-specific errors. 77 | 78 | ## Implementation Details 79 | 80 | ### `JValidation` 81 | 82 | `JValidation` is defined as follows: 83 | 84 | ```haskell 85 | data JValidation e a = 86 | JValidation (Maybe a) (JValidationReport e) 87 | 88 | data JValidationReport e = 89 | JValidationReport [JValidationError e] (Map JPathSegment (JValidationReport e)) 90 | ``` 91 | 92 | * `e` is the type of domain-specific errors. 93 | * `j` is the validation input (for example, `JSON.Value`) 94 | * `a` is the validation result. 95 | 96 | The `Applicative` instance for `JValidation` accumulates errors from all 97 | subcomputations. We don't want to have a `Monad` instance for `JValidation` 98 | because it would violate the `(<*>) = ap` law. 99 | 100 | ### `JDefinition` 101 | 102 | `JDefinition` is a categorical (arrow) product of a validator and an encoder: 103 | 104 | ```haskell 105 | type JDefinition e = ArrPair (ValidationArr e) EncodingArr 106 | 107 | data ArrPair p q j a = ArrPair (p j a) (q j a) 108 | 109 | newtype ValidationArr e j a = 110 | ValidationArr (j -> JValidation e a) 111 | 112 | newtype EncodingArr j a = 113 | EncodingArr (a -> j) 114 | ``` 115 | 116 | It has a `Category` instance that can be used for sequential/monadic 117 | validation: any failed step of the pipeline aborts the pipeline. In most 118 | cases, a `JDefinition` can be built by using the same recipe: 119 | 120 | * narrow down the type using one of existing primitive combinators 121 | * (`jString`, `jObject`, etc), parse (probably using `jObjectDefinition`), 122 | * then add extra predicates using `jDefinition`. 123 | 124 | ### `JObjectDefinition` 125 | 126 | `JObjectDefinition` is an applicative `Product` of a validator and an encoder. 127 | It can be converted into a `JDefinition`. It does not have a `Monad` instance 128 | but it can be used for "parallel" applicative validation – all errors will be 129 | reported in parallel. 130 | 131 | ### `makeRecBuilder` 132 | 133 | `jField` uses explicit type applications so that fields would not be mixed 134 | up; `makeRecBuilder` wraps constructors into something that takes explicitly 135 | named fields. 136 | 137 | ## Future Work 138 | 139 | * Use `-XDerivingVia` instead of `coerce` once GHC 8.10 is out (due to 140 | three-release policy). 141 | 142 | * Better document how to use sum type validation. There are tests in 143 | `JSON.DefinitionSpec` but no docs yet. 144 | 145 | * TODO: comment on `BadExponent`. 146 | 147 | * Move the `Field` machinery into 148 | [`named`](http://hackage.haskell.org/package/named)? 149 | 150 | * Use something like Barbies or 151 | [`higgledy`](https://github.com/i-am-tom/higgledy) to get rid of `Field` 152 | and move field names into types? 153 | -------------------------------------------------------------------------------- /lib/Jijo/Validation.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE RankNTypes #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE TypeOperators #-} 4 | {-# LANGUAGE DerivingStrategies #-} 5 | {-# LANGUAGE UndecidableInstances #-} 6 | {-# LANGUAGE DeriveFunctor #-} 7 | {-# LANGUAGE TypeApplications #-} 8 | {-# LANGUAGE LambdaCase #-} 9 | 10 | -- | Validation of JSON input against a schema. 11 | module Jijo.Validation 12 | ( JTy(..), 13 | JValidationError(..), 14 | JValidationReport(..), 15 | isEmptyJValidationReport, 16 | scopeJValidationReport, 17 | flattenJValidationReport, 18 | renderJValidationReport, 19 | renderJValidationErrorList, 20 | JValidation(..), 21 | jValidationWarning, 22 | jValidationError, 23 | jValidationFail, 24 | jRejectExtraFields, 25 | jValidateField, 26 | jValidateOptField, 27 | jValidateElements, 28 | mapJValidationError, 29 | mapJValidationReport, 30 | eitherToJValidation, 31 | ValidationArr(..), 32 | ) where 33 | 34 | import Prelude hiding ((.), id) 35 | import Data.Text (Text) 36 | import Data.Set (Set) 37 | import Data.HashSet (HashSet) 38 | import Data.Map (Map) 39 | import Control.Category 40 | import Data.Foldable 41 | import Data.Traversable 42 | import Data.Bifunctor 43 | import Data.String 44 | import Data.Functor.Compose 45 | import qualified Control.Monad.Trans.State.Strict as State.Strict 46 | 47 | import GHC.TypeLits hiding (ErrorMessage(Text)) 48 | import qualified GHC.TypeLits as TypeLits 49 | 50 | import qualified Data.Map as Map 51 | import qualified Data.Set as Set 52 | import qualified Data.HashMap.Strict as HashMap 53 | import qualified Data.HashSet as HashSet 54 | import qualified Data.Vector as Vector 55 | import qualified Data.List as List 56 | import qualified Data.Text as Text 57 | 58 | import Jijo.Path 59 | 60 | -- | JSON value types. 61 | data JTy 62 | = JTyObject 63 | | JTyArray 64 | | JTyString 65 | | JTyNumber 66 | | JTyBool 67 | | JTyNull 68 | deriving stock (Eq, Ord, Show) 69 | 70 | -- | JSON validation error, parametrized by @e@ for domain-specific validation 71 | -- failures. 72 | -- 73 | -- @ 74 | -- data DomainError = BadUserId | PasswordTooShort 75 | -- type ValidationError = 'JValidationError' DomainError 76 | -- @ 77 | data JValidationError e 78 | = JTypeNotOneOf (Set JTy) -- ^ A value does not have the expected type, e.g. expected an object or null but got a string. 79 | | JLabelNotOneOf (Set Text) -- ^ A value of the form @{ \"label\": value }@ or @\"label\"@ has an unexpected label, 80 | -- e.g. expected @\"just\"@ or @\"nothing\"@ but got @\"candy\"@. 81 | | JMissingField Text -- ^ An object does not have a required field. 82 | | JExtraField Text -- ^ An object has an unexpected field. 83 | | JMalformedSum -- ^ A value is not a valid encoding of a sum type, 84 | -- which should have the form @{ \"label\": value }@ or @\"label\"@. 85 | | JValidationFail e -- ^ A domain-specific validation failure. 86 | deriving stock (Eq, Show) 87 | deriving stock Functor 88 | 89 | instance IsString e => IsString (JValidationError e) where 90 | fromString = JValidationFail . fromString 91 | 92 | -- | A collection of 'JValidationError', both for the root JSON value and its 93 | -- children (object fields or array elements). In other words, 94 | -- @'JValidationReport' e@ is a prefix tree where the keys are 'JPathSegment' 95 | -- and the values are @['JValidationError' e]@. 96 | data JValidationReport e = 97 | JValidationReport [JValidationError e] (Map JPathSegment (JValidationReport e)) 98 | deriving stock (Eq, Show) 99 | deriving stock Functor 100 | 101 | instance Semigroup (JValidationReport e) where 102 | JValidationReport es1 fs1 <> JValidationReport es2 fs2 = 103 | JValidationReport (es1 <> es2) (Map.unionWith (<>) fs1 fs2) 104 | 105 | instance Monoid (JValidationReport e) where 106 | mempty = JValidationReport mempty mempty 107 | 108 | -- | Associate a validation report with a child (object field or array element) 109 | -- instead of the root value. 110 | scopeJValidationReport :: JPathSegment -> JValidationReport e -> JValidationReport e 111 | scopeJValidationReport ps es = 112 | JValidationReport [] (Map.singleton ps es) 113 | 114 | -- | Check if validation was successful. 115 | isEmptyJValidationReport :: JValidationReport e -> Bool 116 | isEmptyJValidationReport (JValidationReport es fs) = 117 | null es && all isEmptyJValidationReport fs 118 | 119 | -- | Flatten the prefix trie of 'JValidationError' into a list. 120 | flattenJValidationReport :: JValidationReport e -> [(JPath, JValidationError e)] 121 | flattenJValidationReport = go emptyJPathBuilder 122 | where 123 | go pb (JValidationReport es fs) = 124 | map (\e -> (buildJPath pb, e)) es <> 125 | concatMap (goField pb) (Map.toList fs) 126 | goField pb (ps, a) = 127 | go (addJPathSegment ps pb) a 128 | 129 | -- | Validation context with an 'Applicative' instance that grants: 130 | -- 131 | -- * Accumulation of errors in a validation report (@Writer@). 132 | -- * Possibility of failure (@Maybe@). 133 | -- 134 | data JValidation e a = 135 | JValidation (Maybe a) (JValidationReport e) 136 | deriving stock Functor 137 | 138 | instance Applicative (JValidation e) where 139 | pure a = JValidation (pure a) mempty 140 | JValidation mf es1 <*> JValidation ma es2 = 141 | JValidation (mf <*> ma) (es1 <> es2) 142 | 143 | type MonadicValidationErrorMessage = 144 | 'TypeLits.Text "Monadic validation is not supported. Fit your definition into" ':$$: 145 | 'TypeLits.Text " -XApplicativeDo if possible, or use 'Category' composition" ':$$: 146 | 'TypeLits.Text " if you need to do more checks after the initial validation." 147 | 148 | instance TypeError MonadicValidationErrorMessage => Monad (JValidation e) where 149 | return = error "return @JValidation: impossible" 150 | (>>=) = error "(>>=) @JValidation: impossible" 151 | 152 | -- | A validation arrow with a 'Category' instance. This is a Kleisli arrow 153 | -- associated with 'JValidation'. 154 | newtype ValidationArr e j a = 155 | ValidationArr (j -> JValidation e a) 156 | 157 | instance Category (ValidationArr e) where 158 | id = ValidationArr pure 159 | ValidationArr f . ValidationArr g = 160 | ValidationArr $ \a -> 161 | case g a of 162 | JValidation Nothing es1 -> JValidation Nothing es1 163 | JValidation (Just b) es1 -> 164 | case f b of 165 | JValidation mc es2 -> JValidation mc (es1 <> es2) 166 | 167 | -- | Report a warning by appending an error to the root of the @JValidationReport@ 168 | -- but without aborting validation. 169 | jValidationWarning :: JValidationError e -> JValidation e () 170 | jValidationWarning e = 171 | JValidation (Just ()) (JValidationReport [e] mempty) 172 | 173 | -- | Report an error by appending an error to the root of the @JValidationReport@ 174 | -- and aborting validation. 175 | jValidationError :: JValidationError e -> JValidation e a 176 | jValidationError e = 177 | JValidation Nothing (JValidationReport [e] mempty) 178 | 179 | -- | A variant of 'jValidationError' specialized to domain-specific errors. 180 | jValidationFail :: e -> JValidation e a 181 | jValidationFail = jValidationError . JValidationFail 182 | 183 | -- | A natural transformation between 'Either' and 'JValidation'. 184 | eitherToJValidation :: Either e a -> JValidation e a 185 | eitherToJValidation = either jValidationFail pure 186 | 187 | -- | Modify the validation report using produced in 'JValidation'. 188 | mapJValidationReport :: 189 | (JValidationReport e -> JValidationReport e') -> 190 | JValidation e a -> JValidation e' a 191 | mapJValidationReport f (JValidation a es) = 192 | JValidation a (f es) 193 | 194 | -- | Modify domain-specific validation errors produced in 'JValidation'. 195 | mapJValidationError :: (e -> e') -> JValidation e a -> JValidation e' a 196 | mapJValidationError f = mapJValidationReport (fmap f) 197 | 198 | instance Bifunctor JValidation where 199 | first = mapJValidationError 200 | second = fmap 201 | 202 | -- | Report a validation warning if a JSON object contains unexpected fields. 203 | jRejectExtraFields :: 204 | HashSet Text -> 205 | HashMap.HashMap Text j -> 206 | JValidation e () 207 | jRejectExtraFields allowedFields obj = 208 | traverse_ 209 | (\fname -> jValidationWarning (JExtraField fname)) 210 | (HashSet.toList extraFields) 211 | where 212 | objFields = HashMap.keysSet obj 213 | extraFields = HashSet.difference objFields allowedFields 214 | 215 | -- | Validate a required object field. 216 | jValidateField :: 217 | Text -> 218 | (j -> JValidation e a) -> 219 | HashMap.HashMap Text j -> 220 | JValidation e a 221 | jValidateField fieldName vField o = 222 | onJust (HashMap.lookup fieldName o) $ \field -> 223 | mapJValidationReport (scopeJValidationReport (JPSField fieldName)) $ 224 | vField field 225 | where 226 | onJust Nothing _ = jValidationError (JMissingField fieldName) 227 | onJust (Just a) f = f a 228 | 229 | -- | Validate an optional object field. 230 | jValidateOptField :: 231 | Text -> 232 | (j -> JValidation e a) -> 233 | HashMap.HashMap Text j -> 234 | JValidation e (Maybe a) 235 | jValidateOptField fieldName vField o = 236 | for (HashMap.lookup fieldName o) $ \field -> 237 | mapJValidationReport (scopeJValidationReport (JPSField fieldName)) $ 238 | vField field 239 | 240 | -- | Validate array elements. 241 | jValidateElements :: 242 | (j -> JValidation e a) -> 243 | Vector.Vector j -> 244 | JValidation e (Vector.Vector a) 245 | jValidateElements vElement = 246 | itraverse $ \i element -> 247 | mapJValidationReport (scopeJValidationReport (JPSIndex i)) $ 248 | vElement element 249 | 250 | 251 | -- | Render a @JValidationReport@ into a human-readable string. 252 | renderJValidationReport :: JValidationReport String -> String 253 | renderJValidationReport = renderJValidationErrorList . flattenJValidationReport 254 | 255 | -- | Render a flattened @JValidationReport@ into a human-readable string. 256 | renderJValidationErrorList :: 257 | [(JPath, JValidationError String)] -> 258 | String 259 | renderJValidationErrorList = 260 | mconcat . List.intersperse "\n" . map formatError 261 | where 262 | formatError :: (JPath, JValidationError String) -> String 263 | formatError (path, err) = 264 | (fromString . Text.unpack) (renderJPath path) <> ": " <> 265 | case err of 266 | JTypeNotOneOf jtys -> "type not one of " <> pprSet pprJTy jtys 267 | JLabelNotOneOf jlabels -> "label not one of " <> pprSet (fromString . Text.unpack) jlabels 268 | JMissingField fname -> "missing field " <> (fromString . Text.unpack) fname 269 | JExtraField fname -> "extra field " <> (fromString . Text.unpack) fname 270 | JMalformedSum -> "malformed sum" 271 | JValidationFail e -> fromString e 272 | pprSet :: (a -> String) -> Set a -> String 273 | pprSet pprElem s = 274 | "{" <> (mconcat . List.intersperse ",") (map pprElem (Set.toList s)) <> "}" 275 | pprJTy :: JTy -> String 276 | pprJTy = \case 277 | JTyObject -> "object" 278 | JTyArray -> "array" 279 | JTyString -> "string" 280 | JTyNumber -> "number" 281 | JTyBool -> "bool" 282 | JTyNull -> "null" 283 | 284 | -- Indexed 'traverse' using 'State'. 285 | -- Does not require 'Monad' unlike 'Vector.imapM'. 286 | itraverse :: (Traversable t, Applicative f) => (Int -> a -> f b) -> t a -> f (t b) 287 | itraverse f s = State.Strict.evalState (getCompose (traverse f' s)) 0 288 | where f' a = Compose (State.Strict.state (\i -> i `seq` (f i a, i+1))) 289 | -------------------------------------------------------------------------------- /test/Jijo/DefinitionSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ApplicativeDo #-} 2 | {-# LANGUAGE OverloadedLists #-} 3 | {-# LANGUAGE TemplateHaskell #-} 4 | 5 | module Jijo.DefinitionSpec (spec) where 6 | 7 | import Prelude hiding ((.), id) 8 | import Control.Category 9 | import Control.Lens hiding ((.=)) 10 | import Data.Void 11 | import Data.Aeson as JSON hiding (encode) 12 | import Data.Aeson.Lens as JSON 13 | import Data.Set as Set 14 | import Data.Scientific as Scientific 15 | import Data.Vector as Vector 16 | import Data.Text as Text 17 | 18 | import Test.Hspec 19 | import Hedgehog 20 | import Hedgehog.Gen as Gen 21 | import Hedgehog.Range as Range 22 | import HaskellWorks.Hspec.Hedgehog 23 | 24 | import Jijo.RecordField.TH 25 | import Jijo.Path 26 | import Jijo.Definition 27 | 28 | data Pair a b = Pair { _pairFst :: a, _pairSnd :: b } 29 | deriving (Eq, Show) 30 | 31 | makeRecBuilder "_pair" ''Pair 32 | 33 | spec :: Spec 34 | spec = do 35 | test_stock 36 | test_objects 37 | test_arrays 38 | test_composition 39 | test_errors 40 | test_sums 41 | test_nullable 42 | 43 | test_stock :: Spec 44 | test_stock = describe "Stock definitions" $ do 45 | describe "jObject" $ do 46 | it "accepts only objects" $ require $ prop_accepts JTyObject _Object jObject 47 | it "encodes into an object" $ require $ prop_encodes genJObject _Object jObject 48 | describe "jArray" $ do 49 | it "accepts only arrays" $ require $ prop_accepts JTyArray _Array jArray 50 | it "encodes into an array" $ require $ prop_encodes genJArray _Array jArray 51 | describe "jString" $ do 52 | it "accepts only strings" $ require $ prop_accepts JTyString _String jString 53 | it "encodes into a string" $ require $ prop_encodes genJString _String jString 54 | describe "jNumber" $ do 55 | it "accepts only numbers" $ require $ prop_accepts JTyNumber _Number jNumber 56 | it "encodes into a number" $ require $ prop_encodes genJNumber _Number jNumber 57 | describe "jBool" $ do 58 | it "accepts only bools" $ require $ prop_accepts JTyBool _Bool jBool 59 | it "encodes into a bool" $ require $ prop_encodes genJBool _Bool jBool 60 | where 61 | -- Check that the definition only accepts JSON values of a certain type 62 | prop_accepts :: 63 | (Eq a, Show a) => 64 | JTy -> 65 | APrism' JSON.Value a -> 66 | JDefinition Void JSON.Value a -> 67 | Property 68 | prop_accepts ty ctr d = property $ do 69 | j <- forAll genJValue 70 | let val = validateViaDefinition d j 71 | case j ^? clonePrism ctr of 72 | Just x -> val === Right x 73 | _ -> val === Left (JValidationReport [JTypeNotOneOf (Set.singleton ty)] mempty) 74 | 75 | -- Check that the definition only encodes into JSON values of a certain type 76 | prop_encodes :: 77 | (Eq a, Show a) => 78 | Gen JSON.Value -> 79 | APrism' JSON.Value a -> 80 | JDefinition Void JSON.Value a -> 81 | Property 82 | prop_encodes gen ctr d = property $ do 83 | j <- forAll gen 84 | Just j === fmap (encodeViaDefinition d) (j ^? clonePrism ctr) 85 | 86 | test_objects :: Spec 87 | test_objects = describe "Object definition machinery" $ do 88 | it "encodes" $ 89 | encode (Pair True (Just False)) 90 | `shouldBe` object ["foo" .= True, "bar" .= False] 91 | it "decodes" $ 92 | validate (object ["foo" .= True, "bar" .= False]) 93 | `shouldBe` Right (Pair True (Just False)) 94 | it "fails when the value is not an object" $ do 95 | validate (JSON.Bool True) 96 | `shouldBe` Left [(JPath [], JTypeNotOneOf (Set.fromList [JTyObject]))] 97 | it "warns on extra fields" $ do 98 | validate (object ["foo" .= True, "bar" .= False, "quux" .= True]) 99 | `shouldBe` Left [(JPath [], JExtraField "quux")] 100 | it "allows extra fields" $ do 101 | validateExtraFieldsOk (object ["foo" .= True, "bar" .= False, "quux" .= True]) 102 | `shouldBe` Right (Pair True (Just False)) 103 | describe "inJField" $ do 104 | it "reports an error when the field is not found" $ 105 | validate (object ["bar" .= True]) 106 | `shouldBe` Left [(JPath [], JMissingField "foo")] 107 | it "reports an error when the field is unparseable" $ 108 | validate (object ["foo" .= (), "bar" .= True]) 109 | `shouldBe` Left [(JPath [JPSField "foo"], JTypeNotOneOf (Set.fromList [JTyBool]))] 110 | describe "inOptJField" $ do 111 | it "succeeds when the field is not found" $ 112 | validate (object ["foo" .= True, "bar" .= False]) 113 | `shouldBe` Right (Pair True (Just False)) 114 | it "reports an error when the field is unparseable" $ 115 | validate (object ["foo" .= True, "bar" .= ()]) 116 | `shouldBe` Left [(JPath [JPSField "bar"], JTypeNotOneOf (Set.fromList [JTyBool]))] 117 | it "doesn't allow null in place of a missing field" $ 118 | validate (object ["foo" .= True, "bar" .= JSON.Null]) 119 | `shouldBe` Left [(JPath [JPSField "bar"], JTypeNotOneOf (Set.fromList [JTyBool]))] 120 | it "doesn't encode anything when the field is missing" $ 121 | encode (Pair True Nothing) 122 | `shouldBe` object ["foo" .= True] 123 | where 124 | sampleDefn :: Bool -> JDefinition Void Value (Pair Bool (Maybe Bool)) 125 | sampleDefn extraFieldsOk = defineJObject $ 126 | (if extraFieldsOk then allowExtraFields else id) $ 127 | recPair <$> jField "foo" jBool <*> jFieldOpt "bar" jBool 128 | validate' extraFieldsOk = 129 | over _Left flattenJValidationReport . 130 | validateViaDefinition (sampleDefn extraFieldsOk) 131 | validate = validate' False 132 | validateExtraFieldsOk = validate' True 133 | encode = encodeViaDefinition (sampleDefn False) 134 | 135 | test_arrays :: Spec 136 | test_arrays = describe "Array definition machinery" $ do 137 | let 138 | data1234 = [[1,2],[3],[4]] 139 | json1234 = 140 | JSON.Array [ JSON.Array [JSON.Number 1, JSON.Number 2], 141 | JSON.Array [JSON.Number 3], 142 | JSON.Array [JSON.Number 4] ] 143 | it "encodes" $ encode data1234 `shouldBe` json1234 144 | it "decodes" $ validate json1234 `shouldBe` Right data1234 145 | it "reports proper path" $ 146 | validate (JSON.Array [JSON.Array [], JSON.Array [], JSON.Array [JSON.Bool True]]) 147 | `shouldBe` Left [(JPath [JPSIndex 2, JPSIndex 0], 148 | JTypeNotOneOf (Set.fromList [JTyNumber]))] 149 | where 150 | sampleDefn :: JDefinition Void Value [[Scientific]] 151 | sampleDefn = jListOf (jListOf jNumber) 152 | validate = 153 | over _Left flattenJValidationReport . 154 | validateViaDefinition sampleDefn 155 | encode = encodeViaDefinition sampleDefn 156 | 157 | test_composition :: Spec 158 | test_composition = describe "Composition of definitions" $ do 159 | it "encoding works" $ 160 | encode True `shouldBe` JSON.Bool True 161 | it "encoding works even when the condition is violated" $ 162 | encode False `shouldBe` JSON.Bool False 163 | it "decoding works" $ 164 | validate (JSON.Bool True) `shouldBe` Right True 165 | it "errors from the inner validator are present" $ 166 | validate (JSON.String "blah") 167 | `shouldBe` Left [(JPath [], JTypeNotOneOf (Set.fromList [JTyBool]))] 168 | it "errors from the outer validator are present" $ 169 | validate (JSON.Bool False) 170 | `shouldBe` Left [(JPath [], JValidationFail "bad")] 171 | where 172 | sampleDefn :: JDefinition Text Value Bool 173 | sampleDefn = 174 | jDefinition (\x -> if x then pure x else jValidationFail "bad") id . 175 | jBool 176 | validate = 177 | over _Left flattenJValidationReport . 178 | validateViaDefinition sampleDefn 179 | encode = encodeViaDefinition sampleDefn 180 | 181 | test_errors :: Spec 182 | test_errors = describe "Validation errors" $ do 183 | it "multiple errors are reported" $ 184 | validate (object []) 185 | `shouldBe` Left [(JPath [], JMissingField "eq"), 186 | (JPath [], JMissingField "neq")] 187 | it "nested errors are reported correctly" $ do 188 | validate (object ["eq" .= object ["a" .= True, "b" .= False], 189 | "neq" .= object ["b" .= ()]]) 190 | `shouldBe` Left [(JPath [JPSField "eq"], JValidationFail "!="), 191 | (JPath [JPSField "neq"], JMissingField "a"), 192 | (JPath [JPSField "neq", JPSField "b"], JTypeNotOneOf (Set.fromList [JTyBool]))] 193 | where 194 | sampleDefn :: JDefinition Text Value (Pair (Pair Bool Bool) (Pair Bool Bool)) 195 | sampleDefn = defineJObject $ do 196 | eq <- jField "eq" $ 197 | jDefinition (\p@(Pair a b) -> if a == b then pure p else jValidationFail "!=") id . 198 | defineJObject (recPair <$> jField "a" jBool <*> jField "b" jBool) 199 | neq <- jField "neq" $ 200 | jDefinition (\p@(Pair a b) -> if a /= b then pure p else jValidationFail "==") id . 201 | defineJObject (recPair <$> jField "a" jBool <*> jField "b" jBool) 202 | pure (recPair eq neq) 203 | validate = 204 | over _Left flattenJValidationReport . 205 | validateViaDefinition sampleDefn 206 | 207 | test_sums :: Spec 208 | test_sums = describe "Sum definition machinery" $ do 209 | it "encodes enum options" $ 210 | encode Nothing `shouldBe` JSON.String "nothing" 211 | it "encodes sum options" $ 212 | encode (Just True) `shouldBe` object ["just" .= JSON.Bool True] 213 | it "validates enum options" $ 214 | validate (JSON.String "nothing") `shouldBe` Right Nothing 215 | it "validates sum options" $ 216 | validate (object ["just" .= JSON.Bool False]) `shouldBe` Right (Just False) 217 | it "reports non-label types" $ 218 | validate JSON.Null `shouldBe` 219 | Left [(JPath [], JTypeNotOneOf (Set.fromList [JTyString, JTyObject]))] 220 | it "reports bad labels" $ 221 | validate (JSON.String "none") `shouldBe` 222 | Left [(JPath [], JLabelNotOneOf (Set.fromList ["nothing", "just"]))] 223 | it "reports malformed sums" $ 224 | validate (object []) `shouldBe` 225 | Left [(JPath [], JMalformedSum)] 226 | where 227 | sampleDefn :: JDefinition Text JSON.Value (Maybe Bool) 228 | sampleDefn = defineJSum $ 229 | jEnumOption "nothing" _Nothing <> 230 | jSumOption "just" _Just jBool 231 | validate = 232 | over _Left flattenJValidationReport . 233 | validateViaDefinition sampleDefn 234 | encode = encodeViaDefinition sampleDefn 235 | 236 | data Greeting = Hello | Hi 237 | deriving (Eq, Show) 238 | 239 | jGreeting :: JDefinition () JSON.Value Greeting 240 | jGreeting = 241 | jDefinition (validateGreeting . toLower) encodeGreeting . jString 242 | where 243 | encodeGreeting Hello = "hello" 244 | encodeGreeting Hi = "hi" 245 | 246 | validateGreeting "hello" = pure Hello 247 | validateGreeting "hi" = pure Hi 248 | validateGreeting _ = jValidationFail () 249 | 250 | test_nullable :: Spec 251 | test_nullable = describe "Nullable fields" $ do 252 | it "encodes null" $ 253 | encode Nothing `shouldBe` JSON.Null 254 | it "encodes non-null" $ 255 | encode (Just Hi) `shouldBe` JSON.String "hi" 256 | it "validates null" $ 257 | validate JSON.Null `shouldBe` Right Nothing 258 | it "validates non-null" $ 259 | validate (JSON.String "HeLLo") `shouldBe` Right (Just Hello) 260 | it "keeps original error" $ 261 | validate (JSON.String "nope") `shouldBe` 262 | Left [(JPath [], JValidationFail ())] 263 | it "reports that null was expected" $ 264 | validate (JSON.Bool True) `shouldBe` 265 | Left [(JPath [], JTypeNotOneOf (Set.fromList [JTyString, JTyNull]))] 266 | where 267 | sampleDefn :: JDefinition () JSON.Value (Maybe Greeting) 268 | sampleDefn = jNullable jGreeting 269 | validate = 270 | over _Left flattenJValidationReport . 271 | validateViaDefinition sampleDefn 272 | encode = encodeViaDefinition sampleDefn 273 | 274 | data SmartErr = N_gt_2 275 | 276 | data Smart = MkSmart Int Text 277 | 278 | mkSmart :: Text -> Text -> Either SmartErr Smart 279 | mkSmart s1 s2 = 280 | if n > 2 then Left N_gt_2 281 | else Right (MkSmart n (s1 <> s2)) 282 | where n = Text.length s1 283 | 284 | getSmartPrefix :: Smart -> Text 285 | getSmartPrefix (MkSmart n s) = Text.take n s 286 | 287 | getSmartSuffix :: Smart -> Text 288 | getSmartSuffix (MkSmart n s) = Text.drop n s 289 | 290 | -- TODO: test case. 291 | _jSmart :: JDefinition SmartErr JSON.Value Smart 292 | _jSmart = 293 | defineJObjectEither $ 294 | mkSmart 295 | <$> inJField "prefix" getSmartPrefix jString 296 | <*> inJField "suffix" getSmartSuffix jString 297 | 298 | ---------------------------------------------------------------------------- 299 | -- Utilities 300 | ---------------------------------------------------------------------------- 301 | 302 | genJNull :: Gen JSON.Value 303 | genJNull = pure JSON.Null 304 | 305 | genJString :: Gen JSON.Value 306 | genJString = JSON.String <$> Gen.text (Range.constant 0 5) Gen.unicode 307 | 308 | genJBool :: Gen JSON.Value 309 | genJBool = JSON.Bool <$> Gen.bool 310 | 311 | genJNumber :: Gen JSON.Value 312 | genJNumber = JSON.Number . Scientific.fromFloatDigits <$> 313 | Gen.double (Range.constant (-100) 100) 314 | 315 | genJArray :: Gen JSON.Value 316 | genJArray = do 317 | let gen = Gen.recursive Gen.choice 318 | [genJBool, genJNumber, genJString] 319 | [genJArray, genJObject] 320 | (JSON.Array . Vector.fromList) <$> Gen.list (Range.constant 0 5) gen 321 | 322 | genJObject :: Gen JSON.Value 323 | genJObject = JSON.object <$> 324 | Gen.list (Range.constant 0 5) 325 | ((,) <$> Gen.text (Range.constant 0 5) Gen.unicode <*> genJValue) 326 | 327 | genJValue :: Gen JSON.Value 328 | genJValue = 329 | Gen.choice [genJNull, genJString, genJBool, genJNumber, genJArray, genJObject] 330 | -------------------------------------------------------------------------------- /lib/Jijo/Definition.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE TypeApplications #-} 2 | {-# LANGUAGE LambdaCase #-} 3 | {-# LANGUAGE ApplicativeDo #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE TypeOperators #-} 7 | {-# LANGUAGE ExistentialQuantification #-} 8 | {-# LANGUAGE DataKinds #-} 9 | {-# LANGUAGE DerivingStrategies #-} 10 | {-# LANGUAGE ScopedTypeVariables #-} 11 | {-# LANGUAGE RankNTypes #-} 12 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 13 | {-# LANGUAGE OverloadedStrings #-} 14 | 15 | -- | A framework for building JSON schemas that can be used to perform both 16 | -- validation and serialization. 17 | module Jijo.Definition 18 | ( -- * Core 19 | JDefinition, 20 | jDefinition, 21 | validateViaDefinition, 22 | encodeViaDefinition, 23 | mapJError, 24 | EncodingArr(..), 25 | ArrPair(..), 26 | -- * Validation 27 | JTy(..), 28 | JValidationError(..), 29 | JValidationReport(..), 30 | isEmptyJValidationReport, 31 | scopeJValidationReport, 32 | flattenJValidationReport, 33 | renderJValidationReport, 34 | renderJValidationErrorList, 35 | JValidation, 36 | jValidationError, 37 | jValidationFail, 38 | mapJValidationError, 39 | eitherToJValidation, 40 | -- * Defining objects 41 | JObjectDefinition, 42 | jObjectDefinition, 43 | jObjectDefinitionEither, 44 | defineJObject, 45 | defineJObjectEither, 46 | allowExtraFields, 47 | jField, 48 | jFieldOpt, 49 | inJField, 50 | inOptJField, 51 | -- * Defining arrays 52 | jArrayOf, 53 | jListOf, 54 | -- * Defining sums 55 | defineJSum, 56 | jEnumOption, 57 | jSumOption, 58 | JSumOption(..), 59 | JSumException(..), 60 | -- * Stock definitions 61 | jObject, 62 | jArray, 63 | jString, 64 | jNumber, 65 | jBool, 66 | jNullable, 67 | -- * Aeson integration 68 | parseJSON_viaDefinition, 69 | toJSON_viaDefinition, 70 | aesonJDefinition, 71 | ) where 72 | 73 | import Prelude hiding ((.), id) 74 | import Data.Text (Text) 75 | import Data.DList (DList) 76 | import Data.Scientific (Scientific) 77 | import Data.Map (Map) 78 | import Data.HashSet (HashSet) 79 | import Data.Vector (Vector) 80 | import GHC.TypeLits as TypeLits 81 | import Control.Monad 82 | import Control.Category 83 | import Data.Coerce 84 | import Data.Maybe 85 | import Control.Exception (Exception, throw) 86 | 87 | import qualified Data.Map as Map 88 | import qualified Data.Set as Set 89 | import qualified Data.DList as DList 90 | import qualified Data.Vector as Vector 91 | import qualified Data.HashMap.Strict as HashMap 92 | import qualified Data.HashSet as HashSet 93 | import qualified Data.Aeson.Types as JSON 94 | 95 | import qualified Control.Monad.Trans.Reader as T 96 | import Data.Functor.Const 97 | import Data.Functor.Product 98 | 99 | import Data.Functor.Identity 100 | import qualified Data.Monoid as Monoid 101 | import Data.Profunctor 102 | import Data.Tagged 103 | 104 | import qualified GHC.Records as Rec 105 | 106 | import Jijo.Path 107 | import Jijo.Validation 108 | import Jijo.RecordField 109 | 110 | ---------------------------------------------------------------------------- 111 | -- Definition 112 | ---------------------------------------------------------------------------- 113 | 114 | -- | Encode @a@ as @j@. 115 | newtype EncodingArr j a = 116 | EncodingArr (a -> j) 117 | 118 | instance Category EncodingArr where 119 | id = EncodingArr id 120 | EncodingArr f . EncodingArr g = EncodingArr (g . f) 121 | 122 | -- | A pair of arrows, i.e. the product of two categories. 123 | data ArrPair p q j a = ArrPair (p j a) (q j a) 124 | 125 | instance (Category p, Category q) => Category (ArrPair p q) where 126 | id = ArrPair id id 127 | ArrPair f1 g1 . ArrPair f2 g2 = ArrPair (f1 . f2) (g1 . g2) 128 | 129 | -- | Describes serialization and validation of a type @a@ with possible 130 | -- validation errors of type @e@. 131 | type JDefinition e = ArrPair (ValidationArr e) EncodingArr 132 | 133 | jValidate :: JDefinition e j a -> j -> JValidation e a 134 | jValidate (ArrPair (ValidationArr vArr) _) = vArr 135 | 136 | jEncode :: JDefinition e j a -> a -> j 137 | jEncode (ArrPair _ (EncodingArr eArr)) = eArr 138 | 139 | -- | Validate @j@ against a schema, producing either a validation report (in 140 | -- case of failure) or a value of type @a@ (in case of success). 141 | validateViaDefinition :: 142 | JDefinition e j a -> 143 | j -> 144 | Either (JValidationReport e) a 145 | validateViaDefinition d j = 146 | case jValidate d j of 147 | JValidation (Just a) es | isEmptyJValidationReport es -> Right a 148 | JValidation _ es -> Left es 149 | 150 | -- | Serialize @a@ into @j@. 151 | encodeViaDefinition :: 152 | JDefinition e j a -> 153 | a -> 154 | j 155 | encodeViaDefinition = jEncode 156 | 157 | -- | Define @b@ in terms of @a@. 158 | jDefinition :: 159 | (a -> JValidation e b) -> 160 | (b -> a) -> 161 | JDefinition e a b 162 | jDefinition toB fromB = ArrPair (ValidationArr toB) (EncodingArr fromB) 163 | 164 | -- | Modify domain-specific validation errors produced in 'JDefinition'. 165 | mapJError :: (e -> e') -> JDefinition e a b -> JDefinition e' a b 166 | mapJError f (ArrPair (ValidationArr toB) fromB) = 167 | ArrPair (ValidationArr (mapJValidationError f . toB)) fromB 168 | 169 | ---------------------------------------------------------------------------- 170 | -- Objects 171 | ---------------------------------------------------------------------------- 172 | 173 | data ObjSchema = 174 | ObjSchema 175 | { objSchemaFields :: HashSet Text, 176 | objSchemaAllowExtraFields :: Bool 177 | } 178 | 179 | instance Semigroup ObjSchema where 180 | s1 <> s2 = 181 | ObjSchema 182 | { objSchemaFields = HashSet.union (objSchemaFields s1) (objSchemaFields s2), 183 | objSchemaAllowExtraFields = objSchemaAllowExtraFields s1 || objSchemaAllowExtraFields s2 184 | } 185 | 186 | instance Monoid ObjSchema where 187 | mempty = 188 | ObjSchema 189 | { objSchemaFields = HashSet.empty, 190 | objSchemaAllowExtraFields = False 191 | } 192 | 193 | type ObjValidationAp e = T.ReaderT JSON.Object (JValidation e) 194 | type ObjEncodingAp o = Const (o -> DList JSON.Pair) 195 | type ObjSchemaAp = Const ObjSchema 196 | type ObjDefinitionAp e o = Product (Product ObjSchemaAp (ObjValidationAp e)) (ObjEncodingAp o) 197 | 198 | -- | Auxiliary type for describing objects, suitable for use with 199 | -- applicative notation. Usually it will be immediately fed into 200 | -- 'defineJObject'. 201 | -- 202 | -- * @e@ is the error type 203 | -- * @o@ is the object type being described 204 | -- * @a@ is the return type; a completed description will have type 205 | -- @JObjectDefinition e o o@. 206 | newtype JObjectDefinition e o a = 207 | JObjectDefinition (ObjDefinitionAp e o a) 208 | deriving newtype (Functor, Applicative) 209 | 210 | jObjectValidate :: JObjectDefinition e o a -> JSON.Object -> JValidation e a 211 | jObjectValidate (JObjectDefinition (Pair (Pair (Const objSchema) (T.ReaderT vAp)) _)) obj = 212 | unless 213 | (objSchemaAllowExtraFields objSchema) 214 | (jRejectExtraFields (objSchemaFields objSchema) obj) *> 215 | vAp obj 216 | 217 | jObjectEncode :: JObjectDefinition e o a -> o -> DList JSON.Pair 218 | jObjectEncode (JObjectDefinition (Pair _ (Const eAp))) = eAp 219 | 220 | mkJObjectDefinition :: 221 | ObjSchema -> 222 | (JSON.Object -> JValidation e a) -> 223 | (o -> DList JSON.Pair) -> 224 | JObjectDefinition e o a 225 | mkJObjectDefinition objSchema objValidate objEncode = 226 | JObjectDefinition (Pair (Pair (Const objSchema) (T.ReaderT objValidate)) (Const objEncode)) 227 | 228 | type MonadicObjectErr = 229 | 'TypeLits.Text "Monadic object definition is not supported. Fit your definition into" ':$$: 230 | 'TypeLits.Text " -XApplicativeDo if possible, or use 'Category' composition" ':$$: 231 | 'TypeLits.Text " if you need to do more checks after the initial validation." 232 | 233 | instance TypeError MonadicObjectErr => Monad (JObjectDefinition e o) where 234 | return = error "return @ JObjectDefinition: impossible" 235 | (>>=) = error "(>>=) @ JObjectDefinition: impossible" 236 | 237 | -- | Construct 'JDefinition' from 'JObjectDefinition'. 238 | jObjectDefinition :: JObjectDefinition e o o -> JDefinition e JSON.Object o 239 | jObjectDefinition objDefn = jDefinition validationArr encodingArr 240 | where 241 | validationArr = jObjectValidate objDefn 242 | encodingArr = HashMap.fromList . DList.toList . jObjectEncode objDefn 243 | 244 | -- | Construct 'JDefinition' from 'JObjectDefinition' with an additional validation step. 245 | jObjectDefinitionEither :: JObjectDefinition e o (Either e o) -> JDefinition e JSON.Object o 246 | jObjectDefinitionEither objDefn = ArrPair validationArr encodingArr 247 | where 248 | validationArr = ValidationArr eitherToJValidation . ValidationArr (jObjectValidate objDefn) 249 | encodingArr = EncodingArr (HashMap.fromList . DList.toList . jObjectEncode objDefn) 250 | 251 | -- | Disable warnings when the JSON object has unexpected fields. 252 | allowExtraFields :: JObjectDefinition e o a -> JObjectDefinition e o a 253 | allowExtraFields (JObjectDefinition (Pair (Pair (Const objSchema) objValidate) objEncode)) = 254 | JObjectDefinition (Pair (Pair (Const objSchema') objValidate) objEncode) 255 | where 256 | objSchema' = objSchema { objSchemaAllowExtraFields = True } 257 | 258 | -- | Create a 'JDefinition' for JSON objects: 259 | -- 260 | -- @ 261 | -- data User = 262 | -- MkUser { _userId :: UUID, 263 | -- _userName :: Text, 264 | -- _userAddr :: Text 265 | -- } 266 | -- 267 | -- 'Jijo.RecordField.TH.makeRecBuilder' \"_user\" ''User 268 | -- 269 | -- jUser = 'defineJObject' $ 270 | -- pure recUser -- recUser generated by 'Jijo.RecordField.TH.makeRecBuilder' 271 | -- \<*\> 'jField' \@\"Id\" \"id\" jUUID 272 | -- \<*\> 'jField' \@\"Email\" \"email\" jText 273 | -- \<*\> 'jField' \@\"Name\" \"name\" jText 274 | -- @ 275 | defineJObject :: JObjectDefinition e o o -> JDefinition e JSON.Value o 276 | defineJObject objDefn = jObjectDefinition objDefn . jObject 277 | 278 | -- | Create a 'JDefinition' for JSON objects, with an additional validation step. 279 | defineJObjectEither :: JObjectDefinition e o (Either e o) -> JDefinition e JSON.Value o 280 | defineJObjectEither objDefn = jObjectDefinitionEither objDefn . jObject 281 | 282 | -- | Validate/encode a required object field. 283 | inJField :: Text -> (o -> a) -> JDefinition e JSON.Value a -> JObjectDefinition e o a 284 | inJField fieldName getField fieldDef = mkJObjectDefinition objSchema objValidate objEncode 285 | where 286 | objSchema = mempty { objSchemaFields = HashSet.singleton fieldName } 287 | objValidate = jValidateField fieldName (jValidate fieldDef) 288 | objEncode o = DList.singleton (fieldName, jEncode fieldDef (getField o)) 289 | 290 | -- | Validate/encode an optional object field. 291 | inOptJField :: Text -> (o -> Maybe a) -> JDefinition e JSON.Value a -> JObjectDefinition e o (Maybe a) 292 | inOptJField fieldName getField fieldDef = mkJObjectDefinition objSchema objValidate objEncode 293 | where 294 | objSchema = mempty { objSchemaFields = HashSet.singleton fieldName } 295 | objValidate = jValidateOptField fieldName (jValidate fieldDef) 296 | objEncode o = case getField o of 297 | Nothing -> DList.empty 298 | Just val -> DList.singleton (fieldName, jEncode fieldDef val) 299 | 300 | -- | Validate/encode a required object field using the 'Field' machinery. 301 | jField :: 302 | forall name prefix e o a. 303 | Rec.HasField (AppendSymbol prefix name) o a => 304 | Text -> 305 | JDefinition e JSON.Value a -> 306 | JObjectDefinition e o (Field prefix name a) 307 | jField fieldName fieldDef = 308 | coerceJObjectDefinition $ inJField fieldName 309 | (Rec.getField @(AppendSymbol prefix name) @o @a) 310 | fieldDef 311 | 312 | -- | Validate/encode an optional object field using the 'Field' machinery. 313 | jFieldOpt :: 314 | forall name prefix e o a. 315 | Rec.HasField (AppendSymbol prefix name) o (Maybe a) => 316 | Text -> 317 | JDefinition e JSON.Value a -> 318 | JObjectDefinition e o (Field prefix name (Maybe a)) 319 | jFieldOpt fieldName fieldDef = 320 | coerceJObjectDefinition $ inOptJField fieldName 321 | (Rec.getField @(AppendSymbol prefix name) @o @(Maybe a)) 322 | fieldDef 323 | 324 | coerceJObjectDefinition :: 325 | Coercible a b => 326 | JObjectDefinition e o a -> 327 | JObjectDefinition e o b 328 | coerceJObjectDefinition (JObjectDefinition (Pair (Pair s p) q)) = 329 | JObjectDefinition (Pair (Pair (coerce s) (coerce p)) (coerce q)) 330 | 331 | ---------------------------------------------------------------------------- 332 | -- Arrays 333 | ---------------------------------------------------------------------------- 334 | 335 | -- | Validate/encode a JSON array. 336 | jArrayOf :: JDefinition e JSON.Value a -> JDefinition e JSON.Value (Vector a) 337 | jArrayOf elementDefn = jDefinition validationArr encodingArr . jArray 338 | where 339 | validationArr = jValidateElements (jValidate elementDefn) 340 | encodingArr = Vector.map (jEncode elementDefn) 341 | 342 | -- | Validate/encode a JSON array, via a list. 343 | jListOf :: JDefinition e JSON.Value a -> JDefinition e JSON.Value [a] 344 | jListOf elementDefn = 345 | jDefinition (pure . Vector.toList) Vector.fromList . jArrayOf elementDefn 346 | 347 | ---------------------------------------------------------------------------- 348 | -- Sums 349 | ---------------------------------------------------------------------------- 350 | 351 | -- | Validation/encoding of a sum constructor. 352 | data JSumOption e a 353 | = JEnumOption a (a -> Bool) 354 | | forall b. JSumOption (b -> a) (a -> Maybe b) (JDefinition e JSON.Value b) 355 | 356 | -- | An exception indicative of an invalid schema for a sum type. If you 357 | -- encounter it, check that there are no duplicate labels in your inputs to 358 | -- 'defineJSum'. 359 | data JSumException 360 | = JSumNoEncoding 361 | | JSumAmbiguousEncoding 362 | deriving (Eq, Show) 363 | 364 | instance Exception JSumException 365 | 366 | -- | A constructor of a sum type with no attached data: 367 | -- 368 | -- @ 369 | -- jSign = 'defineJSum' $ 370 | -- 'jEnumOption' \"+\" _True <> 371 | -- 'jEnumOption' \"-\" _False 372 | -- @ 373 | -- 374 | -- The above definition accepts JSON strings @\"+\"@ and @\"-\"@. 375 | jEnumOption :: Text -> Prism' a () -> Map Text (JSumOption e a) 376 | jEnumOption label p = 377 | Map.singleton label (JEnumOption (review p ()) (isJust . preview p)) 378 | 379 | -- | A constructor of a sum type with data attached: 380 | -- 381 | -- @ 382 | -- jEither jLeft jRight = 'defineJSum' $ 383 | -- 'jSumOption' \"left\" _Left jLeft <> 384 | -- 'jSumOption' \"right\" _Right jRight 385 | -- @ 386 | -- 387 | -- The above definition accepts JSON objects of the form @{ \"left\": ... }@ and @{ \"right\": ... }@. 388 | jSumOption :: Text -> Prism' a b -> JDefinition e JSON.Value b -> Map Text (JSumOption e a) 389 | jSumOption label p jDef = 390 | Map.singleton label (JSumOption (review p) (preview p) jDef) 391 | 392 | -- | Create a 'JDefinition' for sum types: 393 | -- 394 | -- @ 395 | -- jMaybe jJust = 'defineJSum' $ 396 | -- 'jEnumOption' \"nothing\" _Nothing <> 397 | -- 'jSumOption' \"just\" _Just jJust 398 | -- @ 399 | -- 400 | -- The above definition accepts JSON objects of the form @{ \"just\": ... }@ 401 | -- and the JSON string @\"nothing\"@. 402 | defineJSum :: Map Text (JSumOption e a) -> JDefinition e JSON.Value a 403 | defineJSum jSumOptions = jDefinition checkSum encodeSum 404 | where 405 | checkSum = \case 406 | JSON.String label -> 407 | lookupLabel label $ \case 408 | JEnumOption a _ -> pure a 409 | JSumOption{} -> jValidationError JMalformedSum 410 | JSON.Object obj -> 411 | case HashMap.toList obj of 412 | [(label, j)] -> 413 | lookupLabel label $ \case 414 | JEnumOption{} -> jValidationError JMalformedSum 415 | JSumOption f _ jDef -> 416 | mapJValidationReport (scopeJValidationReport (JPSField label)) $ 417 | f <$> jValidate jDef j 418 | _ -> jValidationError JMalformedSum 419 | _ -> jValidationError (JTypeNotOneOf allowedTypes) 420 | 421 | encodeSum a = pickEncoding $ do 422 | (label, jOpt) <- Map.toList jSumOptions 423 | case jOpt of 424 | JEnumOption _ match -> do 425 | guard (match a) 426 | [JSON.String label] 427 | JSumOption _ match jDef -> do 428 | b <- maybeToList (match a) 429 | [JSON.object [label JSON..= jEncode jDef b]] 430 | 431 | pickEncoding [enc] = enc 432 | pickEncoding [] = throw JSumNoEncoding 433 | pickEncoding _ = throw JSumAmbiguousEncoding 434 | 435 | allowedTypes = 436 | Set.fromList [ JTyString | JEnumOption{} <- Map.elems jSumOptions] <> 437 | Set.fromList [ JTyObject | JSumOption{} <- Map.elems jSumOptions] 438 | 439 | lookupLabel s cont = 440 | case Map.lookup s jSumOptions of 441 | Nothing -> jValidationError (JLabelNotOneOf (Map.keysSet jSumOptions)) 442 | Just opt -> cont opt 443 | 444 | ---------------------------------------------------------------------------- 445 | -- Stock definitions 446 | ---------------------------------------------------------------------------- 447 | 448 | -- | Validate/encode a JSON object. 449 | jObject :: JDefinition e JSON.Value JSON.Object 450 | jObject = jDefinition checkObject JSON.Object 451 | where 452 | checkObject = \case 453 | JSON.Object o -> pure o 454 | _ -> jValidationError (JTypeNotOneOf (Set.singleton JTyObject)) 455 | 456 | -- | Validate/encode a JSON array. 457 | jArray :: JDefinition e JSON.Value JSON.Array 458 | jArray = jDefinition checkArray JSON.Array 459 | where 460 | checkArray = \case 461 | JSON.Array a -> pure a 462 | _ -> jValidationError (JTypeNotOneOf (Set.singleton JTyArray)) 463 | 464 | -- | Validate/encode a JSON string. 465 | jString :: JDefinition e JSON.Value Text 466 | jString = jDefinition checkString JSON.String 467 | where 468 | checkString = \case 469 | JSON.String s -> pure s 470 | _ -> jValidationError (JTypeNotOneOf (Set.singleton JTyString)) 471 | 472 | -- | Validate/encode a JSON number. 473 | jNumber :: JDefinition e JSON.Value Scientific 474 | jNumber = jDefinition checkNumber JSON.Number 475 | where 476 | checkNumber = \case 477 | JSON.Number n -> pure n 478 | _ -> jValidationError (JTypeNotOneOf (Set.singleton JTyNumber)) 479 | 480 | -- | Validate/encode a JSON boolean. 481 | jBool :: JDefinition e JSON.Value Bool 482 | jBool = jDefinition checkBool JSON.Bool 483 | where 484 | checkBool = \case 485 | JSON.Bool b -> pure b 486 | _ -> jValidationError (JTypeNotOneOf (Set.singleton JTyBool)) 487 | 488 | -- | Validate/encode a nullable JSON value. 489 | -- 490 | -- 'jNullable' assumses that the inner definition does not accept or produce 491 | -- @null@. As a consequence, one should be careful not to nest this combinator: 492 | -- 493 | -- @ 494 | -- jNullable (jNullable ...) -- don't! 495 | -- @ 496 | -- 497 | jNullable :: JDefinition e JSON.Value a -> JDefinition e JSON.Value (Maybe a) 498 | jNullable jDef = jDefinition validateNullable encodeNullable 499 | where 500 | -- Assumption: for any a, jEncode jDef a /= JSON.Null 501 | encodeNullable = \case 502 | Nothing -> JSON.Null 503 | Just a -> jEncode jDef a 504 | 505 | -- Assumption: (jValidate jDef JSON.Null) errors with JTypeNotOneOf 506 | validateNullable JSON.Null = pure Nothing 507 | validateNullable j = 508 | mapJValidationReport adjustReport (fmap Just (jValidate jDef j)) 509 | 510 | adjustReport (JValidationReport es fs) = 511 | JValidationReport (map adjustErr es) fs 512 | adjustErr (JTypeNotOneOf jtys) = 513 | JTypeNotOneOf (Set.insert JTyNull jtys) 514 | adjustErr e = e 515 | 516 | ---------------------------------------------------------------------------- 517 | -- Aeson integration 518 | ---------------------------------------------------------------------------- 519 | 520 | -- | Default definition for 'JSON.FromJSON': 521 | -- 522 | -- @ 523 | -- instance FromJSON Foo where 524 | -- parseJSON = parseJSON_viaDefinition jFoo 525 | -- @ 526 | -- 527 | parseJSON_viaDefinition :: 528 | JDefinition String JSON.Value a -> 529 | JSON.Value -> JSON.Parser a 530 | parseJSON_viaDefinition d j = 531 | either (fail . renderJValidationReport) return $ 532 | validateViaDefinition d j 533 | 534 | -- | Default definition for 'JSON.ToJSON': 535 | -- 536 | -- @ 537 | -- instance ToJSON Foo where 538 | -- toJSON = toJSON_viaDefinition jFoo 539 | -- @ 540 | -- 541 | toJSON_viaDefinition :: 542 | JDefinition e JSON.Value a -> 543 | a -> JSON.Value 544 | toJSON_viaDefinition = jEncode 545 | 546 | -- | A 'JDefinition' that arises from 'JSON.FromJSON' and 'JSON.ToJSON'. 547 | -- 548 | -- prop> parseJSON_viaDefinition aesonJDefinition = parseJSON 549 | -- prop> toJSON_viaDefinition aesonJDefinition = toJSON 550 | -- 551 | aesonJDefinition :: 552 | (JSON.FromJSON a, JSON.ToJSON a) => 553 | JDefinition String JSON.Value a 554 | aesonJDefinition = jDefinition toB fromB 555 | where 556 | toB = eitherToJValidation . JSON.parseEither JSON.parseJSON 557 | fromB = JSON.toJSON 558 | 559 | ---------------------------------------------------------------------------- 560 | -- Prisms (to avoid a 'lens' dep) 561 | ---------------------------------------------------------------------------- 562 | 563 | type Prism s t a b = forall p f. (Choice p, Applicative f) => p a (f b) -> p s (f t) 564 | type Prism' s a = Prism s s a a 565 | 566 | review :: Prism' t b -> b -> t 567 | review p = coerce . p . Tagged . Identity 568 | {-# INLINE review #-} 569 | 570 | preview :: Prism' s a -> s -> Maybe a 571 | preview l = coerce . l (Const . Monoid.First . Just) 572 | {-# INLINE preview #-} 573 | --------------------------------------------------------------------------------