diff options
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs | 108 |
1 files changed, 66 insertions, 42 deletions
diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index 7f2c4ec7e83c..d21892b9e764 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -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} |