102 lines
2.5 KiB
Haskell
102 lines
2.5 KiB
Haskell
|
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
|
||
|
|
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
|
||
|
|
|
||
|
|
module Schema
|
||
|
|
( Schema,
|
||
|
|
viewSchema,
|
||
|
|
schemaForm,
|
||
|
|
)
|
||
|
|
where
|
||
|
|
|
||
|
|
import Data.Aeson qualified as A
|
||
|
|
import Data.Aeson.Key qualified as AK
|
||
|
|
import Data.Aeson.KeyMap qualified as AM
|
||
|
|
import Data.List
|
||
|
|
import Data.Map qualified as M
|
||
|
|
import Data.Maybe
|
||
|
|
import Data.Text qualified as T
|
||
|
|
import Form qualified as F
|
||
|
|
import Miso
|
||
|
|
import Miso.String (toMisoString)
|
||
|
|
|
||
|
|
data Schema = Schema
|
||
|
|
{ id :: String,
|
||
|
|
schema :: String,
|
||
|
|
title :: String,
|
||
|
|
type_ :: SchemaType
|
||
|
|
}
|
||
|
|
deriving (Show, Eq)
|
||
|
|
|
||
|
|
instance A.FromJSON Schema where
|
||
|
|
parseJSON =
|
||
|
|
A.withObject
|
||
|
|
"Schema"
|
||
|
|
( \v ->
|
||
|
|
Schema
|
||
|
|
<$> v A..: "$id"
|
||
|
|
<*> v A..: "$schema"
|
||
|
|
<*> v A..: "title"
|
||
|
|
<*> A.parseJSON (A.Object v)
|
||
|
|
)
|
||
|
|
|
||
|
|
data SchemaType = Object (M.Map String String)
|
||
|
|
deriving (Show, Eq)
|
||
|
|
|
||
|
|
instance A.FromJSON SchemaType where
|
||
|
|
parseJSON =
|
||
|
|
A.withObject
|
||
|
|
"SchemaType"
|
||
|
|
( \v ->
|
||
|
|
v A..: "type" >>= \case
|
||
|
|
("object" :: String) -> Object <$> v A..: "properties"
|
||
|
|
)
|
||
|
|
|
||
|
|
viewSchema :: Schema -> View action
|
||
|
|
viewSchema schema =
|
||
|
|
case schema.type_ of
|
||
|
|
Object properties ->
|
||
|
|
ol_ [] $
|
||
|
|
( \(k, v) ->
|
||
|
|
li_ [] $
|
||
|
|
[ text (toMisoString k),
|
||
|
|
text ":",
|
||
|
|
text (toMisoString v)
|
||
|
|
]
|
||
|
|
)
|
||
|
|
<$> (M.toList properties)
|
||
|
|
|
||
|
|
schemaForm :: Schema -> F.Form A.Value A.Value
|
||
|
|
schemaForm schema =
|
||
|
|
fmap mergeJson . sequence $
|
||
|
|
case schema.type_ of
|
||
|
|
Object properties ->
|
||
|
|
( \(AK.fromString -> k, "string") ->
|
||
|
|
A.Object . AM.singleton k
|
||
|
|
<$> ( F.mapValues (getO k) (setO k) $
|
||
|
|
jsonString (AK.toString k)
|
||
|
|
)
|
||
|
|
)
|
||
|
|
<$> (M.toList properties)
|
||
|
|
|
||
|
|
mergeJson :: [A.Value] -> A.Value
|
||
|
|
mergeJson = foldl' mergeObject (A.Object AM.empty)
|
||
|
|
|
||
|
|
mergeObject :: A.Value -> A.Value -> A.Value
|
||
|
|
mergeObject (A.Object kvs) (A.Object kvs') = A.Object (AM.union kvs kvs')
|
||
|
|
|
||
|
|
fromJson :: A.Value -> T.Text
|
||
|
|
fromJson (A.String x) = x
|
||
|
|
fromJson _ = ""
|
||
|
|
|
||
|
|
toJson :: T.Text -> A.Value -> A.Value
|
||
|
|
toJson x _ = A.String x
|
||
|
|
|
||
|
|
getO :: AK.Key -> A.Value -> A.Value
|
||
|
|
getO k (A.Object kvs) = fromMaybe A.Null (AM.lookup k kvs)
|
||
|
|
|
||
|
|
setO :: AK.Key -> A.Value -> A.Value -> A.Value
|
||
|
|
setO k v (A.Object kvs) = A.Object (AM.insert k v kvs)
|
||
|
|
|
||
|
|
jsonString :: String -> F.Form A.Value A.Value
|
||
|
|
jsonString = fmap A.String . F.mapValues fromJson toJson . F.string
|