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

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

4 files changed, 140 insertions, 116 deletions

diff --git a/users/Profpatsch/whatcd-resolver/default.nix b/users/Profpatsch/whatcd-resolver/default.nix
index 82998bf6d7..7862b8dc65 100644
--- a/users/Profpatsch/whatcd-resolver/default.nix
+++ b/users/Profpatsch/whatcd-resolver/default.nix
@@ -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
diff --git a/users/Profpatsch/whatcd-resolver/src/JsonLd.hs b/users/Profpatsch/whatcd-resolver/src/JsonLd.hs
new file mode 100644
index 0000000000..b27f25b482
--- /dev/null
+++ b/users/Profpatsch/whatcd-resolver/src/JsonLd.hs
@@ -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"]
+    )
diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
index 4b449559f7..128fa2934c 100644
--- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
+++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
@@ -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
diff --git a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal
index 080247a060..5f1e4246c0 100644
--- a/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal
+++ b/users/Profpatsch/whatcd-resolver/whatcd-resolver.cabal
@@ -65,6 +65,7 @@ library
     exposed-modules:
        WhatcdResolver
        AppT
+       JsonLd
        Html
        Transmission
        Redacted