diff --git a/users/Profpatsch/my-prelude/src/MyPrelude.hs b/users/Profpatsch/my-prelude/src/MyPrelude.hs index 8d248be91..569ec3e99 100644 --- 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 = diff --git a/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs b/users/Profpatsch/my-prelude/src/Postgres/Decoder.hs index 92fe5cc7d..6e07709d8 100644 --- 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: -- -- @ diff --git a/users/Profpatsch/shell.nix b/users/Profpatsch/shell.nix index 90ac1b20e..b7442a758 100644 --- 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. diff --git a/users/Profpatsch/whatcd-resolver/services/reverse-proxy/caddyfile b/users/Profpatsch/whatcd-resolver/services/reverse-proxy/caddyfile new file mode 100644 index 000000000..a0c0813b4 --- /dev/null +++ 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 +} diff --git a/users/Profpatsch/whatcd-resolver/services/reverse-proxy/run b/users/Profpatsch/whatcd-resolver/services/reverse-proxy/run index 7081b35f5..71522832a 100755 --- 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 diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index eeecd84cf..ab71636e3 100644 --- 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 diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index 26ca8be5d..c838f51c6 100644 --- 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)