From 1ae5e20c984970437ac6b846de1f6e8af350d72e Mon Sep 17 00:00:00 2001
From: Profpatsch <mail@profpatsch.de>
Date: Sun, 17 Mar 2024 12:52:06 +0100
Subject: 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
---
 .../whatcd-resolver/src/WhatcdResolver.hs          | 117 +--------------------
 1 file changed, 1 insertion(+), 116 deletions(-)

(limited to 'users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs')

diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
index 4b449559f799..128fa2934c8f 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
-- 
cgit 1.4.1