autodocodec-schema (empty) → 0.0.0.0
raw patch · 4 files changed
+449/−0 lines, 4 filesdep +aesondep +autodocodecdep +base
Dependencies added: aeson, autodocodec, base, containers, mtl, text, unordered-containers, validity, validity-aeson, validity-containers, validity-text
Files
- CHANGELOG.md +5/−0
- LICENSE +21/−0
- autodocodec-schema.cabal +45/−0
- src/Autodocodec/Schema.hs +378/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Changelog++## [0.0.0.0] - 2021-11-19++First release.
+ LICENSE view
@@ -0,0 +1,21 @@+MIT License++Copyright (c) 2021 Tom Sydney Kerckhove++Permission is hereby granted, free of charge, to any person obtaining a copy+of this software and associated documentation files (the "Software"), to deal+in the Software without restriction, including without limitation the rights+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell+copies of the Software, and to permit persons to whom the Software is+furnished to do so, subject to the following conditions:++The above copyright notice and this permission notice shall be included in all+copies or substantial portions of the Software.++THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE+SOFTWARE.
+ autodocodec-schema.cabal view
@@ -0,0 +1,45 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.4.+--+-- see: https://github.com/sol/hpack++name: autodocodec-schema+version: 0.0.0.0+synopsis: Autodocodec interpreters for JSON Schema+homepage: https://github.com/NorfairKing/autodocodec#readme+bug-reports: https://github.com/NorfairKing/autodocodec/issues+author: Tom Sydney Kerckhove+maintainer: syd@cs-syd.eu+copyright: 2021 Tom Sydney Kerckhove+license: MIT+license-file: LICENSE+build-type: Simple+extra-source-files:+ LICENSE+ CHANGELOG.md++source-repository head+ type: git+ location: https://github.com/NorfairKing/autodocodec++library+ exposed-modules:+ Autodocodec.Schema+ other-modules:+ Paths_autodocodec_schema+ hs-source-dirs:+ src+ build-depends:+ aeson+ , autodocodec+ , base >=4.7 && <5+ , containers+ , mtl+ , text+ , unordered-containers+ , validity+ , validity-aeson+ , validity-containers+ , validity-text+ default-language: Haskell2010
+ src/Autodocodec/Schema.hs view
@@ -0,0 +1,378 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-}++module Autodocodec.Schema where++import Autodocodec+import Control.Monad.State+import Data.Aeson (FromJSON (..), ToJSON (..))+import qualified Data.Aeson as JSON+import qualified Data.Aeson.Types as JSON+import Data.Foldable+import qualified Data.HashMap.Strict as HM+import Data.List.NonEmpty (NonEmpty (..))+import qualified Data.List.NonEmpty as NE+import Data.Map (Map)+import qualified Data.Map as M+import Data.Set (Set)+import qualified Data.Set as S+import Data.Text (Text)+import qualified Data.Text as T+import Data.Validity+import Data.Validity.Aeson ()+import Data.Validity.Containers ()+import Data.Validity.Text ()+import GHC.Generics (Generic)++-- | A JSON Schema+--+-- http://json-schema.org/understanding-json-schema/reference/index.html+--+-- Contrary to a 'Codec', values of this type should be finite.+--+-- NOTE: This schema roundtrips to JSON, but it cannot expres everything that a fully-featured json-schema may be able to express.+data JSONSchema+ = AnySchema+ | NullSchema+ | BoolSchema+ | StringSchema+ | NumberSchema !(Maybe NumberBounds)+ | ArraySchema !JSONSchema+ | MapSchema !JSONSchema+ | -- | This needs to be a list because keys should stay in their original ordering.+ ObjectSchema ObjectSchema+ | ValueSchema !JSON.Value+ | ChoiceSchema !(NonEmpty JSONSchema)+ | CommentSchema !Text !JSONSchema+ | RefSchema !Text+ | WithDefSchema !(Map Text JSONSchema) !JSONSchema+ deriving (Show, Eq, Generic)++instance Validity JSONSchema where+ validate js =+ mconcat+ [ genericValidate js,+ declare "never has two nested comments" $ case js of+ CommentSchema _ (CommentSchema _ _) -> False+ _ -> True,+ case js of+ ChoiceSchema cs -> declare "there are 2 of more choices" $ length cs >= 2+ _ -> valid+ ]++instance ToJSON JSONSchema where+ toJSON = JSON.object . go+ where+ go :: JSONSchema -> [JSON.Pair]+ go = \case+ AnySchema -> []+ NullSchema -> ["type" JSON..= ("null" :: Text)]+ BoolSchema -> ["type" JSON..= ("boolean" :: Text)]+ StringSchema -> ["type" JSON..= ("string" :: Text)]+ NumberSchema mBounds ->+ ("type" JSON..= ("number" :: Text)) : case mBounds of+ Nothing -> []+ Just NumberBounds {..} -> ["minimum" JSON..= numberBoundsLower, "maximum" JSON..= numberBoundsUpper]+ ArraySchema s ->+ let itemSchemaVal = go s+ in ["type" JSON..= ("array" :: Text), ("items", JSON.object itemSchemaVal)]+ ValueSchema v -> ["const" JSON..= v]+ MapSchema s ->+ let itemSchemaVal = go s+ in ["type" JSON..= ("object" :: Text), "additionalProperties" JSON..= JSON.object itemSchemaVal]+ ObjectSchema os ->+ case toJSON os of+ JSON.Object o -> HM.toList o+ _ -> [] -- Should not happen.+ ChoiceSchema jcs ->+ let svals :: [JSON.Value]+ svals = map (JSON.object . go) (NE.toList jcs)+ val :: JSON.Value+ val = (JSON.toJSON :: [JSON.Value] -> JSON.Value) svals+ in [("anyOf", val)]+ (CommentSchema outerComment (CommentSchema innerComment s)) ->+ go (CommentSchema (outerComment <> "\n" <> innerComment) s)+ CommentSchema comment s -> ("$comment" JSON..= comment) : go s+ RefSchema name -> ["$ref" JSON..= (defsPrefix <> name :: Text)]+ WithDefSchema defs s -> ("$defs" JSON..= defs) : go s++instance FromJSON JSONSchema where+ parseJSON = JSON.withObject "JSONSchema" $ \o -> do+ mt <- o JSON..:? "type"+ mc <- o JSON..:? "$comment"+ let commentFunc = maybe id CommentSchema mc+ mdefs <- o JSON..:? "$defs"+ let defsFunc = maybe id WithDefSchema mdefs+ fmap (commentFunc . defsFunc) $ case mt :: Maybe Text of+ Just "null" -> pure NullSchema+ Just "boolean" -> pure BoolSchema+ Just "string" -> pure StringSchema+ Just "number" -> do+ mLower <- o JSON..:? "minimum"+ mUpper <- o JSON..:? "maximum"+ pure $+ NumberSchema $ case (,) <$> mLower <*> mUpper of+ Nothing -> Nothing+ Just (numberBoundsLower, numberBoundsUpper) -> Just NumberBounds {..}+ Just "array" -> do+ mI <- o JSON..:? "items"+ case mI of+ Nothing -> pure $ ArraySchema AnySchema+ Just is -> pure $ ArraySchema is+ Just "object" -> do+ mAdditional <- o JSON..:? "additionalProperties"+ case mAdditional of+ Nothing -> ObjectSchema <$> parseJSON (JSON.Object o)+ Just additional -> pure $ MapSchema additional+ Nothing -> do+ mAny <- o JSON..:? "anyOf"+ case mAny of+ Just anies -> pure $ ChoiceSchema anies+ Nothing -> do+ let mConst = HM.lookup "const" o+ case mConst of+ Just constant -> pure $ ValueSchema constant+ Nothing -> do+ mRef <- o JSON..:? "$ref"+ pure $ case mRef of+ Just ref -> case T.stripPrefix defsPrefix ref of+ Just name -> RefSchema name+ Nothing -> AnySchema+ Nothing -> AnySchema+ t -> fail $ "unknown schema type:" <> show t++data ObjectSchema+ = ObjectKeySchema Text KeyRequirement JSONSchema (Maybe Text)+ | ObjectAnySchema -- For 'pure'+ | ObjectChoiceSchema (NonEmpty ObjectSchema)+ | ObjectAllOfSchema (NonEmpty ObjectSchema)+ deriving (Show, Eq, Generic)++instance Validity ObjectSchema++instance FromJSON ObjectSchema where+ parseJSON = JSON.withObject "ObjectSchema" go+ where+ go :: JSON.Object -> JSON.Parser ObjectSchema+ go o = do+ t <- o JSON..: "type"+ guard $ t == ("object" :: Text)+ mAllOf <- o JSON..:? "allOf"+ case mAllOf of+ Just ao -> do+ ne <- parseJSON ao+ ObjectAllOfSchema <$> mapM go ne+ Nothing -> do+ mAnyOf <- o JSON..:? "anyOf"+ case mAnyOf of+ Just ao -> do+ ne <- parseJSON ao+ ObjectChoiceSchema <$> mapM go ne+ Nothing -> do+ props <- o JSON..:? "properties" JSON..!= HM.empty+ reqs <- o JSON..:? "required" JSON..!= []+ let keySchemaFor k v = do+ ks <- parseJSON v+ let (mDoc, ks') = case ks of+ CommentSchema doc ks'' -> (Just doc, ks'')+ _ -> (Nothing, ks)+ pure $+ if k `elem` reqs+ then ObjectKeySchema k Required ks' mDoc+ else ObjectKeySchema k (Optional Nothing) ks' mDoc+ keySchemas <- mapM (uncurry keySchemaFor) (HM.toList props)+ pure $ case NE.nonEmpty keySchemas of+ Nothing -> ObjectAnySchema+ Just (el :| []) -> el+ Just ne -> ObjectAllOfSchema ne++instance ToJSON ObjectSchema where+ toJSON = JSON.object . (("type" JSON..= ("object" :: Text)) :) . go+ where+ go :: ObjectSchema -> [JSON.Pair]+ go = \case+ ObjectAnySchema -> []+ ObjectKeySchema k kr ks mDoc ->+ let (propVal, req) = keySchemaToPieces (k, kr, ks, mDoc)+ in -- TODO deal with the default value somehow.+ concat [["properties" JSON..= JSON.object [k JSON..= propVal]], ["required" JSON..= [k] | req]]+ ObjectChoiceSchema ne -> ["anyOf" JSON..= NE.map toJSON ne]+ ObjectAllOfSchema ne ->+ case mapM parseAndObjectKeySchema (NE.toList ne) of+ Nothing -> ["allOf" JSON..= NE.map toJSON ne]+ Just ne' ->+ let f (hm, l) tup@(k, _, _, _) =+ let (propVal, req) = keySchemaToPieces tup+ in (HM.insert k propVal hm, if req then k : l else l)+ (propValMap, reqs) = foldl' f (HM.empty, []) (concat ne')+ in concat [["properties" JSON..= propValMap], ["required" JSON..= reqs | not $ null reqs]]++ keySchemaToPieces :: (Text, KeyRequirement, JSONSchema, Maybe Text) -> (JSON.Value, Bool)+ keySchemaToPieces (_, kr, ks, mDoc) =+ let propVal = toJSON (maybe id CommentSchema mDoc ks)+ in (propVal, kr == Required)++ parseAndObjectKeySchema :: ObjectSchema -> Maybe [(Text, KeyRequirement, JSONSchema, Maybe Text)]+ parseAndObjectKeySchema = \case+ ObjectKeySchema k kr ks mDoc -> Just [(k, kr, ks, mDoc)]+ ObjectAllOfSchema os -> concat <$> mapM parseAndObjectKeySchema os+ _ -> Nothing++defsPrefix :: Text+defsPrefix = "#/$defs/"++validateAccordingTo :: JSON.Value -> JSONSchema -> Bool+validateAccordingTo val schema = (`evalState` M.empty) $ go val schema+ where+ goObject :: JSON.Object -> ObjectSchema -> State (Map Text JSONSchema) Bool+ goObject obj = \case+ ObjectAnySchema -> pure True+ ObjectKeySchema key kr ks _ -> case HM.lookup key obj of+ Nothing -> case kr of+ Required -> pure False+ Optional _ -> pure True+ Just value' -> go value' ks+ ObjectAllOfSchema ne -> and <$> mapM (goObject obj) ne+ ObjectChoiceSchema ne -> or <$> mapM (goObject obj) ne++ go :: JSON.Value -> JSONSchema -> State (Map Text JSONSchema) Bool+ go value = \case+ AnySchema -> pure True+ NullSchema -> pure $ value == JSON.Null+ BoolSchema -> pure $ case value of+ JSON.Bool _ -> True+ _ -> False+ StringSchema -> pure $ case value of+ JSON.String _ -> True+ _ -> False+ NumberSchema mBounds -> pure $ case value of+ JSON.Number s -> case maybe Right checkNumberBounds mBounds s of+ Left _ -> False+ Right _ -> True+ _ -> False+ ArraySchema as -> case value of+ JSON.Array v -> and <$> mapM (`go` as) v+ _ -> pure False+ MapSchema vs -> case value of+ JSON.Object hm -> and <$> mapM (`go` vs) hm+ _ -> pure False+ ObjectSchema os -> case value of+ JSON.Object obj -> goObject obj os+ _ -> pure False+ ValueSchema v -> pure $ v == value+ ChoiceSchema ss -> or <$> mapM (go value) ss+ CommentSchema _ s -> go value s+ RefSchema name -> do+ mSchema <- gets (M.lookup name)+ case mSchema of+ Nothing -> pure False -- Referred to a schema that's not defined, we have no choice but to reject the value.+ Just s -> go value s+ WithDefSchema defs s -> do+ modify (M.union defs)+ go value s++data KeyRequirement+ = Required+ | Optional (Maybe JSON.Value) -- Default value+ deriving (Show, Eq, Generic)++instance Validity KeyRequirement++jsonSchemaViaCodec :: forall a. HasCodec a => JSONSchema+jsonSchemaViaCodec = jsonSchemaVia (codec @a)++jsonSchemaVia :: ValueCodec input output -> JSONSchema+jsonSchemaVia = (`evalState` S.empty) . go+ where+ go :: ValueCodec input output -> State (Set Text) JSONSchema+ go = \case+ NullCodec -> pure NullSchema+ BoolCodec mname -> pure $ maybe id CommentSchema mname BoolSchema+ StringCodec mname -> pure $ maybe id CommentSchema mname StringSchema+ NumberCodec mname mBounds -> pure $ maybe id CommentSchema mname $ NumberSchema mBounds+ ArrayOfCodec mname c -> do+ s <- go c+ pure $ maybe id CommentSchema mname $ ArraySchema s+ ObjectOfCodec mname oc -> do+ s <- goObject oc+ pure $ maybe id CommentSchema mname $ ObjectSchema s+ HashMapCodec c -> MapSchema <$> go c+ MapCodec c -> MapSchema <$> go c+ ValueCodec -> pure AnySchema+ EqCodec value c -> pure $ ValueSchema (toJSONVia c value)+ EitherCodec c1 c2 -> do+ s1 <- go c1+ s2 <- go c2+ pure $ ChoiceSchema (goChoice (s1 :| [s2]))+ BimapCodec _ _ c -> go c+ CommentCodec t c -> CommentSchema t <$> go c+ ReferenceCodec name c -> do+ alreadySeen <- gets (S.member name)+ if alreadySeen+ then pure $ RefSchema name+ else do+ modify (S.insert name)+ s <- go c+ pure $ WithDefSchema (M.singleton name s) (RefSchema name)++ goChoice :: NonEmpty JSONSchema -> NonEmpty JSONSchema+ goChoice (s :| rest) = case NE.nonEmpty rest of+ Nothing -> goSingle s+ Just ne -> goSingle s <> goChoice ne+ where+ goSingle :: JSONSchema -> NonEmpty JSONSchema+ goSingle = \case+ ChoiceSchema ss -> goChoice ss+ s' -> s' :| []++ goObject :: ObjectCodec input output -> State (Set Text) ObjectSchema+ goObject = \case+ RequiredKeyCodec k c mdoc -> do+ s <- go c+ pure $ ObjectKeySchema k Required s mdoc+ OptionalKeyCodec k c mdoc -> do+ s <- go c+ pure $ ObjectKeySchema k (Optional Nothing) s mdoc+ OptionalKeyWithDefaultCodec k c mr mdoc -> do+ s <- go c+ pure $ ObjectKeySchema k (Optional (Just (toJSONVia c mr))) s mdoc+ OptionalKeyWithOmittedDefaultCodec k c defaultValue mDoc -> goObject (OptionalKeyWithDefaultCodec k c defaultValue mDoc)+ BimapCodec _ _ c -> goObject c+ EitherCodec oc1 oc2 -> do+ os1 <- goObject oc1+ os2 <- goObject oc2+ pure $ ObjectChoiceSchema (goObjectChoice (os1 :| [os2]))+ PureCodec _ -> pure ObjectAnySchema+ ApCodec oc1 oc2 -> do+ os1 <- goObject oc1+ os2 <- goObject oc2+ pure $ ObjectAllOfSchema (goObjectAllOf (os1 :| [os2]))++ goObjectChoice :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema+ goObjectChoice (s :| rest) = case NE.nonEmpty rest of+ Nothing -> goSingle s+ Just ne -> goSingle s <> goObjectChoice ne+ where+ goSingle :: ObjectSchema -> NonEmpty ObjectSchema+ goSingle = \case+ ObjectChoiceSchema ss -> goObjectChoice ss+ s' -> s' :| []++ goObjectAllOf :: NonEmpty ObjectSchema -> NonEmpty ObjectSchema+ goObjectAllOf (s :| rest) = case NE.nonEmpty rest of+ Nothing -> goSingle s+ Just ne -> goSingle s <> goObjectAllOf ne+ where+ goSingle :: ObjectSchema -> NonEmpty ObjectSchema+ goSingle = \case+ ObjectAllOfSchema ss -> goObjectAllOf ss+ s' -> s' :| []++uncurry3 :: (a -> b -> c -> d) -> ((a, b, c) -> d)+uncurry3 f (a, b, c) = f a b c