git.iko.soy/typeable/hjsonschema
on 1.6.1 help sign in
typeable/hjsonschema/examples/AlternateSchema.hs
205 lines 7.4 kB history raw
1-- | An implementation of JSON Schema Draft 4 based on 'HashMap Text Value'
2-- instead of a custom record type like 'JSONSchema.Draft4'.
3--
4-- If you're writing code for a new schema specification you probably want
5-- to copy this module instead of the 'JSONSchema.Draft4'. While it's
6-- less convenient to write schemas in Haskell without a record type, you
7-- can get the implementation finished with far fewer lines of code.
9module AlternateSchema where
11import Protolude
13import Data.Aeson (FromJSON(..), Value(..),
14 decodeStrict)
15import qualified Data.Aeson as AE
16import qualified Data.HashMap.Strict as HM
17import Data.Maybe (fromMaybe)
18import Data.Profunctor (Profunctor (..))
20import JSONSchema.Draft4 (ValidatorFailure(..),
21 metaSchemaBytes)
22import JSONSchema.Fetch (SchemaWithURI(..),
23 URISchemaMap(..))
24import qualified JSONSchema.Fetch as FE
25import JSONSchema.Types (Schema(..), Spec(..))
26import qualified JSONSchema.Types as JT
27import qualified JSONSchema.Validator.Draft4 as D4
28import JSONSchema.Validator.Reference (BaseURI(..),
29 Scope(..),
30 updateResolutionScope)
32--------------------------------------------------
33-- * Basic fetching tools
34--------------------------------------------------
36referencesViaHTTP
37 :: SchemaWithURI Schema
38 -> IO (Either FE.HTTPFailure (FE.URISchemaMap Schema))
39referencesViaHTTP = FE.referencesViaHTTP' draft4FetchInfo
41draft4FetchInfo :: FE.FetchInfo Schema
42draft4FetchInfo = FE.FetchInfo embedded (lookup "id") (lookup "$ref")
43 where
44 lookup :: Text -> Schema -> Maybe Text
45 lookup k (Schema s) =
46 case HM.lookup k s of
47 Just (String t) -> Just t
48 _ -> Nothing
50-- | An implementation of 'JT.embedded'.
51embedded :: Schema -> ([Schema], [Schema])
52embedded s =
53 JT.embedded (d4Spec mempty mempty (Scope s Nothing (BaseURI Nothing))) s
55--------------------------------------------------
56-- * Main API
57--------------------------------------------------
59validate
60 :: URISchemaMap Schema
61 -> SchemaWithURI Schema
62 -> Value
63 -> [ValidatorFailure]
64validate schemaMap sw =
65 JT.validate (d4Spec schemaMap visited scope) (_swSchema sw)
66 where
67 visited :: D4.VisitedSchemas
68 visited = D4.VisitedSchemas [(Nothing, Nothing)]
70 schemaId :: Maybe Text
71 schemaId = FE._fiId draft4FetchInfo (_swSchema sw)
73 scope :: Scope Schema
74 scope = Scope
75 { _topLevelDocument = _swSchema sw
76 , _documentURI = _swURI sw
77 , _currentBaseURI = updateResolutionScope (BaseURI (_swURI sw))
78 schemaId
79 }
81-- | A schema for schemas themselves. Uses @src/draft4.json@ which is loaded
82-- at compile time.
83metaSchema :: Schema
84metaSchema =
85 fromMaybe (panic "Schema decode failed (this should never happen)")
86 . decodeStrict
87 $ metaSchemaBytes
89checkSchema :: Schema -> [ValidatorFailure]
90checkSchema = validate schemaMap (SchemaWithURI metaSchema Nothing)
91 . Object
92 . _unSchema
93 where
94 schemaMap :: URISchemaMap Schema
95 schemaMap =
96 URISchemaMap (HM.singleton "http://json-schema.org/draft-04/schema"
97 metaSchema)
99--------------------------------------------------
100-- * Spec
101--------------------------------------------------
103validateSubschema
104 :: URISchemaMap Schema
105 -> D4.VisitedSchemas
106 -> Scope Schema
107 -> Schema
108 -> Value
109 -> [ValidatorFailure]
110validateSubschema schemaMap visited scope schema =
111 JT.validate (d4Spec schemaMap visited newScope) schema
112 where
113 schemaId :: Maybe Text
114 schemaId = FE._fiId draft4FetchInfo schema
116 newScope :: Scope Schema
117 newScope = scope
118 { _currentBaseURI = updateResolutionScope (_currentBaseURI scope)
119 schemaId
120 }
122d4Spec
123 :: URISchemaMap Schema
124 -> D4.VisitedSchemas
125 -> Scope Schema
126 -> Spec Schema ValidatorFailure
127 -- ^ Here we reuses 'ValidatorFailure' from
128 -- 'JSONSchema.Draft4.Failure'. If your validators have different
129 -- failure possibilities you'll need to create your own validator
130 -- failure type.
131d4Spec schemaMap visited scope =
132 Spec $
133 [ dimap
134 f
135 FailureRef
136 (D4.refValidator (FE.getReference schemaMap) updateScope
137 valRef visited scope)
138 ]
140 <> fmap (lmap disableIfRefPresent)
141 [ dimap f FailureMultipleOf D4.multipleOfValidator
142 , dimap f FailureMaximum D4.maximumValidator
143 , dimap f FailureMinimum D4.minimumValidator
145 , dimap f FailureMaxLength D4.maxLengthValidator
146 , dimap f FailureMinLength D4.minLengthValidator
147 , dimap f FailurePattern D4.patternValidator
149 , dimap f FailureMaxItems D4.maxItemsValidator
150 , dimap f FailureMinItems D4.minItemsValidator
151 , dimap f FailureUniqueItems D4.uniqueItemsValidator
152 , dimap
153 (fromMaybe D4.emptyItems . f)
154 (\err -> case err of
155 D4.IRInvalidItems e -> FailureItems e
156 D4.IRInvalidAdditional e -> FailureAdditionalItems e)
157 (D4.itemsRelatedValidator descend)
158 , lmap f D4.definitionsEmbedded
160 , dimap f FailureMaxProperties D4.maxPropertiesValidator
161 , dimap f FailureMinProperties D4.minPropertiesValidator
162 , dimap f FailureRequired D4.requiredValidator
163 , dimap f FailureDependencies (D4.dependenciesValidator descend)
164 , dimap
165 (fromMaybe D4.emptyProperties . f)
166 FailurePropertiesRelated
167 (D4.propertiesRelatedValidator descend)
169 , dimap f FailureEnum D4.enumValidator
170 , dimap f FailureType D4.typeValidator
171 , dimap f FailureAllOf (D4.allOfValidator lateral)
172 , dimap f FailureAnyOf (D4.anyOfValidator lateral)
173 , dimap f FailureOneOf (D4.oneOfValidator lateral)
174 , dimap f FailureNot (D4.notValidator lateral)
175 ]
176 where
177 f :: FromJSON a => Schema -> Maybe a
178 f (Schema a) =
179 case AE.fromJSON (Object a) of
180 AE.Error _ -> Nothing
181 AE.Success b -> Just b
183 disableIfRefPresent :: Schema -> Schema
184 disableIfRefPresent schema =
185 case FE._fiRef draft4FetchInfo schema of
186 Nothing -> schema
187 Just _ -> Schema mempty
189 updateScope :: BaseURI -> Schema -> BaseURI
190 updateScope uri schema =
191 updateResolutionScope uri (FE._fiId draft4FetchInfo schema)
193 valRef
194 :: D4.VisitedSchemas
195 -> Scope Schema
196 -> Schema
197 -> Value
198 -> [ValidatorFailure]
199 valRef vis sc = JT.validate (d4Spec schemaMap vis sc)
201 descend :: Schema -> Value -> [ValidatorFailure]
202 descend = validateSubschema schemaMap mempty scope
204 lateral :: Schema -> Value -> [ValidatorFailure]
205 lateral = validateSubschema schemaMap visited scope