feat(users/Profpatsch/whatcd-resolver): render anon json+ld objs

Some json+ld objects cannot be expanded any further, they are missing
the `@id` tag. Now we also render them as objects.

Change-Id: I1c8f26f3c34e69420c349e66a3ce5a36dc55a1ea
Reviewed-on: https://cl.tvl.fyi/c/depot/+/11173
Reviewed-by: Profpatsch <mail@profpatsch.de>
Autosubmit: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI
This commit is contained in:
Profpatsch 2024-03-17 02:31:28 +01:00 committed by clbot
parent 3b9fb1aa60
commit 32c5674962

View file

@ -453,6 +453,7 @@ getBestTorrentsTable = do
-- | A recursive `json+ld` structure.
data Jsonld
= JsonldObject JsonldObject
| JsonldAnonymousObject JsonldAnonymousObject
| JsonldArray [Jsonld]
| JsonldField Json.Value
deriving stock (Show, Eq)
@ -468,64 +469,87 @@ data JsonldObject = JsonldObject'
}
deriving stock (Show, Eq)
-- | A json+ld object that cannot be inspected further by resolving its ID
data JsonldAnonymousObject = JsonldAnonymousObject'
{ -- | `@type` field; currently just the plain value without taking into account the json+ld context
type_ :: Set Text,
-- | fields of this anonymous object
fields :: Map Text Jsonld
}
deriving stock (Show, Eq)
jsonldParser :: (Monad m) => Json.ParseT err m Jsonld
jsonldParser =
Json.asValue >>= \cur -> do
if
| Json.Object _ <- cur -> do
typeMay <- Json.keyMay "@type" $ (Json.asArraySet Json.asText Json.<|> (Set.singleton <$> Json.asText))
type_ <-
Json.keyMay "@type" (Json.asArraySet Json.asText Json.<|> (Set.singleton <$> Json.asText))
<&> fromMaybe Set.empty
idMay <- Json.keyMay "@id" $ Json.asText
fields <-
Json.asObjectMap jsonldParser
<&> Map.delete "@type"
<&> Map.delete "@id"
if
| Just type_ <- typeMay,
Just id_ <- idMay -> do
previewFields <-
Json.asObjectMap jsonldParser
<&> Map.delete "@type"
<&> Map.delete "@id"
pure $ JsonldObject $ JsonldObject' {..}
| otherwise -> pure $ JsonldField cur
| Just id_ <- idMay -> do
pure $ JsonldObject $ JsonldObject' {previewFields = fields, ..}
| otherwise -> pure $ JsonldAnonymousObject $ JsonldAnonymousObject' {..}
| Json.Array _ <- cur -> do
JsonldArray <$> Json.eachInArray jsonldParser
| otherwise -> pure $ JsonldField cur
renderJsonld :: Jsonld -> Html
renderJsonld = \case
JsonldObject obj ->
[hsx|
<dl>
<dt>Type</dt>
<dd>{obj.type_ & toList & schemaTypes}</dd>
<dt>Url</dt>
<dd><a href={obj.id_}>{obj.id_}</a></dd>
<dt>Fields</dt>
<dd>
{obj.previewFields & Html.toDefinitionList schemaType renderJsonld}
<div>
<button
hx-get={snippetHref obj.id_}
hx-target="closest dl"
hx-swap="outerHTML"
>more fields </button>
</div>
</dd>
</dl>
|]
where
snippetHref target =
Builder.toLazyByteString $
"/snips/jsonld/render"
<> Url.renderQueryBuilder True [("target", Just (textToBytesUtf8 target))]
schemaTypes xs =
xs
<&> schemaType
& List.intersperse ", "
& mconcat
schemaType t =
let href :: Text = [fmt|https://schema.org/{t}|] in [hsx|<a href={href} target="_blank">{t}</a>|]
JsonldObject obj -> renderObject obj (Just obj.id_) obj.previewFields
JsonldAnonymousObject obj -> renderObject obj Nothing obj.fields
JsonldArray arr ->
Html.toOrderedList renderJsonld arr
JsonldField f -> Html.mkVal f
where
renderObject obj mId_ fields = do
let id_ =
mId_ <&> \i ->
[hsx|
<dt>Url</dt>
<dd><a href={i}>{i}</a></dd>
|]
getMoreButton =
mId_ <&> \i ->
[hsx|
<div>
<button
hx-get={snippetHref i}
hx-target="closest dl"
hx-swap="outerHTML"
>more fields </button>
</div>
|]
[hsx|
<dl>
<dt>Type</dt>
<dd>{obj.type_ & toList & schemaTypes}</dd>
{id_}
<dt>Fields</dt>
<dd>
{fields & Html.toDefinitionList schemaType renderJsonld}
{getMoreButton}
</dd>
</dl>
|]
snippetHref target =
Builder.toLazyByteString $
"/snips/jsonld/render"
<> Url.renderQueryBuilder True [("target", Just (textToBytesUtf8 target))]
schemaTypes xs =
xs
<&> schemaType
& List.intersperse ", "
& mconcat
schemaType t =
let href :: Text = [fmt|https://schema.org/{t}|] in [hsx|<a href={href} target="_blank">{t}</a>|]
-- | A value between (inclusive) 0% and (inclusive) 100%. Precise to 1% steps.
newtype Percentage = Percentage {unPercentage :: Int}