chore(users/Profpatsch/whatcd-resolver): JsonLd module

Change-Id: Ia2bd60b8449592ef1f79ac4877554958eb0b0407
Reviewed-on: https://cl.tvl.fyi/c/depot/+/11239
Reviewed-by: Profpatsch <mail@profpatsch.de>
Autosubmit: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI
This commit is contained in:
Profpatsch 2024-03-17 12:52:06 +01:00 committed by clbot
parent c2856dc2cd
commit 1ae5e20c98
4 changed files with 140 additions and 116 deletions

View file

@ -12,6 +12,7 @@ let
./Main.hs
./src/WhatcdResolver.hs
./src/AppT.hs
./src/JsonLd.hs
./src/Html.hs
./src/Transmission.hs
./src/Redacted.hs

View file

@ -0,0 +1,137 @@
{-# LANGUAGE QuasiQuotes #-}
module JsonLd where
import AppT
import Control.Monad.Reader
import Data.Aeson qualified as Json
import Data.Aeson.BetterErrors qualified as Json
import Data.ByteString.Builder qualified as Builder
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Set (Set)
import Data.Set qualified as Set
import Html qualified
import IHP.HSX.QQ (hsx)
import Json qualified
import Label
import MyPrelude
import Network.HTTP.Client.Conduit qualified as Http
import Network.HTTP.Simple qualified as Http
import Network.HTTP.Types.URI qualified as Url
import Network.URI (URI)
import Redacted
import Text.Blaze.Html (Html)
import Prelude hiding (span)
-- | A recursive `json+ld` structure.
data Jsonld
= JsonldObject JsonldObject
| JsonldAnonymousObject JsonldAnonymousObject
| JsonldArray [Jsonld]
| JsonldField Json.Value
deriving stock (Show, Eq)
-- | A json+ld object, that is something which can be further expanded by following the URL in its `id_` field.
data JsonldObject = JsonldObject'
{ -- | `@type` field; currently just the plain value without taking into account the json+ld context
type_ :: Set Text,
-- | `@id` field, usually a link to follow for expanding the object to its full glory
id_ :: Text,
-- | any fields of this object that remote deemed important enough to already pre-emptively include in the object; to get all fields resolve the URL in `id_`.
previewFields :: Map Text Jsonld
}
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
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 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 -> 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>|]
httpGetJsonLd :: (MonadThrow m, MonadOtel m) => (URI, Http.Request) -> m Jsonld
httpGetJsonLd (uri, req) = inSpan' "Fetch json+ld" $ \span -> do
addAttribute span "json+ld.targetUrl" (uri & showToText)
httpJson
(mkOptional (label @"contentType" "application/ld+json"))
jsonldParser
( req
& Http.setRequestMethod "GET"
& Http.setRequestHeader "Accept" ["application/ld+json"]
)

View file

@ -10,13 +10,10 @@ import Control.Monad.Reader
import Data.Aeson qualified as Json
import Data.Aeson.BetterErrors qualified as Json
import Data.Aeson.KeyMap qualified as KeyMap
import Data.ByteString.Builder qualified as Builder
import Data.HashMap.Strict qualified as HashMap
import Data.List qualified as List
import Data.Map.Strict qualified as Map
import Data.Pool qualified as Pool
import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text qualified as Text
import Database.PostgreSQL.Simple qualified as Postgres
import Database.PostgreSQL.Simple.SqlQQ (sql)
@ -29,6 +26,7 @@ import IHP.HSX.QQ (hsx)
import Json qualified
import Json.Enc (Enc)
import Json.Enc qualified as Enc
import JsonLd
import Label
import Multipart2 qualified as Multipart
import MyPrelude
@ -36,7 +34,6 @@ import Network.HTTP.Client.Conduit qualified as Http
import Network.HTTP.Simple qualified as Http
import Network.HTTP.Types
import Network.HTTP.Types qualified as Http
import Network.HTTP.Types.URI qualified as Url
import Network.URI (URI)
import Network.URI qualified
import Network.URI qualified as URI
@ -447,107 +444,6 @@ getBestTorrentsTable = do
</table>
|]
-- | A recursive `json+ld` structure.
data Jsonld
= JsonldObject JsonldObject
| JsonldAnonymousObject JsonldAnonymousObject
| JsonldArray [Jsonld]
| JsonldField Json.Value
deriving stock (Show, Eq)
-- | A json+ld object, that is something which can be further expanded by following the URL in its `id_` field.
data JsonldObject = JsonldObject'
{ -- | `@type` field; currently just the plain value without taking into account the json+ld context
type_ :: Set Text,
-- | `@id` field, usually a link to follow for expanding the object to its full glory
id_ :: Text,
-- | any fields of this object that remote deemed important enough to already pre-emptively include in the object; to get all fields resolve the URL in `id_`.
previewFields :: Map Text Jsonld
}
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
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 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 -> 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>|]
getTransmissionTorrentsTable ::
(MonadTransmission m, MonadThrow m, MonadLogger m, MonadOtel m) => m Html
getTransmissionTorrentsTable = do
@ -645,17 +541,6 @@ migrate = inSpan "Database Migration" $ do
|]
()
httpGetJsonLd :: (MonadThrow m, MonadOtel m) => (URI, Http.Request) -> m Jsonld
httpGetJsonLd (uri, req) = inSpan' "Fetch json+ld" $ \span -> do
addAttribute span "json+ld.targetUrl" (uri & showToText)
httpJson
(mkOptional (label @"contentType" "application/ld+json"))
jsonldParser
( req
& Http.setRequestMethod "GET"
& Http.setRequestHeader "Accept" ["application/ld+json"]
)
httpTorrent ::
( MonadIO m,
MonadThrow m

View file

@ -65,6 +65,7 @@ library
exposed-modules:
WhatcdResolver
AppT
JsonLd
Html
Transmission
Redacted