feat(users/Profpatsch/whatcd-resolver): serve torrent files

We want to be able to play the files directly from the web browser (jukebox). Luckily, transmission does not seem to change the filenames from the ones given by the torrent file, so we can literally parse the torrent file and construct a path to the media file, extraordinary. Adjusts the caddy reverse proxy to serve the given transmission directory (using my weird sshfs forwarding scheme in the shell.nix preset lol), then redirect from a handler that maps from torrentId/fileId to the actual file. Change-Id: Iab5faf7cc06066f3253031af31e137c0e28f54e3 Reviewed-on: https://cl.tvl.fyi/c/depot/+/13270 Tested-by: BuildkiteCI Reviewed-by: Profpatsch <mail@profpatsch.de>
2025-03-15 20:02:36 +01:00 · 2025-03-15 20:02:36 +01:00 · 498c8e05f8
commit 498c8e05f8
parent 10c8f3386b
7 changed files with 164 additions and 18 deletions
--- a/users/Profpatsch/my-prelude/src/MyPrelude.hs
+++ b/users/Profpatsch/my-prelude/src/MyPrelude.hs
@ -120,6 +120,7 @@ module MyPrelude
    zipWith3NonEmpty,
    zip4NonEmpty,
    toList,
+    atMay,
    lengthNatural,
    maximum1,
    minimum1,
@ -236,6 +237,7 @@ import Data.Text.Lazy.Encoding qualified
 import Data.These (These (That, These, This))
 import Data.Traversable (for)
 import Data.Vector (Vector)
+import Data.Vector qualified as Vector
 import Data.Void (Void, absurd)
 import Data.Word (Word8)
 import Divisive
@ -452,13 +454,26 @@ zip4NonEmpty ~(a :| as) ~(b :| bs) ~(c :| cs) ~(d :| ds) = (a, b, c, d) :| zip4

 -- | We don’t want to use Foldable’s `length`, because it is too polymorphic and can lead to bugs.
 -- Only list-y things should have a length.
-class (Foldable f) => Lengthy f
+class (Foldable f) => Lengthy f where
+  atMay :: Natural -> f a -> Maybe a
+  atMay = atMayDefault (\idx' xs -> xs & toList & (!! idx'))
+  {-# INLINE atMay #-}
+
+atMayDefault :: (Lengthy f) => (Int -> f a -> a) -> Natural -> f a -> Maybe a
+atMayDefault lookupF idx f = do
+  let midx = integerToBounded @Int (idx & naturalToInteger)
+  if
+    | idx >= lengthNatural f -> Nothing
+    | Nothing <- midx -> Nothing
+    | Just idx' <- midx -> f & lookupF idx' & Just
+{-# INLINE atMayDefault #-}

 instance Lengthy []

 instance Lengthy NonEmpty

-instance Lengthy Vector
+instance Lengthy Vector where
+  atMay = atMayDefault (\idx' xs -> xs & (Vector.! idx'))

 lengthNatural :: (Lengthy f) => f a -> Natural
 lengthNatural xs =
--- a/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs
+++ b/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs
@ -12,6 +12,7 @@ import FieldParser (FieldParser)
 import FieldParser qualified as Field
 import Json qualified
 import Label
+import Parse (Parse, runParse)
 import PossehlAnalyticsPrelude

 -- | A Decoder of postgres values. Allows embedding more complex parsers (like a 'Json.ParseT').
@ -36,21 +37,21 @@ textMay = fromField @(Maybe Text)

 -- | Parse a `text` field, and then use a 'FieldParser' to convert the result further.
 textParse :: (Typeable to) => FieldParser Text to -> Decoder to
-textParse = parse @Text
+textParse = parseField @Text

 -- | Parse a nullable `text` field, and then use a 'FieldParser' to convert the result further.
 textParseMay :: (Typeable to) => FieldParser Text to -> Decoder (Maybe to)
-textParseMay = parseMay @Text
+textParseMay = parseFieldMay @Text

 -- | Parse a type implementing 'FromField', and then use a 'FieldParser' to convert the result further.
-parse ::
+parseField ::
  forall from to.
  ( PG.FromField from,
    Typeable to
  ) =>
  FieldParser from to ->
  Decoder to
-parse parser = Decoder $ PG.fieldWith $ \field bytes -> do
+parseField parser = Decoder $ PG.fieldWith $ \field bytes -> do
  val <- PG.fromField @from field bytes
  case Field.runFieldParser parser val of
    Left err ->
@ -61,14 +62,14 @@ parse parser = Decoder $ PG.fieldWith $ \field bytes -> do
    Right a -> pure a

 -- | Parse a nullable type implementing 'FromField', and then use a 'FieldParser' to convert the result further.
-parseMay ::
+parseFieldMay ::
  forall from to.
  ( PG.FromField from,
    Typeable to
  ) =>
  FieldParser from to ->
  Decoder (Maybe to)
-parseMay parser = Decoder $ PG.fieldWith $ \field bytes -> do
+parseFieldMay parser = Decoder $ PG.fieldWith $ \field bytes -> do
  val <- PG.fromField @(Maybe from) field bytes
  case Field.runFieldParser parser <$> val of
    Nothing -> pure Nothing
@ -79,6 +80,43 @@ parseMay parser = Decoder $ PG.fieldWith $ \field bytes -> do
        (err & prettyError & textToString)
    Just (Right a) -> pure (Just a)

+-- | Parse a type implementing 'FromField', and then use a 'Parse' to convert the result further.
+parse ::
+  forall from to.
+  ( PG.FromField from,
+    Typeable to
+  ) =>
+  Parse from to ->
+  Decoder to
+parse parser = Decoder $ PG.fieldWith $ \field bytes -> do
+  val <- PG.fromField @from field bytes
+  case Parse.runParse "Cannot parse field" parser val of
+    Left err ->
+      PG.returnError
+        PG.ConversionFailed
+        field
+        (err & prettyErrorTree & textToString)
+    Right a -> pure a
+
+-- | Parse a nullable type implementing 'FromField', and then use a 'Parse' to convert the result further.
+parseMay ::
+  forall from to.
+  ( PG.FromField from,
+    Typeable to
+  ) =>
+  Parse from to ->
+  Decoder (Maybe to)
+parseMay parser = Decoder $ PG.fieldWith $ \field bytes -> do
+  val <- PG.fromField @(Maybe from) field bytes
+  case Parse.runParse "Cannot parse field" parser <$> val of
+    Nothing -> pure Nothing
+    Just (Left err) ->
+      PG.returnError
+        PG.ConversionFailed
+        field
+        (err & prettyErrorTree & textToString)
+    Just (Right a) -> pure (Just a)
+
 -- | Turn any type that implements 'PG.fromField' into a 'Decoder'. Use type applications to prevent accidental conversions:
 --
 -- @
--- a/users/Profpatsch/shell.nix
+++ b/users/Profpatsch/shell.nix
@ -85,6 +85,7 @@ pkgs.mkShell {
      path = "${pkgs.pgformatter}/bin/pg_format";
    }
  ];
+  WHATCD_RESOLVER_TRANSMISSION_DOWNLOAD_DIRECTORY = "/home/philip/tmp/a/seeding";

  # DECLIB_MASTODON_ACCESS_TOKEN read from `pass` in .envrc.

--- a/users/Profpatsch/whatcd-resolver/services/reverse-proxy/caddyfile
+++ b/users/Profpatsch/whatcd-resolver/services/reverse-proxy/caddyfile
@ -0,0 +1,17 @@
+{
+	# Global options block
+	auto_https off
+}
+
+:9092 {
+	# Serve files from the directory specified by WHATCD_RESOLVER_TRANSMISSION_DOWNLOAD_DIRECTORY
+	handle_path /files/* {
+		root * {env.WHATCD_RESOLVER_TRANSMISSION_DOWNLOAD_DIRECTORY}
+		file_server {
+			browse off
+		}
+	}
+
+	# Reverse proxy from localhost:9092 to localhost:9093
+	reverse_proxy * localhost:9093
+}
--- a/users/Profpatsch/whatcd-resolver/services/reverse-proxy/run
+++ b/users/Profpatsch/whatcd-resolver/services/reverse-proxy/run
@ -1,2 +1,2 @@
 #!/usr/bin/env execlineb
-caddy reverse-proxy --from :9092 --to :9093
+caddy run --config ./caddyfile
--- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs
+++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs
@ -26,6 +26,7 @@ import Data.Text.IO qualified as Text.IO
 import Data.Time (NominalDiffTime, UTCTime)
 import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
 import Database.PostgreSQL.Simple (Binary (Binary), Only (..))
+import Database.PostgreSQL.Simple qualified as Postgres
 import Database.PostgreSQL.Simple.Types (PGArray (PGArray))
 import FieldParser (FieldParser)
 import FieldParser qualified as Field
@ -46,6 +47,7 @@ import Postgres.MonadPostgres
 import Pretty
 import RevList (RevList)
 import RevList qualified
+import System.FilePath ((</>))
 import UnliftIO (MonadUnliftIO, askRunInIO, async, newQSem, withQSem)
 import UnliftIO.Async (Async)
 import UnliftIO.Async qualified as Async
@ -1141,3 +1143,26 @@ bencodeTorrentParser =
          source <- mapLookupMay "source" bencodeTextLenient
          pure Info {..}
    pure TorrentFile {..}
+
+getTorrentFilePath :: (MonadPostgres m, HasField "torrentId" dat Int, HasField "fileId" dat Natural) => dat -> m (Maybe FilePath)
+getTorrentFilePath dat = do
+  mTorrent <-
+    runTransaction $
+      queryFirstRowWithMaybe
+        [fmt|
+          SELECT torrent_file FROM redacted.torrents
+          WHERE torrent_file IS NOT NULL
+          AND torrent_id = ?::int
+        |]
+        ( Only $ (dat.torrentId :: Int)
+        )
+        ( Dec.parse @(Postgres.Binary ByteString)
+            (lmap (Postgres.fromBinary) parseBencode >>> bencodeTorrentParser)
+        )
+  if
+    | Just torrent <- mTorrent ->
+        pure $
+          torrent.info.files
+            & atMay dat.fileId
+            <&> (\f -> (torrent.info.name & textToString) </> (f.path <&> textToString & foldl' (</>) ""))
+    | otherwise -> pure Nothing
--- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
+++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs
@ -292,10 +292,7 @@ htmlUi = do
                           ( label @"artistRedactedId"
                               <$> ( singleQueryArgument
                                       "redacted_id"
-                                       ( Field.utf8
-                                           >>> (Field.decimalNatural <&> toInteger)
-                                           >>> (Field.bounded @Int "Int")
-                                       )
+                                       parseRedactedId
                                   )
                           )
                           $ \dat _span ->
@ -329,14 +326,31 @@ htmlUi = do
                               ( label @"artistId"
                                   <$> Multipart.field
                                     "artist-id"
-                                     ( Field.utf8
-                                         >>> (Field.decimalNatural <&> toInteger)
-                                         >>> (Field.bounded @Int "Int")
-                                     )
+                                     parseRedactedId
                               )
                           runTransaction $ redactedRefreshArtist dat
                           pure $ E22 (label @"redirectTo" $ textToBytesUtf8 $ mkArtistLink dat)
                     ),
+                     ( "serve/torrent",
+                       HtmlWithQueryArgsRedirect
+                         ( do
+                             torrentId <- singleQueryArgument "torrent-id" parseRedactedId
+                             fileId <- singleQueryArgument "file-id" (Field.utf8 >>> Field.decimalNatural)
+                             pure $ t2 #torrentId torrentId #fileId fileId
+                         )
+                         ( \dat _span -> do
+                             let transmissionTorrentEndpoint :: Text
+                                 transmissionTorrentEndpoint = "/files"
+
+                             mFilePath <- getTorrentFilePath dat.queryArgs
+                             case mFilePath of
+                               Nothing -> do
+                                 pure $ e21 #err "Torrent file not found"
+                               Just filePath -> do
+                                 let redirectPath = transmissionTorrentEndpoint <> "/" <> (filePath & stringToText)
+                                 pure $ e22 #redirectTo (textToBytesUtf8 redirectPath)
+                         )
+                     ),
                     ( "autorefresh",
                       Plain $ do
                         qry <-
@ -414,6 +428,13 @@ htmlUi = do
              }
          )

+parseRedactedId :: Field.FieldParser' Error ByteString Int
+parseRedactedId =
+  ( Field.utf8
+      >>> (Field.decimalNatural <&> toInteger)
+      >>> (Field.bounded @Int "Int")
+  )
+
 data MainHtml = MainHtml
  { returnUrl :: ByteString,
    counterHtml :: Html,
@ -622,6 +643,8 @@ data HandlerResponse m where
  HtmlOrRedirect :: (Otel.Span -> m (E2 "respond" Html "redirectTo" ByteString)) -> HandlerResponse m
  -- | render html after parsing some query arguments
  HtmlWithQueryArgs :: Parse Query a -> (QueryArgsDat a -> Otel.Span -> m Html) -> HandlerResponse m
+  -- | Redirect (HTTP 302) to the given path or show 404 with error message
+  HtmlWithQueryArgsRedirect :: Parse Query a -> (QueryArgsDat a -> Otel.Span -> m (E2 "err" Error "redirectTo" ByteString)) -> HandlerResponse m
  -- | render html or reload the page via the Referer header if no htmx
  HtmlOrReferer :: (Otel.Span -> m Html) -> HandlerResponse m
  -- | render html and stream the head before even doing any work in the handler
@ -673,6 +696,14 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do
            r.redirectTo
            (\status header -> Wai.responseLBS status [header] "")
            req
+  let redirectOr404 :: (Otel.Span -> m (E2 "err" Error "redirectTo" ByteString)) -> m ResponseReceived
+      redirectOr404 = html' $ \res -> case res.html of
+        E21 h ->
+          Wai.responseLBS
+            Http.notFound404
+            [("Content-Type", "text/plain")]
+            (h.err & prettyError & textToBytesUtf8 & toLazyBytes)
+        E22 r -> Wai.responseLBS Http.seeOther303 [("Location", r.redirectTo)] ""
  let postAndRedirect ::
        MultipartParseT m dat ->
        (Otel.Span -> dat -> m (Label "redirectTo" ByteString)) ->
@ -708,6 +739,10 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do
        Right dat -> html (act dat)
        Left act' -> html act'

+  let htmlWithQueryArgsRedirect parser act = case htmlWithQueryArgs' parser of
+        Right dat -> redirectOr404 (act dat)
+        Left act' -> html act'
+
  let htmlStream :: Parse Query a -> (QueryArgsDat a -> Otel.Span -> (m HtmlHead, m Html)) -> m ResponseReceived
      htmlStream parser act = inRouteSpan $ \span -> do
        case htmlWithQueryArgs' parser of
@ -746,6 +781,7 @@ runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do
            Html act -> html act
            HtmlOrRedirect act -> htmlOrRedirect act
            HtmlWithQueryArgs parser act -> htmlWithQueryArgs parser act
+            HtmlWithQueryArgsRedirect parser act -> htmlWithQueryArgsRedirect parser act
            HtmlOrReferer act -> htmlOrReferer act
            HtmlStream parser act -> htmlStream parser act
            PostAndRedirect mParser act -> mParser >>= \parser -> postAndRedirect parser act
@ -1185,11 +1221,25 @@ runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do
      Nothing -> runStderrLoggingT $ do
        logInfo "WHATCD_RESOLVER_REDACTED_API_KEY was not set, trying pass"
        runCommandExpect0 "pass" ["internet/redacted/api-keys/whatcd-resolver"]
+  transmissionDownloadDirectory <- do
+    mPath <- Env.lookupEnv "WHATCD_RESOLVER_TRANSMISSION_DOWNLOAD_DIRECTORY"
+    case mPath of
+      Nothing -> pure $ Left [fmt|WHATCD_RESOLVER_TRANSMISSION_DOWNLOAD_DIRECTORY not set, no file streaming available|]
+      Just path -> do
+        Dir.doesDirectoryExist path >>= \case
+          False -> pure $ Left [fmt|WHATCD_RESOLVER_TRANSMISSION_DOWNLOAD_DIRECTORY directory does not exist: {path}, no file streaming available|]
+          True -> pure $ Right path
+
  let newAppT = do
        logInfo [fmt|Running with config: {showPretty pgConfig}|]
        logInfo [fmt|Connected to database at {db & TmpPg.toDataDirectory} on socket {db & TmpPg.toConnectionString}|]
+        case transmissionDownloadDirectory of
+          Left errmsg -> logInfo errmsg
+          Right dir -> logInfo [fmt|Streaming torrent files from {dir}|]
        appT
-  runReaderT newAppT.unAppT Context {..}
+  runReaderT
+    newAppT.unAppT
+    Context {..}
    `catch` ( \case
                AppExceptionPretty p -> throwM $ EscapedException (p & Pretty.prettyErrs)
                AppExceptionTree t -> throwM $ EscapedException (t & prettyErrorTree & textToString)