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>

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 =

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:
 --
 -- @

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.
 

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
+}

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

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

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

@@ -292,10 +292,7 @@ htmlUi = do
                            ( label @"artistRedactedId"
                                <$> ( singleQueryArgument
                                        "redacted_id"
-                                       ( Field.utf8
+                                       parseRedactedId
-                                           >>> (Field.decimalNatural <&> toInteger)
-                                           >>> (Field.bounded @Int "Int")
-                                       )
                                    )
                            )
                            $ \dat _span ->
@@ -329,14 +326,31 @@ htmlUi = do
                                ( label @"artistId"
                                    <$> Multipart.field
                                      "artist-id"
-                                     ( Field.utf8
+                                     parseRedactedId
-                                         >>> (Field.decimalNatural <&> toInteger)
-                                         >>> (Field.bounded @Int "Int")
-                                     )
                                )
                            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)