feat(users/Profpatsch/whatcd-resolver): locally serve resources

Proxy the resources through our server instead of always requesting
them from the CDN, leaking lots of usage data.

This prefetches the resources at server startup (instead of e.g.
adding them to the build environment statically), which is a nice
compromise I think. It will also keep the integrity verification in
place, but that is still done in the client.

Adds `rel=preload` as well, so we start fetching asap.

No caching (yet). We could easily add a hash over the content though
so the client never has to re-request the resources.

Change-Id: I9aac80cfb1ded09e578ba2a70dcf982bf5322ff6
Reviewed-on: https://cl.tvl.fyi/c/depot/+/13215
Reviewed-by: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI

users/Profpatsch/my-prelude/src/MyPrelude.hs

@@ -173,6 +173,7 @@ module MyPrelude
     HasCallStack,
     module Data.Error,
     symbolText,
+    unwrapErrorTree,
   )
 where
 
@@ -199,6 +200,7 @@ import Data.Char qualified
 import Data.Coerce (Coercible, coerce)
 import Data.Data (Proxy (Proxy))
 import Data.Error
+import Data.Error.Tree (ErrorTree, prettyErrorTree)
 import Data.Foldable (Foldable (foldMap', toList), fold, foldl', for_, sequenceA_, traverse_)
 import Data.Foldable qualified as Foldable
 import Data.Function ((&))
@@ -833,3 +835,7 @@ symbolText :: forall sym. (KnownSymbol sym) => Text
 symbolText = do
   symbolVal (Proxy :: Proxy sym)
     & stringToText
+
+-- | Like 'unwrapError', but for 'ErrorTree'. Will crash with an uncatchable exception if 'Left'.
+unwrapErrorTree :: (HasCallStack) => Either ErrorTree a -> a
+unwrapErrorTree e = e & first (newError . prettyErrorTree) & unwrapError

users/Profpatsch/my-prelude/src/Parse.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE TemplateHaskellQuotes #-}
 
 module Parse where
 
@@ -14,6 +15,7 @@ import Data.Semigroupoid qualified as Semigroupoid
 import Data.Text qualified as Text
 import FieldParser (FieldParser)
 import FieldParser qualified as Field
+import Language.Haskell.TH.Syntax qualified as TH
 import PossehlAnalyticsPrelude
 import Validation (partitionValidations)
 import Prelude hiding (init, maybe)
@@ -191,3 +193,18 @@ zipNonEmpty (x :| xs) (y :| ys) = (x, y) :| zip xs ys
 
 zipIndex :: NonEmpty b -> NonEmpty (Natural, b)
 zipIndex = zipNonEmpty (1 :| [2 :: Natural ..])
+
+-- | Parse a literal value at compile time. This is used with Template Haskell, like so:
+--
+-- > $$("2023-07-27" & literal hyphenatedDay) :: Time.Day
+--
+-- You need the double @$$@!
+--
+-- ATTN: This needs an instance of the 'TH.Lift' class for the output type.
+-- Many library types don’t yet implement this class, so we have to provide the instances ourselves.
+-- See NOTE: Lift for library types
+literal :: forall from to. (TH.Lift to) => Parse from to -> from -> TH.Code TH.Q to
+literal parser s = do
+  case runParse "Literal parse failed" parser s of
+    Right a -> [||a||]
+    Left err -> TH.liftCode (err & prettyErrorTree & textToString & fail)

users/Profpatsch/whatcd-resolver/src/Http.hs

@@ -1,7 +1,10 @@
 {-# LANGUAGE QuasiQuotes #-}
+{-# OPTIONS_GHC -Wno-orphans #-}
 
 module Http
-  ( doRequestJson,
+  ( textToURI,
+    uriToHttpClientRequest,
+    doRequestJson,
     RequestOptions (..),
     mkRequestOptions,
     httpJson,
@@ -19,6 +22,8 @@ module Http
 where
 
 import AppT
+import Control.Exception (Exception (..), SomeException)
+import Control.Monad.Catch.Pure (runCatch)
 import Data.Aeson qualified as Json
 import Data.Aeson.BetterErrors qualified as Json
 import Data.CaseInsensitive (CI (original))
@@ -29,6 +34,7 @@ import Data.List.NonEmpty qualified as NonEmpty
 import Data.Ord (clamp)
 import Data.Text qualified as Text
 import Data.Text.Punycode qualified as Punycode
+import FieldParser (FieldParser' (..))
 import FieldParser qualified as Field
 import Json qualified
 import Json.Enc qualified as Enc
@@ -38,12 +44,51 @@ import Network.HTTP.Client
 import Network.HTTP.Client qualified as Http
 import Network.HTTP.Simple qualified as Http
 import Network.HTTP.Types.Status (Status (..))
+import Network.URI (URI, parseURI)
 import Network.Wai.Parse qualified as Wai
 import Optional
+import Parse (Parse)
+import Parse qualified
 import Pretty
 import UnliftIO.Concurrent (threadDelay)
 import Prelude hiding (span)
 
+-- | Make sure we can parse the given Text into an URI.
+textToURI :: Parse Text URI
+textToURI =
+  Parse.fieldParser
+    ( FieldParser $ \text ->
+        text
+          & textToString
+          & Network.URI.parseURI
+          & annotate [fmt|Cannot parse this as a URL: "{text}"|]
+    )
+
+-- | Make sure we can parse the given URI into a Request.
+--
+-- This tries to work around the horrible, horrible interface in Http.Client.
+uriToHttpClientRequest :: Parse URI Http.Request
+uriToHttpClientRequest =
+  Parse.mkParseNoContext
+    ( \(ctx, url) ->
+        (url & Http.requestFromURI)
+          & runCatch
+          & first (checkException @Http.HttpException)
+          & \case
+            Left (Right (Http.InvalidUrlException urlText reason)) ->
+              Left [fmt|Unable to set the url "{urlText}" as request URL, reason: {reason}, at {Parse.showContext ctx}|]
+            Left (Right exc@(Http.HttpExceptionRequest _ _)) ->
+              Left [fmt|Weird! Should not get a HttpExceptionRequest when parsing an URL (bad library design), was {exc & displayException}, at {Parse.showContext ctx}|]
+            Left (Left someExc) ->
+              Left [fmt|Weird! Should not get anyhting but a HttpException when parsing an URL (bad library design), was {someExc & displayException}, at {Parse.showContext ctx}|]
+            Right req -> pure req
+    )
+  where
+    checkException :: (Exception b) => SomeException -> Either SomeException b
+    checkException some = case fromException some of
+      Nothing -> Left some
+      Just e -> Right e
+
 data RequestOptions = RequestOptions
   { method :: ByteString,
     host :: Text,

users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs

@@ -10,12 +10,12 @@ import Comparison
 import Conduit (ConduitT)
 import Conduit qualified
 import Control.Category qualified as Cat
-import Control.Monad.Catch.Pure (runCatch)
 import Control.Monad.Logger.CallStack
 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 qualified as ByteString
 import Data.CaseInsensitive (CI)
 import Data.Conduit ((.|))
 import Data.Error.Tree
@@ -28,9 +28,10 @@ import Data.Text qualified as Text
 import Database.PostgreSQL.Simple qualified as Postgres
 import Database.PostgreSQL.Simple.Types (PGArray (PGArray))
 import Database.Postgres.Temp qualified as TmpPg
-import FieldParser (FieldParser, FieldParser' (..))
+import FieldParser (FieldParser)
 import FieldParser qualified as Field
 import Html qualified
+import Http
 import IHP.HSX.QQ (hsx)
 import IHP.HSX.ToHtml (ToHtml)
 import Json qualified
@@ -45,11 +46,10 @@ 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.URI (URI)
-import Network.URI qualified
 import Network.Wai (ResponseReceived)
 import Network.Wai qualified as Wai
 import Network.Wai.Handler.Warp qualified as Warp
+import Network.Wai.Parse (parseContentType)
 import OpenTelemetry.Attributes qualified as Otel
 import OpenTelemetry.Context.ThreadLocal qualified as Otel
 import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan')
@@ -67,7 +67,9 @@ import System.Environment qualified as Env
 import System.FilePath ((</>))
 import Text.Blaze.Html (Html)
 import Text.Blaze.Html.Renderer.Utf8 qualified as Html
+import Text.Blaze.Html5 ((!))
 import Text.Blaze.Html5 qualified as Html
+import Text.Blaze.Html5.Attributes qualified as HtmlA
 import Tool (readTool, readTools)
 import Transmission
 import UnliftIO hiding (Handler)
@@ -98,6 +100,8 @@ htmlUi = do
         ()
         (Dec.fromField @Text)
 
+  ourHtmlIntegrities <- prefetchHtmlIntegrities
+
   (counterHtmlM, counterHandler, _counterAsync) <- testCounter (label @"endpoint" "counter")
 
   withRunInIO $ \runInIO -> Warp.run 9093 $ \req respondOrig -> do
@@ -129,11 +133,12 @@ htmlUi = do
 
       let handlers :: Handlers (AppT IO)
           handlers =
-            Map.fromList
+            Map.fromList $
-              [ ( "",
+              ourHtmlIntegrities.handlers
+                <> [ ( "",
                        Html $ \span -> do
                          counterHtml <- counterHtmlM
-                    mainHtml counterHtml uniqueRunId span
+                         mainHtml ourHtmlIntegrities counterHtml uniqueRunId span
                      ),
                      ( "redacted-search",
                        HtmlWithQueryArgs (label @"searchstr" <$> singleQueryArgument "searchstr" Cat.id) $
@@ -161,6 +166,7 @@ htmlUi = do
                                  (getSettings)
                              pure $
                                mainHtml'
+                                 ourHtmlIntegrities
                                  ( MainHtml
                                      { pageTitle = [fmt|whatcd-resolver – Search – {dat.queryArgs.searchstr & bytesToTextUtf8Lenient}|],
                                        returnUrl = dat.returnUrl,
@@ -282,7 +288,7 @@ htmlUi = do
                                <$> (singleQueryArgument "redacted_id" (Field.utf8 >>> Field.decimalNatural))
                            )
                            $ \dat _span -> do
-                        artistPage (T2 dat.queryArgs (label @"uniqueRunId" uniqueRunId))
+                             artistPage ourHtmlIntegrities (T2 dat.queryArgs (label @"uniqueRunId" uniqueRunId))
                      ),
                      ( "artist/refresh",
                        HtmlOrRedirect $
@@ -321,7 +327,7 @@ htmlUi = do
         runHandlers
           ( Html $ \span -> do
               counterHtml <- counterHtmlM
-              mainHtml counterHtml uniqueRunId span
+              mainHtml ourHtmlIntegrities counterHtml uniqueRunId span
           )
           handlers
           req
@@ -330,8 +336,8 @@ htmlUi = do
     everySecond :: Text -> Enc -> Html -> Html
     everySecond call extraData innerHtml = [hsx|<div hx-trigger="every 1s" hx-swap="outerHTML" hx-post={call} hx-vals={Enc.encToBytesUtf8 extraData}>{innerHtml}</div>|]
 
-    mainHtml :: Html -> Text -> Otel.Span -> AppT IO Html
+    mainHtml :: OurHtmlIntegrities (AppT IO) -> Html -> Text -> Otel.Span -> AppT IO Html
-    mainHtml counterHtml uniqueRunId _span = runTransaction $ do
+    mainHtml ourHtmlIntegrities counterHtml uniqueRunId _span = runTransaction $ do
       -- jsonld <-
       --   httpGetJsonLd
       --     ( URI.parseURI "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" & annotate "not an URI" & unwrapError,
@@ -345,6 +351,7 @@ htmlUi = do
       -- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable
       pure $
         mainHtml'
+          ourHtmlIntegrities
           ( MainHtml
               { pageTitle = "whatcd-resolver",
                 returnUrl = "/",
@@ -366,10 +373,11 @@ data MainHtml = MainHtml
     settings :: Settings
   }
 
-mainHtml' :: MainHtml -> Html
+mainHtml' :: OurHtmlIntegrities m -> MainHtml -> Html
-mainHtml' dat = do
+mainHtml' integrities dat = do
   -- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable
   htmlPageChrome
+    integrities
     dat.pageTitle
     ( [hsx|
             {dat.counterHtml}
@@ -443,8 +451,8 @@ redirectOrFallback target responseFn req = do
     Just _ -> responseFn Http.ok200 ("Hx-Redirect", target)
     Nothing -> responseFn Http.seeOther303 ("Location", target)
 
-htmlPageChrome :: (ToHtml a) => Text -> a -> Html
+htmlPageChrome :: (ToHtml a) => OurHtmlIntegrities m -> Text -> a -> Html
-htmlPageChrome title body =
+htmlPageChrome integrities title body =
   Html.docTypeHtml $
     [hsx|
       <head>
@@ -458,9 +466,7 @@ htmlPageChrome title body =
           TODO: create favicon
         -->
         <link rel="icon" href="data:,">
-        <link href="https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/css/bootstrap.min.css" rel="stylesheet" integrity="sha384-9ndCyUaIbzAi2FUVXJi0CjmCapSmO7SnpJef0486qhLnuZ2cdeRhO02iuK6FUUVM" crossorigin="anonymous">
+        {integrities.html}
-        <script src="https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/js/bootstrap.bundle.min.js" integrity="sha384-geWF76RCwLtnZ8qwWowPQNguL3RmwHVBC9FhGdlKrxdiJJigb/j/68SIy3Te4Bkz" crossorigin="anonymous"></script>
-        <script src="https://unpkg.com/htmx.org@1.9.2" integrity="sha384-L6OqL9pRWyyFU3+/bjdSri+iIphTN/bvYyM37tICVyOJkWZLpP2vGn6VUEXgzg6h" crossorigin="anonymous"></script>
         <style>
           dl {
             margin: 1em;
@@ -474,6 +480,47 @@ htmlPageChrome title body =
       </body>
     |]
 
+data OurHtmlIntegrities m = OurHtmlIntegrities
+  { html :: Html,
+    handlers :: [(Text, HandlerResponse m)]
+  }
+
+prefetchHtmlIntegrities :: (MonadOtel m, MonadThrow m) => m (OurHtmlIntegrities m)
+prefetchHtmlIntegrities = do
+  let resources =
+        [ HtmlIntegrity
+            { integrityName = "Bootstrap CSS",
+              integrityUrl = "https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/css/bootstrap.min.css",
+              integrityHash = "sha384-9ndCyUaIbzAi2FUVXJi0CjmCapSmO7SnpJef0486qhLnuZ2cdeRhO02iuK6FUUVM",
+              localPath = "resources/bootstrap.min.css",
+              isTag = E21 (label @"link" ())
+            },
+          HtmlIntegrity
+            { integrityName = "Bootstrap JS",
+              integrityUrl = "https://cdn.jsdelivr.net/npm/bootstrap@5.3.0/dist/js/bootstrap.bundle.min.js",
+              integrityHash = "sha384-geWF76RCwLtnZ8qwWowPQNguL3RmwHVBC9FhGdlKrxdiJJigb/j/68SIy3Te4Bkz",
+              localPath = "resources/bootstrap.bundle.min.js",
+              isTag = E22 (label @"script" ())
+            },
+          HtmlIntegrity
+            { integrityName = "htmx",
+              integrityUrl = "https://unpkg.com/htmx.org@1.9.2",
+              integrityHash = "sha384-L6OqL9pRWyyFU3+/bjdSri+iIphTN/bvYyM37tICVyOJkWZLpP2vGn6VUEXgzg6h",
+              localPath = "resources/htmx.js",
+              isTag = E22 (label @"script" ())
+            }
+        ]
+  resources
+    & traverse
+      ( \r ->
+          prefetchResourceIntegrity r <&> \(html, handler) ->
+            ( html,
+              [(r.localPath, handler)]
+            )
+      )
+    <&> fold
+    <&> \(html, handlers) -> OurHtmlIntegrities {..}
+
 artistPage ::
   ( HasField "artistRedactedId" dat Natural,
     HasField "uniqueRunId" dat Text,
@@ -483,9 +530,10 @@ artistPage ::
     MonadThrow m,
     MonadTransmission m
   ) =>
+  OurHtmlIntegrities m ->
   dat ->
   m Html
-artistPage dat = runTransaction $ do
+artistPage ourHtmlIntegrities dat = runTransaction $ do
   (fresh, settings) <-
     concurrentlyTraced
       ( getBestTorrentsData
@@ -503,8 +551,6 @@ artistPage dat = runTransaction $ do
         Just a -> [fmt|{a} - Artist Page - whatcd-resolver|]
   let mainContent =
         [hsx|
-        <p>Artist ID: {dat.artistRedactedId}</p>
-
         <div id="artist-torrents">
           {torrents}
         </div>
@@ -522,6 +568,7 @@ artistPage dat = runTransaction $ do
       |]
   pure $
     mainHtml'
+      ourHtmlIntegrities
       ( MainHtml
           { pageTitle,
             returnUrl,
@@ -677,42 +724,6 @@ singleQueryArgumentMay field inner =
     )
     >>> Parse.maybe (Parse.fieldParser inner)
 
--- | Make sure we can parse the given Text into an URI.
-textToURI :: Parse Text URI
-textToURI =
-  Parse.fieldParser
-    ( FieldParser $ \text ->
-        text
-          & textToString
-          & Network.URI.parseURI
-          & annotate [fmt|Cannot parse this as a URL: "{text}"|]
-    )
-
--- | Make sure we can parse the given URI into a Request.
---
--- This tries to work around the horrible, horrible interface in Http.Client.
-uriToHttpClientRequest :: Parse URI Http.Request
-uriToHttpClientRequest =
-  Parse.mkParseNoContext
-    ( \(ctx, url) ->
-        (url & Http.requestFromURI)
-          & runCatch
-          & first (checkException @Http.HttpException)
-          & \case
-            Left (Right (Http.InvalidUrlException urlText reason)) ->
-              Left [fmt|Unable to set the url "{urlText}" as request URL, reason: {reason}, at {Parse.showContext ctx}|]
-            Left (Right exc@(Http.HttpExceptionRequest _ _)) ->
-              Left [fmt|Weird! Should not get a HttpExceptionRequest when parsing an URL (bad library design), was {exc & displayException}, at {Parse.showContext ctx}|]
-            Left (Left someExc) ->
-              Left [fmt|Weird! Should not get anyhting but a HttpException when parsing an URL (bad library design), was {someExc & displayException}, at {Parse.showContext ctx}|]
-            Right req -> pure req
-    )
-
-checkException :: (Exception b) => SomeException -> Either SomeException b
-checkException some = case fromException some of
-  Nothing -> Left some
-  Just e -> Right e
-
 data ArtistFilter = ArtistFilter
   { onlyArtist :: Maybe (Label "artistId" Text)
   }
@@ -1286,3 +1297,84 @@ counterConduit =
           threadDelay 300_000
           Conduit.yield [hsx|<p>{i}</p>|]
       )
+
+data HtmlIntegrity = HtmlIntegrity
+  { -- | The name of the resource, for debugging purposes
+    integrityName :: Text,
+    -- | The URL of the resource content
+    integrityUrl :: Text,
+    -- | The integrity hash of the resource
+    integrityHash :: Text,
+    -- | The local url path to fetch the cached resource from the frontend
+    localPath :: Text,
+    -- | is @<link>@ or @<script>@ tag?
+    isTag :: E2 "link" () "script" ()
+  }
+
+-- | Fetch a resource, calculate its integrity hash, and return a html @<link>@ snippet and a handler to return the resource.
+prefetchResourceIntegrity :: (MonadOtel m, MonadThrow m) => HtmlIntegrity -> m (Html, HandlerResponse m)
+prefetchResourceIntegrity dat = inSpan' [fmt|prefetching resource {dat.integrityName}|] $ \span -> do
+  let x =
+        dat.integrityUrl
+          & Parse.runParse "Failed to parse URI" (textToURI >>> uriToHttpClientRequest)
+          & unwrapErrorTree
+
+  Http.httpBS x
+    >>= ( \resp -> do
+            let !statusCode = resp & Http.responseStatus & (.statusCode)
+            let !mContentType =
+                  resp
+                    & Http.responseHeaders
+                    & List.lookup "content-type"
+                    <&> parseContentType
+                    <&> (\(!ct, _mimeAttributes) -> ct)
+
+            let !bodyStrict = resp & Http.responseBody
+            let !bodyLength = bodyStrict & ByteString.length
+            if
+              | statusCode == 200 ->
+                  case dat.isTag of
+                    E21 l -> do
+                      let _ = l.link
+                      pure
+                        ( -- hsx does not understand the `as` attr
+                          ( Html.link
+                              ! HtmlA.rel "preload"
+                              ! HtmlA.href (Html.textValue dat.localPath)
+                              ! Html.customAttribute "as" "style"
+                          )
+                            <> [hsx|
+                             <link rel="stylesheet" href={dat.localPath} integrity={dat.integrityHash} crossorigin="anonymous">
+                             |],
+                          Plain $
+                            pure $
+                              Wai.responseLBS
+                                Http.ok200
+                                [ ("Content-Type", mContentType & fromMaybe "text/css; charset=UTF-8"),
+                                  ("Content-Length", buildBytes intDecimalB bodyLength)
+                                ]
+                                (toLazyBytes $ bodyStrict)
+                        )
+                    E22 l -> do
+                      let _ = l.script
+                      pure
+                        ( ( -- hsx does not understand the `as` attr
+                            Html.link
+                              ! HtmlA.rel "preload"
+                              ! HtmlA.href (Html.textValue dat.localPath)
+                              ! Html.customAttribute "as" "script"
+                          )
+                            <> [hsx|
+                             <script src={dat.localPath} integrity={dat.integrityHash} crossorigin="anonymous"></script>
+                            |],
+                          Plain $
+                            pure $
+                              Wai.responseLBS
+                                Http.ok200
+                                [ ("Content-Type", mContentType & fromMaybe "text/javascript; charset=UTF-8"),
+                                  ("Content-Length", buildBytes intDecimalB bodyLength)
+                                ]
+                                (toLazyBytes $ bodyStrict)
+                        )
+              | code <- statusCode -> appThrow span $ AppExceptionPretty [[fmt|Server returned an non-200 error code, code {code}:|], pretty resp]
+        )