module Data.JSON.Schema
( Const(..)
, ConstSchema
, HasSchema(..)
, Properties(..)
, Schema(..)
, jsonSchema ) where
import Control.Monad (mzero)
import Data.Aeson (FromJSON(..), ToJSON(..), Value(..),
(.:), (.=), object)
import Data.HashMap.Strict (toList)
import Data.Text (Text, pack, unpack)
import qualified Data.Traversable as T
import Language.Haskell.TH.Lift (deriveLift)
data Schema
= SchemaObject Properties [String]
| SchemaArray Schema
| SchemaString
| SchemaBool
| SchemaNumber
| SchemaInt
| SchemaNull
deriving (Read, Show, Eq)
newtype Properties =
Properties [(String, Schema)]
deriving (Eq, Read, Show)
instance FromJSON Properties where
parseJSON (Object json) = do
t <- (flip T.mapM) json $ \v -> parseJSON v
return . Properties $ map (\(k, v) -> (unpack k, v)) (toList t)
parseJSON _ = fail "Can't parse JSON object"
instance ToJSON Properties where
toJSON (Properties props) =
object $ map (\(k, v) -> (pack k, toJSON v)) props
instance FromJSON Schema where
parseJSON (Object json) = do
t :: Text <- json .: "type"
case t of
"object" -> do
p <- json .: "properties"
p' <- parseJSON p
r <- json .: "required"
r' <- parseJSON r
return $ SchemaObject p' r'
"array" -> do
i <- json .: "items"
a <- parseJSON i
return $ SchemaArray a
"string" -> return SchemaString
"boolean" -> return SchemaBool
"number" -> return SchemaNumber
"int" -> return SchemaInt
"null" -> return SchemaNull
_ -> mzero
parseJSON _ = mzero
instance ToJSON Schema where
toJSON (SchemaObject props reqs) =
object [ "properties" .= props
, "required" .= reqs
, "type" .= ("object" :: String) ]
toJSON (SchemaArray item) =
object [ "items" .= item
, "type" .= ("array" :: String) ]
toJSON SchemaString =
object [ "type" .= ("string" :: String) ]
toJSON SchemaBool =
object [ "type" .= ("boolean" :: String) ]
toJSON SchemaNumber =
object [ "type" .= ("number" :: String) ]
toJSON SchemaInt =
object [ "type" .= ("int" :: String) ]
toJSON SchemaNull =
object [ "type" .= ("null" :: String) ]
jsonSchema :: Value -> Schema
jsonSchema (Object o) =
let
t = fmap jsonSchema o
props = Properties $ map (\(k, v) -> (unpack k, v)) (toList t)
req = map (unpack . fst) (toList t)
in
SchemaObject props req
newtype Const a b =
Const
{ getValue :: b }
type ConstSchema a = Const a Schema
class HasSchema a where
toSchema :: ConstSchema a
instance HasSchema String where
toSchema = Const SchemaString
instance HasSchema Bool where
toSchema = Const SchemaBool
instance HasSchema Double where
toSchema = Const SchemaNumber
instance HasSchema Int where
toSchema = Const SchemaInt
$(deriveLift ''Properties)
$(deriveLift ''Schema)