Json schema in 10 minutes

JsonSchema.hs

{-# LANGUAGE RecordWildCards #-}
module JsonSchema where

import Control.Monad (unless, when, zipWithM_)
import Data.Foldable (for_)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Maybe (isJust, isNothing)

type Key = String

data Value = Value
  { required :: Bool,
    content :: JSONType
  }

data JSONType
  = SInteger
  | SString
  | SBool
  | SObject (Map Key Value)
  | SList [JSONType]

data JSONValue
  = JInteger Integer
  | JString String
  | JBool Bool
  | JObject (Map Key JSONValue)
  | JList [JSONValue]

-- | Checks if the given json is valid w.r.t the given schema.
--
-- Note, stops on the first error.
validate :: JSONType -> JSONValue -> Either String ()
validate SBool (JBool _) = Right ()
validate SInteger (JInteger _) = Right ()
validate SString (JString _) = Right ()
validate (SList ts) (JList vs) = zipWithM_ validate ts vs
validate (SObject schemaMap) (JObject valueMap) = do
  validateObjectNoExtraKeys schemaMap valueMap
  when (length (Map.keys valueMap) > length (Map.keys schemaMap)) $
    Left "Value contains more keys than expected"
  for_ (Map.keys schemaMap) $ \k ->
    let Value {..} = schemaMap Map.! k
     in case Map.lookup k valueMap of
          Nothing -> when required $ Left ("Key not present" <> show k)
          Just v -> validate content v
-- Mismatches
validate SBool _ = Left "Mismatch Bool"
validate SInteger _ = Left "Mismatch Number"
validate SString _ = Left "Mismatch Text"
validate (SObject _) _ = Left "Mismatch Object"
validate (SList _) _ = Left "Mismatch List"

validateObjectNoExtraKeys ::
  Map Key Value ->
  Map Key JSONValue ->
  Either String ()
validateObjectNoExtraKeys jMap sMap =
  for_
    (Map.keys jMap)
    (\k -> if Map.member k sMap then Right () else keyNotExpected k)
  where
    keyNotExpected k = Left $ "Key " <> show k <> " not expected!"

main :: IO ()
main = print $ validate schema json
  where
    schema =
      SObject $
        Map.fromList
          [ ("name", Value {required = True, content = SString}),
            ("address_history", Value {required = True, content = SList [SInteger]}),
            ("optional", Value {required = False, content = SString})
          ]

    json =
      JObject $
        Map.fromList
          [ ("name", JString "foo"),
            ("address_history", JList [JInteger 0]),
            ("optional", JString "hi")
          ]