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/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
-                                           >>> (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)