132 lines
3.3 KiB
Haskell
132 lines
3.3 KiB
Haskell
{-# OPTIONS_GHC -fno-warn-incomplete-patterns #-}
|
|
{-# OPTIONS_GHC -fno-warn-incomplete-uni-patterns #-}
|
|
|
|
module Schema
|
|
( Schema,
|
|
viewSchema,
|
|
schemaTable,
|
|
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)
|
|
|
|
schemaTable :: Schema -> [A.Value] -> View action
|
|
schemaTable schema values =
|
|
table_ [] [thead, tbody]
|
|
where
|
|
thead =
|
|
thead_ [] $
|
|
case schema.type_ of
|
|
Object properties ->
|
|
[ tr_ [] $
|
|
[ th_ [] [text (toMisoString k)]
|
|
| k <- M.keys properties
|
|
]
|
|
]
|
|
tbody = tbody_ [] $
|
|
case schema.type_ of
|
|
Object properties ->
|
|
[ tr_
|
|
[]
|
|
[ td_ [] $
|
|
[ text $
|
|
case getO (AK.fromString k) value of
|
|
A.String s -> toMisoString s
|
|
value -> toMisoString (A.encode value)
|
|
]
|
|
| k <- M.keys properties
|
|
]
|
|
| value <- values
|
|
]
|
|
|
|
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
|