diff options
Diffstat (limited to 'users/Profpatsch/whatcd-resolver')
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/.gitignore | 1 | ||||
| -rwxr-xr-x | users/Profpatsch/whatcd-resolver/services/jaeger/run | 2 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/AppT.hs | 115 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Http.hs | 105 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/JsonLd.hs | 5 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Redacted.hs | 222 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Transmission.hs | 91 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs | 507 |
8 files changed, 698 insertions, 350 deletions
diff --git a/users/Profpatsch/whatcd-resolver/.gitignore b/users/Profpatsch/whatcd-resolver/.gitignore new file mode 100644 index 000000000000..f9c4bdf8b808 --- /dev/null +++ b/users/Profpatsch/whatcd-resolver/.gitignore @@ -0,0 +1 @@ +/.ninja/ diff --git a/users/Profpatsch/whatcd-resolver/services/jaeger/run b/users/Profpatsch/whatcd-resolver/services/jaeger/run index 41332f8bb61b..7800d88287d5 100755 --- a/users/Profpatsch/whatcd-resolver/services/jaeger/run +++ b/users/Profpatsch/whatcd-resolver/services/jaeger/run @@ -1,3 +1,3 @@ #!/usr/bin/env execlineb importas -i DEPOT_ROOT DEPOT_ROOT -nix-run { $DEPOT_ROOT -A users.Profpatsch.jaeger -kK --builders '' } +nix-run { $DEPOT_ROOT -A users.Profpatsch.jaeger -kK } diff --git a/users/Profpatsch/whatcd-resolver/src/AppT.hs b/users/Profpatsch/whatcd-resolver/src/AppT.hs index abe8ccad4cd3..8550d4aa713e 100644 --- a/users/Profpatsch/whatcd-resolver/src/AppT.hs +++ b/users/Profpatsch/whatcd-resolver/src/AppT.hs @@ -9,35 +9,52 @@ import Data.Error.Tree import Data.HashMap.Strict (HashMap) import Data.HashMap.Strict qualified as HashMap import Data.Pool (Pool) +import Data.String (IsString (fromString)) import Data.Text qualified as Text import Database.PostgreSQL.Simple qualified as Postgres +import FieldParser (FieldParser) +import FieldParser qualified as Field import GHC.Stack qualified +import Json.Enc +import Json.Enc qualified as Enc import Label import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan') import OpenTelemetry.Trace.Core qualified as Otel hiding (inSpan, inSpan') import OpenTelemetry.Trace.Monad qualified as Otel import PossehlAnalyticsPrelude import Postgres.MonadPostgres +import Pretty qualified import System.IO qualified as IO import UnliftIO import Prelude hiding (span) data Context = Context - { config :: Label "logDatabaseQueries" DebugLogDatabaseQueries, + { pgConfig :: + T2 + "logDatabaseQueries" + DebugLogDatabaseQueries + "prettyPrintDatabaseQueries" + PrettyPrintDatabaseQueries, + pgConnPool :: (Pool Postgres.Connection), tracer :: Otel.Tracer, - pgFormat :: PgFormatPool, - pgConnPool :: Pool Postgres.Connection, - transmissionSessionId :: MVar ByteString + transmissionSessionId :: IORef (Maybe ByteString), + redactedApiKey :: ByteString } newtype AppT m a = AppT {unAppT :: ReaderT Context m a} deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadThrow) -data AppException = AppException Text - deriving stock (Show) +data AppException + = AppExceptionTree ErrorTree + | AppExceptionPretty [Pretty.Err] deriving anyclass (Exception) --- * Logging & Opentelemetry +instance IsString AppException where + fromString s = AppExceptionTree (fromString s) + +instance Show AppException where + showsPrec _ (AppExceptionTree t) = ("AppException: " ++) . ((textToString $ prettyErrorTree t) ++) + showsPrec _ (AppExceptionPretty t) = ("AppException: " ++) . ((Pretty.prettyErrsNoColor t) ++) instance (MonadIO m) => MonadLogger (AppT m) where monadLoggerLog loc src lvl msg = liftIO $ Logger.defaultOutput IO.stderr loc src lvl (Logger.toLogStr msg) @@ -65,42 +82,72 @@ addAttribute span key a = Otel.addAttribute span ("_." <> key) a addAttributes :: (MonadIO m) => Otel.Span -> HashMap Text Otel.Attribute -> m () addAttributes span attrs = Otel.addAttributes span $ attrs & HashMap.mapKeys ("_." <>) -appThrowTreeNewSpan :: (MonadThrow m, MonadOtel m) => Text -> ErrorTree -> m a -appThrowTreeNewSpan spanName exc = inSpan' spanName $ \span -> do - let msg = prettyErrorTree exc +addEventSimple :: (MonadIO m) => Otel.Span -> Text -> m () +addEventSimple span name = + Otel.addEvent + span + Otel.NewEvent + { Otel.newEventName = name, + Otel.newEventTimestamp = Nothing, + Otel.newEventAttributes = mempty + } + +-- | Create an otel attribute from a json encoder +jsonAttribute :: Enc -> Otel.Attribute +jsonAttribute e = e & Enc.encToTextPretty & Otel.toAttribute + +parseOrThrow :: (MonadThrow m, MonadIO m) => Otel.Span -> FieldParser from to -> from -> m to +parseOrThrow span fp f = + f & Field.runFieldParser fp & \case + Left err -> appThrow span (AppExceptionTree $ singleError err) + Right a -> pure a + +orThrowAppErrorNewSpan :: (MonadThrow m, MonadOtel m) => Text -> Either AppException a -> m a +orThrowAppErrorNewSpan msg = \case + Left err -> appThrowNewSpan msg err + Right a -> pure a + +appThrowNewSpan :: (MonadThrow m, MonadOtel m) => Text -> AppException -> m a +appThrowNewSpan spanName exc = inSpan' spanName $ \span -> do + let msg = case exc of + AppExceptionTree e -> prettyErrorTree e + AppExceptionPretty p -> Pretty.prettyErrsNoColor p & stringToText recordException span ( T2 (label @"type_" "AppException") (label @"message" msg) ) - throwM $ AppException msg + throwM $ exc -appThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> ErrorTree -> m a -appThrowTree span exc = do - let msg = prettyErrorTree exc +appThrow :: (MonadThrow m, MonadIO m) => Otel.Span -> AppException -> m a +appThrow span exc = do + let msg = case exc of + AppExceptionTree e -> prettyErrorTree e + AppExceptionPretty p -> Pretty.prettyErrsNoColor p & stringToText recordException span ( T2 (label @"type_" "AppException") (label @"message" msg) ) - throwM $ AppException msg + throwM $ exc -orAppThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> Either ErrorTree a -> m a -orAppThrowTree span = \case - Left err -> appThrowTree span err +orAppThrow :: (MonadThrow m, MonadIO m) => Otel.Span -> Either AppException a -> m a +orAppThrow span = \case + Left err -> appThrow span err Right a -> pure a -assertM :: (MonadThrow f, MonadIO f) => Otel.Span -> (t -> Either ErrorTree a) -> t -> f a +-- | If action returns a Left, throw an AppException +assertM :: (MonadThrow f, MonadIO f) => Otel.Span -> (t -> Either AppException a) -> t -> f a assertM span f v = case f v of Right a -> pure a - Left err -> appThrowTree span err + Left err -> appThrow span err -assertMNewSpan :: (MonadThrow f, MonadOtel f) => Text -> (t -> Either ErrorTree a) -> t -> f a +assertMNewSpan :: (MonadThrow f, MonadOtel f) => Text -> (t -> Either AppException a) -> t -> f a assertMNewSpan spanName f v = case f v of Right a -> pure a - Left err -> appThrowTreeNewSpan spanName err + Left err -> appThrowNewSpan spanName err -- | A specialized variant of @addEvent@ that records attributes conforming to -- the OpenTelemetry specification's @@ -125,7 +172,7 @@ recordException span dat = liftIO $ do HashMap.fromList [ ("exception.type", Otel.toAttribute @Text dat.type_), ("exception.message", Otel.toAttribute @Text dat.message), - ("exception.stacktrace", Otel.toAttribute @Text $ Text.unlines $ map stringToText callStack) + ("exception.stacktrace", Otel.toAttribute @Text $ Text.unlines $ Prelude.map stringToText callStack) ], .. } @@ -133,15 +180,25 @@ recordException span dat = liftIO $ do -- * Postgres instance (MonadThrow m, MonadUnliftIO m) => MonadPostgres (AppT m) where - execute = executeImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries)) - executeMany = executeManyImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries)) - executeManyReturningWith = executeManyReturningWithImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries)) - queryWith = queryWithImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries)) - queryWith_ = queryWithImpl_ (AppT ask) + execute = executeImpl dbConfig + executeMany = executeManyImpl dbConfig + executeManyReturningWith = executeManyReturningWithImpl dbConfig + queryWith = queryWithImpl dbConfig + queryWith_ = queryWithImpl_ (dbConfig <&> snd) - foldRowsWithAcc = foldRowsWithAccImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries)) + foldRowsWithAcc = foldRowsWithAccImpl dbConfig runTransaction = runPGTransaction +dbConfig :: (Monad m) => AppT m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries) +dbConfig = + AppT $ + asks + ( \c -> + ( c.pgConfig.logDatabaseQueries, + c.pgConfig.prettyPrintDatabaseQueries + ) + ) + runPGTransaction :: (MonadUnliftIO m) => Transaction (AppT m) a -> AppT m a runPGTransaction (Transaction transaction) = do pool <- AppT ask <&> (.pgConnPool) diff --git a/users/Profpatsch/whatcd-resolver/src/Http.hs b/users/Profpatsch/whatcd-resolver/src/Http.hs index 4fdbb306ad18..14ce191d520e 100644 --- a/users/Profpatsch/whatcd-resolver/src/Http.hs +++ b/users/Profpatsch/whatcd-resolver/src/Http.hs @@ -4,29 +4,39 @@ module Http ( doRequestJson, RequestOptions (..), mkRequestOptions, - setRequestMethod, - setRequestBodyLBS, - setRequestHeader, - getResponseStatus, - getResponseHeader, - getResponseBody, + httpJson, + Http.httpBS, + Http.Request, + Http.setRequestMethod, + Http.setQueryString, + Http.setRequestBodyLBS, + Http.setRequestHeader, + Http.getResponseStatus, + Http.getResponseHeader, + Http.getResponseHeaders, + Http.getResponseBody, ) where import AppT +import Data.Aeson.BetterErrors qualified as Json import Data.CaseInsensitive (CI (original)) import Data.Char qualified as Char -import Data.Int (Int64) +import Data.Error.Tree import Data.List qualified as List import Data.Text qualified as Text -import Data.Text.Lazy qualified as Lazy.Text import Data.Text.Punycode qualified as Punycode +import Json qualified import Json.Enc qualified as Enc +import Label import MyPrelude import Network.HTTP.Client -import Network.HTTP.Simple -import OpenTelemetry.Attributes qualified as Otel +import Network.HTTP.Client qualified as Http +import Network.HTTP.Simple qualified as Http +import Network.HTTP.Types.Status (Status (..)) +import Network.Wai.Parse qualified as Wai import Optional +import Pretty import Prelude hiding (span) data RequestOptions = RequestOptions @@ -34,7 +44,7 @@ data RequestOptions = RequestOptions host :: Text, port :: Optional Int, path :: Optional [Text], - headers :: Optional [Header], + headers :: Optional [Http.Header], usePlainHttp :: Optional Bool } @@ -49,26 +59,71 @@ mkRequestOptions opts = usePlainHttp = defaults } +httpJson :: + ( MonadThrow m, + MonadOtel m + ) => + (Optional (Label "contentType" ByteString)) -> + Json.Parse ErrorTree b -> + Http.Request -> + m b +httpJson opts parser req = inSpan' "HTTP Request (JSON)" $ \span -> do + let opts' = opts.withDefault (label @"contentType" "application/json") + Http.httpBS req + >>= assertM + span + ( \resp -> do + let statusCode = resp & Http.responseStatus & (.statusCode) + contentType = + resp + & Http.responseHeaders + & List.lookup "content-type" + <&> Wai.parseContentType + <&> (\(ct, _mimeAttributes) -> ct) + if + | statusCode == 200, + Just ct <- contentType, + ct == opts'.contentType -> + Right $ (resp & Http.responseBody) + | statusCode == 200, + Just otherType <- contentType -> + Left [fmt|Server returned a non-json body, with content-type "{otherType}"|] + | statusCode == 200, + Nothing <- contentType -> + Left [fmt|Server returned a body with unspecified content type|] + | code <- statusCode -> Left $ AppExceptionPretty [[fmt|Server returned an non-200 error code, code {code}:|], pretty resp] + ) + >>= assertM + span + ( \body -> + Json.parseStrict parser body + & first (AppExceptionTree . Json.parseErrorTree "could not parse HTTP response") + ) + doRequestJson :: (MonadOtel m) => RequestOptions -> Enc.Enc -> m (Response ByteString) doRequestJson opts val = inSpan' "HTTP Request (JSON)" $ \span -> do - let x = requestToXhCommandLine opts val - let attrs = [100, 200 .. fromIntegral @Int @Int64 (x & Text.length)] - for_ attrs $ \n -> do - addAttribute span [fmt|request.xh.{n}|] (Lazy.Text.repeat 'x' & Lazy.Text.take n & toStrict & Otel.TextAttribute) addAttribute span "request.xh" (requestToXhCommandLine opts val) - defaultRequest {secure = not (opts & optsUsePlainHttp)} - & setRequestHost (opts & optsHost) - & setRequestPort (opts & optsPort) - -- TODO: is this automatically escaped by the library? - & setRequestPath (opts & optsPath) - & setRequestHeaders (opts & optsHeaders) - & setRequestMethod opts.method - & setRequestBodyLBS (Enc.encToBytesUtf8Lazy val) - & httpBS + resp <- + defaultRequest {secure = not (opts & optsUsePlainHttp)} + & Http.setRequestHost (opts & optsHost) + & Http.setRequestPort (opts & optsPort) + -- TODO: is this automatically escaped by the library? + & Http.setRequestPath (opts & optsPath) + & Http.setRequestHeaders (opts & optsHeaders) + & Http.setRequestMethod opts.method + & Http.setRequestBodyLBS (Enc.encToBytesUtf8Lazy val) + & Http.httpBS + let code = resp & Http.getResponseStatus & (.statusCode) + let msg = resp & Http.getResponseStatus & (.statusMessage) & bytesToTextUtf8Lenient + addAttribute + span + "request.response.status" + ([fmt|{code} {msg}|] :: Text) + pure resp optsHost :: RequestOptions -> ByteString optsHost opts = @@ -85,7 +140,7 @@ optsPort opts = opts.port.withDefault (if opts & optsUsePlainHttp then 80 else 4 optsPath :: RequestOptions -> ByteString optsPath opts = opts.path.withDefault [] & Text.intercalate "/" & ("/" <>) & textToBytesUtf8 -optsHeaders :: RequestOptions -> [Header] +optsHeaders :: RequestOptions -> [Http.Header] optsHeaders opts = opts.headers.withDefault [] -- | Create a string that can be pasted on the command line to invoke the same HTTP request via the `xh` tool (curl but nicer syntax) diff --git a/users/Profpatsch/whatcd-resolver/src/JsonLd.hs b/users/Profpatsch/whatcd-resolver/src/JsonLd.hs index 16b1ab991b16..db2fb9434554 100644 --- a/users/Profpatsch/whatcd-resolver/src/JsonLd.hs +++ b/users/Profpatsch/whatcd-resolver/src/JsonLd.hs @@ -3,7 +3,6 @@ module JsonLd where import AppT -import Control.Monad.Reader import Data.Aeson qualified as Json import Data.Aeson.BetterErrors qualified as Json import Data.ByteString.Builder qualified as Builder @@ -12,16 +11,14 @@ import Data.Map.Strict qualified as Map import Data.Set (Set) import Data.Set qualified as Set import Html qualified +import Http import IHP.HSX.QQ (hsx) import Json qualified import Label import MyPrelude -import Network.HTTP.Client.Conduit qualified as Http -import Network.HTTP.Simple qualified as Http import Network.HTTP.Types.URI qualified as Url import Network.URI (URI) import Optional -import Redacted import Text.Blaze.Html (Html) import Prelude hiding (span) diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index c0c26b72d659..7bf9e8c2ce27 100644 --- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs +++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs @@ -3,6 +3,7 @@ module Redacted where import AppT +import Arg import Control.Monad.Logger.CallStack import Control.Monad.Reader import Data.Aeson qualified as Json @@ -11,14 +12,12 @@ import Data.Aeson.KeyMap qualified as KeyMap import Data.Error.Tree import Data.List qualified as List import Database.PostgreSQL.Simple (Binary (Binary), Only (..)) -import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple.Types (PGArray (PGArray)) import FieldParser qualified as Field +import Http qualified import Json qualified import Label import MyPrelude -import Network.HTTP.Client.Conduit qualified as Http -import Network.HTTP.Simple qualified as Http import Network.HTTP.Types import Network.Wai.Parse qualified as Wai import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan') @@ -26,11 +25,16 @@ import Optional import Postgres.Decoder qualified as Dec import Postgres.MonadPostgres import Pretty -import RunCommand (runCommandExpect0) import Prelude hiding (span) +class MonadRedacted m where + getRedactedApiKey :: m ByteString + +instance (MonadIO m) => MonadRedacted (AppT m) where + getRedactedApiKey = AppT (asks (.redactedApiKey)) + redactedSearch :: - (MonadLogger m, MonadThrow m, MonadOtel m) => + (MonadThrow m, MonadOtel m, MonadRedacted m) => [(ByteString, ByteString)] -> Json.Parse ErrorTree a -> m a @@ -47,7 +51,8 @@ redactedGetTorrentFile :: ( MonadLogger m, MonadThrow m, HasField "torrentId" dat Int, - MonadOtel m + MonadOtel m, + MonadRedacted m ) => dat -> m ByteString @@ -67,14 +72,10 @@ redactedGetTorrentFile dat = inSpan' "Redacted Get Torrent File" $ \span -> do ) httpTorrent span req --- fix --- ( \io -> do --- logInfo "delay" --- liftIO $ threadDelay 10_000_000 --- io --- ) +mkRedactedTorrentLink :: Arg "torrentGroupId" Int -> Text +mkRedactedTorrentLink torrentId = [fmt|https://redacted.ch/torrents.php?id={torrentId.unArg}|] -exampleSearch :: (MonadThrow m, MonadLogger m, MonadPostgres m, MonadOtel m) => m (Transaction m ()) +exampleSearch :: (MonadThrow m, MonadLogger m, MonadPostgres m, MonadOtel m, MonadRedacted m) => m (Transaction m ()) exampleSearch = do t1 <- redactedSearchAndInsert @@ -111,7 +112,8 @@ redactedSearchAndInsert :: ( MonadLogger m, MonadPostgres m, MonadThrow m, - MonadOtel m + MonadOtel m, + MonadRedacted m ) => [(ByteString, ByteString)] -> m (Transaction m ()) @@ -273,31 +275,35 @@ redactedSearchAndInsert extraArguments = do , torrent_id , full_json_result) |] - ( [ ( dat.torrentGroupIdPg :: Int, - group.torrentId :: Int, - group.fullJsonResult :: Json.Value - ) + ( [ T3 + (getLabel @"torrentGroupIdPg" dat) + (getLabel @"torrentId" group) + (getLabel @"fullJsonResult" group) | dat <- dats, group <- dat.torrents ] & unzip3PGArray + @"torrentGroupIdPg" + @Int + @"torrentId" + @Int + @"fullJsonResult" + @Json.Value ) pure () -unzip3PGArray :: [(a1, a2, a3)] -> (PGArray a1, PGArray a2, PGArray a3) -unzip3PGArray xs = xs & unzip3 & \(a, b, c) -> (PGArray a, PGArray b, PGArray c) - redactedGetTorrentFileAndInsert :: ( HasField "torrentId" r Int, MonadPostgres m, MonadThrow m, MonadLogger m, - MonadOtel m + MonadOtel m, + MonadRedacted m ) => r -> Transaction m (Label "torrentFile" ByteString) redactedGetTorrentFileAndInsert dat = inSpan' "Redacted Get Torrent File and Insert" $ \span -> do - bytes <- redactedGetTorrentFile dat + bytes <- lift $ redactedGetTorrentFile dat execute [sql| UPDATE redacted.torrents_json @@ -354,15 +360,21 @@ assertOneUpdated :: m () assertOneUpdated span name x = case x.numberOfRowsAffected of 1 -> pure () - n -> appThrowTree span ([fmt|{name :: Text}: Expected to update exactly one row, but updated {n :: Natural} row(s)|]) + n -> appThrow span ([fmt|{name :: Text}: Expected to update exactly one row, but updated {n :: Natural} row(s)|]) data TorrentData transmissionInfo = TorrentData { groupId :: Int, torrentId :: Int, seedingWeight :: Int, - torrentJson :: Json.Value, - torrentGroupJson :: T3 "artist" Text "groupName" Text "groupYear" Int, - torrentStatus :: TorrentStatus transmissionInfo + artists :: [T2 "artistId" Int "artistName" Text], + torrentGroupJson :: TorrentGroupJson, + torrentStatus :: TorrentStatus transmissionInfo, + torrentFormat :: Text + } + +data TorrentGroupJson = TorrentGroupJson + { groupName :: Text, + groupYear :: Natural } data TorrentStatus transmissionInfo @@ -381,45 +393,76 @@ getTorrentById dat = do (Dec.json Json.asValue) >>= ensureSingleRow +data GetBestTorrentsFilter = GetBestTorrentsFilter + { onlyDownloaded :: Bool, + onlyArtist :: Maybe (Label "artistRedactedId" Natural) + } + -- | Find the best torrent for each torrent group (based on the seeding_weight) -getBestTorrents :: (MonadPostgres m, HasField "onlyDownloaded" opts Bool) => opts -> Transaction m [TorrentData ()] +getBestTorrents :: + (MonadPostgres m) => + GetBestTorrentsFilter -> + Transaction m [TorrentData ()] getBestTorrents opts = do queryWith [sql| - SELECT * FROM ( - SELECT DISTINCT ON (group_id) - tg.group_id, - t.torrent_id, - seeding_weight, - t.full_json_result AS torrent_json, - tg.full_json_result AS torrent_group_json, - t.torrent_file IS NOT NULL as has_torrent_file, - t.transmission_torrent_hash - FROM redacted.torrents t - JOIN redacted.torrent_groups tg ON tg.id = t.torrent_group - ORDER BY group_id, seeding_weight DESC - ) as _ - WHERE - -- onlyDownloaded - ((NOT ?::bool) OR has_torrent_file) + WITH filtered_torrents AS ( + SELECT DISTINCT ON (torrent_group) + id + FROM + redacted.torrents + WHERE + -- onlyDownloaded + ((NOT ?::bool) OR torrent_file IS NOT NULL) + -- filter by artist id + AND + (?::bool OR (to_jsonb(?::int) <@ (jsonb_path_query_array(full_json_result, '$.artists[*].id')))) + ORDER BY + torrent_group, + -- prefer torrents which we already downloaded + torrent_file, + seeding_weight DESC + ) + SELECT + tg.group_id, + t.torrent_id, + t.seeding_weight, + t.full_json_result->'artists' AS artists, + tg.full_json_result->>'groupName' AS group_name, + tg.full_json_result->>'groupYear' AS group_year, + t.torrent_file IS NOT NULL AS has_torrent_file, + t.transmission_torrent_hash, + t.full_json_result->>'encoding' AS torrent_format + FROM filtered_torrents f + JOIN redacted.torrents t ON t.id = f.id + JOIN redacted.torrent_groups tg ON tg.id = t.torrent_group ORDER BY seeding_weight DESC |] - (Only opts.onlyDownloaded :: Only Bool) + ( do + let (onlyArtistB, onlyArtistId) = case opts.onlyArtist of + Nothing -> (True, 0) + Just a -> (False, a.artistRedactedId) + ( opts.onlyDownloaded :: Bool, + onlyArtistB :: Bool, + onlyArtistId & fromIntegral @Natural @Int + ) + ) ( do groupId <- Dec.fromField @Int torrentId <- Dec.fromField @Int seedingWeight <- Dec.fromField @Int - torrentJson <- Dec.json Json.asValue - torrentGroupJson <- - ( Dec.json $ do - artist <- Json.keyLabel @"artist" "artist" Json.asText - groupName <- Json.keyLabel @"groupName" "groupName" Json.asText - groupYear <- Json.keyLabel @"groupYear" "groupYear" (Json.asIntegral @_ @Int) - pure $ T3 artist groupName groupYear - ) + artists <- Dec.json $ + Json.eachInArray $ do + id_ <- Json.keyLabel @"artistId" "id" (Json.asIntegral @_ @Int) + name <- Json.keyLabel @"artistName" "name" Json.asText + pure $ T2 id_ name + torrentGroupJson <- do + groupName <- Dec.text + groupYear <- Dec.textParse Field.decimalNatural + pure $ TorrentGroupJson {..} hasTorrentFile <- Dec.fromField @Bool - transmissionTorrentHash <- - Dec.fromField @(Maybe Text) + transmissionTorrentHash <- Dec.fromField @(Maybe Text) + torrentFormat <- Dec.text pure $ TorrentData { torrentStatus = @@ -429,6 +472,13 @@ getBestTorrents opts = do | Just hash <- transmissionTorrentHash -> InTransmission $ T2 (label @"torrentHash" hash) (label @"transmissionInfo" ()), + torrentFormat = case torrentFormat of + "Lossless" -> "flac" + "V0 (VBR)" -> "V0" + "V2 (VBR)" -> "V2" + "320" -> "320" + "256" -> "256" + o -> o, .. } ) @@ -436,15 +486,14 @@ getBestTorrents opts = do -- | Do a request to the redacted API. If you know what that is, you know how to find the API docs. mkRedactedApiRequest :: ( MonadThrow m, - MonadIO m, - MonadLogger m, HasField "action" p ByteString, - HasField "actionArgs" p [(ByteString, Maybe ByteString)] + HasField "actionArgs" p [(ByteString, Maybe ByteString)], + MonadRedacted m ) => p -> m Http.Request mkRedactedApiRequest dat = do - authKey <- runCommandExpect0 "pass" ["internet/redacted/api-keys/whatcd-resolver"] + authKey <- getRedactedApiKey pure $ [fmt|https://redacted.ch/ajax.php|] & Http.setRequestMethod "GET" @@ -463,73 +512,32 @@ httpTorrent span req = >>= assertM span ( \resp -> do - let statusCode = resp & Http.responseStatus & (.statusCode) + let statusCode = resp & Http.getResponseStatus & (.statusCode) contentType = resp - & Http.responseHeaders + & Http.getResponseHeaders & List.lookup "content-type" <&> Wai.parseContentType <&> (\(ct, _mimeAttributes) -> ct) if | statusCode == 200, Just "application/x-bittorrent" <- contentType -> - Right $ (resp & Http.responseBody) + Right $ (resp & Http.getResponseBody) | statusCode == 200, Just otherType <- contentType -> Left [fmt|Redacted returned a non-torrent body, with content-type "{otherType}"|] | statusCode == 200, Nothing <- contentType -> Left [fmt|Redacted returned a body with unspecified content type|] - | code <- statusCode -> Left [fmt|Redacted returned an non-200 error code, code {code}: {resp & showPretty}|] - ) - -httpJson :: - ( MonadThrow m, - MonadOtel m - ) => - (Optional (Label "contentType" ByteString)) -> - Json.Parse ErrorTree b -> - Http.Request -> - m b -httpJson opts parser req = inSpan' "HTTP Request (JSON)" $ \span -> do - let opts' = opts.withDefault (label @"contentType" "application/json") - Http.httpBS req - >>= assertM - span - ( \resp -> do - let statusCode = resp & Http.responseStatus & (.statusCode) - contentType = - resp - & Http.responseHeaders - & List.lookup "content-type" - <&> Wai.parseContentType - <&> (\(ct, _mimeAttributes) -> ct) - if - | statusCode == 200, - Just ct <- contentType, - ct == opts'.contentType -> - Right $ (resp & Http.responseBody) - | statusCode == 200, - Just otherType <- contentType -> - Left [fmt|Server returned a non-json body, with content-type "{otherType}"|] - | statusCode == 200, - Nothing <- contentType -> - Left [fmt|Server returned a body with unspecified content type|] - | code <- statusCode -> Left [fmt|Server returned an non-200 error code, code {code}: {resp & showPretty}|] - ) - >>= assertM - span - ( \body -> - Json.parseStrict parser body - & first (Json.parseErrorTree "could not parse redacted response") + | code <- statusCode -> Left $ AppExceptionPretty [[fmt|Redacted returned an non-200 error code, code {code}|], pretty resp] ) redactedApiRequestJson :: ( MonadThrow m, - MonadLogger m, HasField "action" p ByteString, HasField "actionArgs" p [(ByteString, Maybe ByteString)], - MonadOtel m + MonadOtel m, + MonadRedacted m ) => p -> Json.Parse ErrorTree a -> @@ -537,4 +545,4 @@ redactedApiRequestJson :: redactedApiRequestJson dat parser = do mkRedactedApiRequest dat - >>= httpJson defaults parser + >>= Http.httpJson defaults parser diff --git a/users/Profpatsch/whatcd-resolver/src/Transmission.hs b/users/Profpatsch/whatcd-resolver/src/Transmission.hs index 66dbeb9ce749..3238780af70f 100644 --- a/users/Profpatsch/whatcd-resolver/src/Transmission.hs +++ b/users/Profpatsch/whatcd-resolver/src/Transmission.hs @@ -25,6 +25,7 @@ import Json.Enc qualified as Enc import Label import MyPrelude import Network.HTTP.Types +import OpenTelemetry.Attributes (ToAttribute (toAttribute)) import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan') import Optional import Postgres.MonadPostgres @@ -48,18 +49,20 @@ scientificPercentage = | otherwise -> Right $ Percentage $ ceiling (f * 100) ) --- | Fetch the current status from transmission, and remove the tranmission hash from our database --- iff it does not exist in transmission anymore +-- | Fetch the current status from transmission, +-- and remove the transmission hash and torrent file from our database iff it does not exist in transmission anymore getAndUpdateTransmissionTorrentsStatus :: ( MonadTransmission m, MonadThrow m, MonadLogger m, MonadPostgres m, - MonadOtel m + MonadOtel m, + HasField "groupId" info Int, + HasField "torrentId" info Int ) => - Map (Label "torrentHash" Text) () -> - (Transaction m (Map (Label "torrentHash" Text) (Label "percentDone" Percentage))) -getAndUpdateTransmissionTorrentsStatus knownTorrents = do + Map (Label "torrentHash" Text) info -> + (Transaction m (Label "knownTorrentsStale" Bool, (Map (Label "torrentHash" Text) (Label "percentDone" Percentage)))) +getAndUpdateTransmissionTorrentsStatus knownTorrents = inSpan' "getAndUpdateTransmissionTorrentsStatus" $ \span -> do let fields = ["hashString", "percentDone"] actualTorrents <- lift @Transaction $ @@ -76,14 +79,36 @@ getAndUpdateTransmissionTorrentsStatus knownTorrents = do ) <&> Map.fromList let toDelete = Map.difference knownTorrents actualTorrents - execute - [fmt| - UPDATE redacted.torrents_json - SET transmission_torrent_hash = NULL - WHERE transmission_torrent_hash = ANY (?::text[]) - |] - $ Only (toDelete & Map.keys <&> (.torrentHash) & PGArray :: PGArray Text) - pure actualTorrents + if + | Map.null toDelete -> do + addEventSimple span "We know about all transmission hashes." + pure (label @"knownTorrentsStale" False, actualTorrents) + | otherwise -> inSpan' "Delete outdated transmission hashes" $ \span' -> do + addAttribute + span' + "db.delete-transmission-hashes" + ( toDelete + & Map.toList + & Enc.list + ( \(k, v) -> + Enc.object + [ ("torrentHash", Enc.text k.torrentHash), + ("groupId", Enc.int v.groupId), + ("torrentId", Enc.int v.torrentId) + ] + ) + & jsonAttribute + ) + _ <- + execute + [fmt| + UPDATE redacted.torrents_json + SET transmission_torrent_hash = NULL, + torrent_file = NULL + WHERE transmission_torrent_hash = ANY (?::text[]) + |] + $ Only (toDelete & Map.keys <&> (.torrentHash) & PGArray :: PGArray Text) + pure (label @"knownTorrentsStale" True, actualTorrents) getTransmissionTorrentsTable :: (MonadTransmission m, MonadThrow m, MonadLogger m, MonadOtel m) => m Html @@ -204,9 +229,9 @@ doTransmissionRequest' req = inSpan' "Transmission Request" $ \span -> do transmissionConnectionConfig req case resp.result of - TransmissionResponseFailure err -> appThrowTree span (nestedError "Transmission RPC error" $ singleError $ newError err) + TransmissionResponseFailure err -> appThrow span (AppExceptionTree $ nestedError "Transmission RPC error" $ singleError $ newError err) TransmissionResponseSuccess -> case resp.arguments of - Nothing -> appThrowTree span "Transmission RPC error: No `arguments` field in response" + Nothing -> appThrow span "Transmission RPC error: No `arguments` field in response" Just out -> pure out -- | Contact the transmission RPC, and do the CSRF protection dance. @@ -226,7 +251,7 @@ doTransmissionRequest :: (TransmissionRequest, Json.Parse Error output) -> m (TransmissionResponse output) doTransmissionRequest span dat (req, parser) = do - sessionId <- getTransmissionId + sessionId <- getCurrentTransmissionSessionId let textArg t = (Enc.text t, Otel.toAttribute @Text t) let encArg enc = (enc, Otel.toAttribute @Text $ enc & Enc.encToTextPretty) let intArg i = (Enc.int i, Otel.toAttribute @Int i) @@ -257,7 +282,7 @@ doTransmissionRequest span dat (req, parser) = do (body <&> second fst & Enc.object) -- Implement the CSRF protection thingy case resp & Http.getResponseStatus & (.statusCode) of - 409 -> do + 409 -> inSpan' "New Transmission Session ID" $ \span' -> do tid <- resp & Http.getResponseHeader "X-Transmission-Session-Id" @@ -266,9 +291,21 @@ doTransmissionRequest span dat (req, parser) = do & unwrapIOError & liftIO <&> NonEmpty.head - setTransmissionId tid + + addAttributes span' $ + HashMap.fromList + [ ("transmission.new_session_id", tid & bytesToTextUtf8Lenient & toAttribute), + ("transmission.old_session_id", sessionId <&> bytesToTextUtf8Lenient & fromMaybe "<none yet>" & toAttribute) + ] + + updateTransmissionSessionId tid + doTransmissionRequest span dat (req, parser) - 200 -> + 200 -> do + addAttributes span $ + HashMap.fromList + [ ("transmission.valid_session_id", sessionId <&> bytesToTextUtf8Lenient & fromMaybe "<none yet>" & toAttribute) + ] resp & Http.getResponseBody & Json.parseStrict @@ -292,15 +329,15 @@ doTransmissionRequest span dat (req, parser) = do case Json.eitherDecodeStrict' @Json.Value (resp & Http.getResponseBody) of Left _err -> pure () Right val -> logInfo [fmt|failing transmission response: {showPrettyJson val}|] - appThrowTree span err - _ -> liftIO $ unwrapIOError $ Left [fmt|Non-200 response: {showPretty resp}|] + appThrow span (AppExceptionTree err) + _ -> appThrow span $ AppExceptionPretty [[fmt|Non-200 response:|], pretty resp] class MonadTransmission m where - getTransmissionId :: m (Maybe ByteString) - setTransmissionId :: ByteString -> m () + getCurrentTransmissionSessionId :: m (Maybe ByteString) + updateTransmissionSessionId :: ByteString -> m () instance (MonadIO m) => MonadTransmission (AppT m) where - getTransmissionId = AppT (asks (.transmissionSessionId)) >>= tryTakeMVar - setTransmissionId t = do + getCurrentTransmissionSessionId = AppT (asks (.transmissionSessionId)) >>= readIORef + updateTransmissionSessionId t = do var <- AppT $ asks (.transmissionSessionId) - putMVar var t + writeIORef var (Just t) diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index 1ec23e1fc707..c8850e70a121 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -1,8 +1,10 @@ +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE QuasiQuotes #-} module WhatcdResolver where import AppT +import Arg import Control.Category qualified as Cat import Control.Monad.Catch.Pure (runCatch) import Control.Monad.Logger.CallStack @@ -10,19 +12,20 @@ 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.Error.Tree import Data.HashMap.Strict qualified as HashMap import Data.List qualified as List import Data.Map.Strict qualified as Map import Data.Pool qualified as Pool import Data.Text qualified as Text import Database.PostgreSQL.Simple qualified as Postgres -import Database.PostgreSQL.Simple.SqlQQ (sql) import Database.PostgreSQL.Simple.Types (PGArray (PGArray)) import Database.Postgres.Temp qualified as TmpPg import FieldParser (FieldParser, FieldParser' (..)) import FieldParser qualified as Field import Html qualified import IHP.HSX.QQ (hsx) +import IHP.HSX.ToHtml (ToHtml) import Json qualified import Json.Enc (Enc) import Json.Enc qualified as Enc @@ -39,7 +42,6 @@ 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 qualified as Wai import OpenTelemetry.Attributes qualified as Otel import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan') import OpenTelemetry.Trace.Monad qualified as Otel @@ -49,6 +51,7 @@ import Postgres.Decoder qualified as Dec import Postgres.MonadPostgres import Pretty import Redacted +import RunCommand (runCommandExpect0) import System.Directory qualified as Dir import System.Directory qualified as Xdg import System.Environment qualified as Env @@ -88,14 +91,17 @@ htmlUi = do let catchAppException act = try act >>= \case Right a -> pure a - Left (AppException err) -> do - runInIO (logError err) + Left (AppExceptionTree err) -> do + runInIO (logError (prettyErrorTree err)) + respondOrig (Wai.responseLBS Http.status500 [] "") + Left (AppExceptionPretty err) -> do + runInIO (logError (err & Pretty.prettyErrsNoColor & stringToText)) respondOrig (Wai.responseLBS Http.status500 [] "") catchAppException $ do let mp span parser = Multipart.parseMultipartOrThrow - (appThrowTree span) + (appThrow span . AppExceptionTree) parser req @@ -105,13 +111,10 @@ htmlUi = do ( do label @"torrentId" <$> Multipart.field "torrent-id" ((Field.utf8 >>> Field.signedDecimal >>> Field.bounded @Int "int")) ) - let parseQueryArgs span parser = - Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) req - & assertM span id let parseQueryArgsNewSpan spanName parser = Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) req - & assertMNewSpan spanName id + & assertMNewSpan spanName (first AppExceptionTree) let handlers :: Handlers (AppT IO) handlers respond = @@ -134,7 +137,7 @@ htmlUi = do Html.mkVal <$> (runTransaction $ getTorrentById dat) ), ( "snips/redacted/getTorrentFile", - respond.html $ \span -> do + respond.htmlOrReferer $ \span -> do dat <- torrentIdMp span runTransaction $ do inserted <- redactedGetTorrentFileAndInsert dat @@ -160,7 +163,7 @@ htmlUi = do file <- getTorrentFileById dat <&> annotate [fmt|No torrent file for torrentId "{dat.torrentId}"|] - >>= orAppThrowTree span + >>= orAppThrow span running <- lift @Transaction $ @@ -196,27 +199,29 @@ htmlUi = do Just _torrent -> [hsx|Running|] ), ( "snips/jsonld/render", - respond.html $ \span -> do - qry <- - parseQueryArgs - span - ( label @"target" - <$> ( (singleQueryArgument "target" Field.utf8 >>> textToURI) - & Parse.andParse uriToHttpClientRequest - ) - ) - jsonld <- httpGetJsonLd (qry.target) - pure $ renderJsonld jsonld + do + let HandlerResponses {htmlWithQueryArgs} = respond + htmlWithQueryArgs + ( label @"target" + <$> ( (singleQueryArgument "target" Field.utf8 >>> textToURI) + & Parse.andParse uriToHttpClientRequest + ) + ) + ( \qry _span -> do + jsonld <- httpGetJsonLd (qry.target) + pure $ renderJsonld jsonld + ) ), ( "artist", - respond.html $ \span -> do - qry <- - parseQueryArgs - span - ( label @"dbId" - <$> (singleQueryArgument "db_id" Field.utf8) - ) - artistPage qry + do + let HandlerResponses {htmlWithQueryArgs} = respond + + htmlWithQueryArgs + ( label @"artistRedactedId" + <$> (singleQueryArgument "redacted_id" (Field.utf8 >>> Field.decimalNatural)) + ) + $ \qry _span -> do + artistPage qry ), ( "autorefresh", respond.plain $ do @@ -256,15 +261,65 @@ htmlUi = do -- "https://musicbrainz.org/work/92000fd4-d304-406d-aeb4-6bdbeed318ec" -- ) -- <&> renderJsonld - bestTorrentsTable <- getBestTorrentsTable + bestTorrentsTable <- getBestTorrentsTable Nothing -- transmissionTorrentsTable <- lift @Transaction getTransmissionTorrentsTable pure $ - Html.docTypeHtml + htmlPageChrome + "whatcd-resolver" [hsx| + <form + hx-post="/snips/redacted/search" + hx-target="#redacted-search-results"> + <label for="redacted-search">Redacted Search</label> + <input + id="redacted-search" + type="text" + name="redacted-search" /> + <button type="submit" hx-disabled-elt="this">Search</button> + <div class="htmx-indicator">Search running!</div> + </form> + <div id="redacted-search-results"> + {bestTorrentsTable} + </div> + <!-- refresh the page if the uniqueRunId is different --> + <input + hidden + type="text" + id="autorefresh" + name="hasItBeenRestarted" + value={uniqueRunId} + hx-get="/autorefresh" + hx-trigger="every 5s" + hx-swap="none" + /> + |] + +-- | Reload the current page (via the Referer header) if the browser has Javascript disabled (and thus htmx does not work). This should make post requests work out of the box. +htmxOrReferer :: Wai.Request -> Wai.Response -> Wai.Response +htmxOrReferer req act = do + let fnd h = req & Wai.requestHeaders & List.find (\(hdr, _) -> hdr == h) + let referer = fnd "Referer" + if + | Just _ <- fnd "Hx-Request" -> act + | Nothing <- referer -> act + | Just (_, rfr) <- referer -> do + Wai.responseLBS seeOther303 [("Location", rfr)] "" + +htmlPageChrome :: (ToHtml a) => Text -> a -> Html +htmlPageChrome title body = + Html.docTypeHtml $ + [hsx| <head> - <title>whatcd-resolver</title> + <!-- TODO: set nice page title for each page --> + <title>{title}</title> <meta charset="utf-8"> <meta name="viewport" content="width=device-width, initial-scale=1"> + <!-- + prevent favicon request, based on answers in + https://stackoverflow.com/questions/1321878/how-to-prevent-favicon-ico-requests + 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"> <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> @@ -277,46 +332,45 @@ htmlUi = do </style> </head> <body> - <form - hx-post="/snips/redacted/search" - hx-target="#redacted-search-results"> - <label for="redacted-search">Redacted Search</label> - <input - id="redacted-search" - type="text" - name="redacted-search" /> - <button type="submit" hx-disabled-elt="this">Search</button> - <div class="htmx-indicator">Search running!</div> - </form> - <div id="redacted-search-results"> - {bestTorrentsTable} - </div> - <!-- refresh the page if the uniqueRunId is different --> - <input - hidden - type="text" - id="autorefresh" - name="hasItBeenRestarted" - value={uniqueRunId} - hx-get="/autorefresh" - hx-trigger="every 5s" - hx-swap="none" - /> + {body} </body> |] -artistPage :: (HasField "dbId" dat Text, Applicative m) => dat -> m Html -artistPage dat = do - pure - [hsx| - Artist ID: {dat.dbId} - |] +artistPage :: + ( HasField "artistRedactedId" dat Natural, + MonadPostgres m, + MonadOtel m, + MonadLogger m, + MonadThrow m, + MonadTransmission m + ) => + dat -> + m Html +artistPage dat = runTransaction $ do + fresh <- getBestTorrentsData (Just $ getLabel @"artistRedactedId" dat) + let artistName = fresh & findMaybe (\t -> t.artists & findMaybe (\a -> if a.artistId == (dat.artistRedactedId & fromIntegral @Natural @Int) then Just a.artistName else Nothing)) + let torrents = mkBestTorrentsTable fresh + pure $ + htmlPageChrome + ( case artistName of + Nothing -> "whatcd-resolver" + Just a -> [fmt|{a} - Artist Page - whatcd-resolver|] + ) + [hsx| + Artist ID: {dat.artistRedactedId} + + {torrents} + |] type Handlers m = HandlerResponses m -> Map Text (m ResponseReceived) data HandlerResponses m = HandlerResponses { -- | render html - html :: ((Otel.Span -> m Html) -> m ResponseReceived), + html :: (Otel.Span -> m Html) -> m ResponseReceived, + -- | render html after parsing some query arguments + htmlWithQueryArgs :: forall a. (Parse Query a -> (a -> Otel.Span -> m Html) -> m ResponseReceived), + -- | render html or reload the page via the Referer header if no htmx + htmlOrReferer :: (Otel.Span -> m Html) -> m ResponseReceived, -- | render a plain wai response plain :: (m Wai.Response -> m ResponseReceived) } @@ -330,23 +384,50 @@ runHandlers :: m ResponseReceived runHandlers defaultHandler handlers req respond = withRunInIO $ \runInIO -> do let path = req & Wai.pathInfo & Text.intercalate "/" + let html' resp act = + Otel.inSpan' + [fmt|Route /{path}|] + ( Otel.defaultSpanArguments + { Otel.attributes = + HashMap.fromList + [ ("_.server.path", Otel.toAttribute @Text path), + ("_.server.query_args", Otel.toAttribute @Text (req.rawQueryString & bytesToTextUtf8Lenient)) + ] + } + ) + ( \span -> do + res <- act span <&> (\h -> T2 (label @"html" h) (label @"extraHeaders" [])) + addEventSimple span "Got Html result, rendering…" + liftIO $ respond (resp res) + ) + let htmlResp res = Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . Html.renderHtml $ res.html + let html = html' htmlResp + let htmlOrReferer = html' $ \res -> htmxOrReferer req (htmlResp res) + let handlerResponses = ( HandlerResponses { plain = (\m -> liftIO $ runInIO m >>= respond), - html = \act -> - Otel.inSpan' - [fmt|Route /{path}|] - ( Otel.defaultSpanArguments - { Otel.attributes = - HashMap.fromList - [ ("server.path", Otel.toAttribute @Text path) - ] - } - ) - ( \span -> do - res <- act span <&> (\html -> T2 (label @"html" html) (label @"extraHeaders" [])) - liftIO $ respond . Wai.responseLBS Http.ok200 ([("Content-Type", "text/html")] <> res.extraHeaders) . Html.renderHtml $ res.html - ) + html, + htmlWithQueryArgs = \parser act -> + case req & Parse.runParse "Unable to find the right request query arguments" (lmap Wai.queryString parser) of + Right a -> html (act a) + Left err -> + html + ( \span -> do + recordException + span + ( T2 + (label @"type_" "Query Parse Exception") + (label @"message" (prettyErrorTree err)) + ) + + pure + [hsx| + <h1>Error:</h1> + <pre>{err & prettyErrorTree}</pre> + |] + ), + htmlOrReferer } ) let handler = @@ -373,6 +454,24 @@ singleQueryArgument field inner = ) >>> Parse.fieldParser inner +singleQueryArgumentMay :: Text -> FieldParser ByteString to -> Parse Http.Query (Maybe to) +singleQueryArgumentMay field inner = + Parse.mkParsePushContext + field + ( \(ctx, qry) -> case qry + & mapMaybe + ( \(k, v) -> + if k == (field & textToBytesUtf8) + then Just v + else Nothing + ) of + [] -> Right Nothing + [Nothing] -> Left [fmt|Expected one query argument with a value, but "{field}" was a query flag|] + [Just one] -> Right (Just one) + more -> Left [fmt|More than one value for query argument "{field}": {show more}, at {ctx & Parse.showContext}|] + ) + >>> Parse.maybe (Parse.fieldParser inner) + -- | Make sure we can parse the given Text into an URI. textToURI :: Parse Text URI textToURI = @@ -415,7 +514,8 @@ snipsRedactedSearch :: HasField "searchstr" r ByteString, MonadThrow m, MonadTransmission m, - MonadOtel m + MonadOtel m, + MonadRedacted m ) => r -> m Html @@ -427,7 +527,11 @@ snipsRedactedSearch dat = do ] runTransaction $ do t - getBestTorrentsTable + getBestTorrentsTable (Nothing :: Maybe (Label "artistRedactedId" Natural)) + +data ArtistFilter = ArtistFilter + { onlyArtist :: Maybe (Label "artistId" Text) + } getBestTorrentsTable :: ( MonadTransmission m, @@ -436,60 +540,113 @@ getBestTorrentsTable :: MonadPostgres m, MonadOtel m ) => + Maybe (Label "artistRedactedId" Natural) -> Transaction m Html -getBestTorrentsTable = do - bestStale :: [TorrentData ()] <- getBestTorrents (label @"onlyDownloaded" False) - actual <- +getBestTorrentsTable dat = do + fresh <- getBestTorrentsData dat + pure $ mkBestTorrentsTable fresh + +doIfJust :: (Applicative f) => (a -> f ()) -> Maybe a -> f () +doIfJust = traverse_ + +getBestTorrentsData :: + ( MonadTransmission m, + MonadThrow m, + MonadLogger m, + MonadPostgres m, + MonadOtel m + ) => + Maybe (Label "artistRedactedId" Natural) -> + Transaction m [TorrentData (Label "percentDone" Percentage)] +getBestTorrentsData artistFilter = inSpan' "get torrents table data" $ \span -> do + artistFilter & doIfJust (\a -> addAttribute span "artist-filter.redacted-id" (a.artistRedactedId & showToText & Otel.toAttribute)) + let getBest = getBestTorrents GetBestTorrentsFilter {onlyArtist = artistFilter, onlyDownloaded = False} + bestStale :: [TorrentData ()] <- getBest + (statusInfo, transmissionStatus) <- getAndUpdateTransmissionTorrentsStatus ( bestStale & mapMaybe ( \td -> case td.torrentStatus of - InTransmission h -> Just h + InTransmission h -> Just (getLabel @"torrentHash" h, td) _ -> Nothing ) - <&> (\t -> (getLabel @"torrentHash" t, t.transmissionInfo)) & Map.fromList ) - let fresh = - bestStale - -- we have to update the status of every torrent that’s not in tranmission anymore - -- TODO I feel like it’s easier (& more correct?) to just do the database request again … - <&> ( \td -> case td.torrentStatus of - InTransmission info -> - case actual & Map.lookup (getLabel @"torrentHash" info) of - -- TODO this is also pretty dumb, cause it assumes that we have the torrent file if it was in transmission before, - -- which is an internal factum that is established in getBestTorrents (and might change later) - Nothing -> td {torrentStatus = NotInTransmissionYet} - Just transmissionInfo -> td {torrentStatus = InTransmission (T2 (getLabel @"torrentHash" info) (label @"transmissionInfo" transmissionInfo))} - NotInTransmissionYet -> td {torrentStatus = NotInTransmissionYet} - NoTorrentFileYet -> td {torrentStatus = NoTorrentFileYet} - ) + bestBest <- + -- Instead of serving a stale table when a torrent gets deleted, fetch + -- the whole view again. This is a little wasteful, but torrents + -- shouldn’t get deleted very often, so it’s fine. + -- Re-evaluate invariant if this happens too often. + if statusInfo.knownTorrentsStale + then inSpan' "Fetch torrents table data again" $ + \span' -> do + addEventSimple span' "The transmission torrent list was out of date, refetching torrent list." + getBest + else pure bestStale + pure $ + bestBest + -- we have to update the status of every torrent that’s not in tranmission anymore + -- TODO I feel like it’s easier (& more correct?) to just do the database request again … + <&> ( \td -> case td.torrentStatus of + InTransmission info -> + case transmissionStatus & Map.lookup (getLabel @"torrentHash" info) of + -- TODO this is also pretty dumb, cause it assumes that we have the torrent file if it was in transmission before, + -- which is an internal factum that is established in getBestTorrents (and might change later) + Nothing -> td {torrentStatus = NotInTransmissionYet} + Just transmissionInfo -> td {torrentStatus = InTransmission (T2 (getLabel @"torrentHash" info) (label @"transmissionInfo" transmissionInfo))} + NotInTransmissionYet -> td {torrentStatus = NotInTransmissionYet} + NoTorrentFileYet -> td {torrentStatus = NoTorrentFileYet} + ) + +mkBestTorrentsTable :: [TorrentData (Label "percentDone" Percentage)] -> Html +mkBestTorrentsTable fresh = do let localTorrent b = case b.torrentStatus of - NoTorrentFileYet -> [hsx|<button hx-post="snips/redacted/getTorrentFile" hx-swap="outerHTML" hx-vals={Enc.encToBytesUtf8 $ Enc.object [("torrent-id", Enc.int b.torrentId)]}>Upload Torrent</button>|] + NoTorrentFileYet -> + [hsx| + <form method="post"> + <input type="hidden" name="torrent-id" value={b.torrentId & show} /> + <button + formaction="snips/redacted/getTorrentFile" + hx-post="snips/redacted/getTorrentFile" + hx-swap="outerHTML" + hx-vals={Enc.encToBytesUtf8 $ Enc.object [("torrent-id", Enc.int b.torrentId)]}>Upload Torrent</button> + </form> + |] InTransmission info -> [hsx|{info.transmissionInfo.percentDone.unPercentage}% done|] NotInTransmissionYet -> [hsx|<button hx-post="snips/redacted/startTorrentFile" hx-swap="outerHTML" hx-vals={Enc.encToBytesUtf8 $ Enc.object [("torrent-id", Enc.int b.torrentId)]}>Start Torrent</button>|] let bestRows = fresh & foldMap ( \b -> do - let artistLink :: Text = [fmt|/artist?db_id={b.groupId}|] + let artists = + b.artists + <&> ( \a -> + T2 + (label @"url" [fmt|/artist?redacted_id={a.artistId}|]) + (label @"content" $ Html.toHtml @Text a.artistName) + ) + & mkLinkList + [hsx| <tr> <td>{localTorrent b}</td> <td>{Html.toHtml @Int b.groupId}</td> <td> - <a href={artistLink}> - {Html.toHtml @Text b.torrentGroupJson.artist} + {artists} + </td> + <td> + <a href={mkRedactedTorrentLink (Arg b.groupId)} target="_blank"> + {Html.toHtml @Text b.torrentGroupJson.groupName} </a> </td> - <td>{Html.toHtml @Text b.torrentGroupJson.groupName}</td> + <td>{Html.toHtml @Natural b.torrentGroupJson.groupYear}</td> <td>{Html.toHtml @Int b.seedingWeight}</td> + <td>{Html.toHtml @Text b.torrentFormat}</td> <td><details hx-trigger="toggle once" hx-post="snips/redacted/torrentDataJson" hx-vals={Enc.encToBytesUtf8 $ Enc.object [("torrent-id", Enc.int b.torrentId)]}></details></td> </tr> |] ) - pure $ - [hsx| + [hsx| <table class="table"> <thead> <tr> @@ -497,9 +654,10 @@ getBestTorrentsTable = do <th>Group ID</th> <th>Artist</th> <th>Name</th> + <th>Year</th> <th>Weight</th> + <th>Format</th> <th>Torrent</th> - <th>Torrent Group</th> </tr> </thead> <tbody> @@ -508,6 +666,15 @@ getBestTorrentsTable = do </table> |] +mkLinkList :: [T2 "url" Text "content" Html] -> Html +mkLinkList xs = + xs + <&> ( \x -> do + [hsx|<a href={x.url}>{x.content}</a>|] + ) + & List.intersperse ", " + & mconcat + getTransmissionTorrentsTable :: (MonadTransmission m, MonadThrow m, MonadLogger m, MonadOtel m) => m Html getTransmissionTorrentsTable = do @@ -543,7 +710,7 @@ assertOneUpdated :: m () assertOneUpdated span name x = case x.numberOfRowsAffected of 1 -> pure () - n -> appThrowTree span ([fmt|{name :: Text}: Expected to update exactly one row, but updated {n :: Natural} row(s)|]) + n -> appThrow span ([fmt|{name :: Text}: Expected to update exactly one row, but updated {n :: Natural} row(s)|]) migrate :: ( MonadPostgres m, @@ -571,77 +738,86 @@ migrate = inSpan "Database Migration" $ do UNIQUE(torrent_id) ); + CREATE INDEX IF NOT EXISTS redacted_torrents_json_torrent_group_fk ON redacted.torrents_json (torrent_group); + + ALTER TABLE redacted.torrents_json ADD COLUMN IF NOT EXISTS torrent_file bytea NULL; ALTER TABLE redacted.torrents_json ADD COLUMN IF NOT EXISTS transmission_torrent_hash text NULL; - -- inflect out values of the full json + -- the seeding weight is used to find the best torrent in a group. + CREATE OR REPLACE FUNCTION calc_seeding_weight(full_json_result jsonb) RETURNS int AS $$ + BEGIN + RETURN + -- three times seeders plus one times snatches + (3 * (full_json_result->'seeders')::integer + + (full_json_result->'snatches')::integer + ) + -- prefer remasters by multiplying them with 3 + * (CASE + WHEN full_json_result->>'remasterTitle' ILIKE '%remaster%' + THEN 3 + ELSE 1 + END) + -- slightly push mp3 V0, to make sure it’s preferred over 320 CBR + * (CASE + WHEN full_json_result->>'encoding' ILIKE '%v0%' + THEN 2 + ELSE 1 + END) + -- remove 24bit torrents from the result (wayyy too big) + * (CASE + WHEN full_json_result->>'encoding' ILIKE '%24bit%' + THEN 0 + ELSE 1 + END) + -- discount FLACS, so we only use them when there’s no mp3 alternative (to save space) + / (CASE + WHEN full_json_result->>'encoding' ILIKE '%lossless%' + THEN 5 + ELSE 1 + END) + ; + END; + $$ LANGUAGE plpgsql IMMUTABLE; + + ALTER TABLE redacted.torrents_json + ADD COLUMN IF NOT EXISTS seeding_weight int GENERATED ALWAYS AS (calc_seeding_weight(full_json_result)) STORED; + + -- inflect out values of the full json CREATE OR REPLACE VIEW redacted.torrents AS SELECT t.id, t.torrent_id, t.torrent_group, -- the seeding weight is used to find the best torrent in a group. - ( ((full_json_result->'seeders')::integer*3 - + (full_json_result->'snatches')::integer - ) - -- prefer remasters by multiplying them with 3 - * (CASE - WHEN full_json_result->>'remasterTitle' ILIKE '%remaster%' - THEN 3 - ELSE 1 - END) - ) - AS seeding_weight, + t.seeding_weight, t.full_json_result, t.torrent_file, t.transmission_torrent_hash FROM redacted.torrents_json t; + CREATE INDEX IF NOT EXISTS torrents_json_seeding ON redacted.torrents_json(((full_json_result->'seeding')::integer)); CREATE INDEX IF NOT EXISTS torrents_json_snatches ON redacted.torrents_json(((full_json_result->'snatches')::integer)); |] () -httpTorrent :: - ( MonadIO m, - MonadThrow m - ) => - Otel.Span -> - Http.Request -> - m ByteString -httpTorrent span req = - Http.httpBS req - >>= assertM - span - ( \resp -> do - let statusCode = resp & Http.responseStatus & (.statusCode) - contentType = - resp - & Http.responseHeaders - & List.lookup "content-type" - <&> Wai.parseContentType - <&> (\(ct, _mimeAttributes) -> ct) - if - | statusCode == 200, - Just "application/x-bittorrent" <- contentType -> - Right $ (resp & Http.responseBody) - | statusCode == 200, - Just otherType <- contentType -> - Left [fmt|Redacted returned a non-torrent body, with content-type "{otherType}"|] - | statusCode == 200, - Nothing <- contentType -> - Left [fmt|Redacted returned a body with unspecified content type|] - | code <- statusCode -> Left [fmt|Redacted returned an non-200 error code, code {code}: {resp & showPretty}|] - ) - runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a) runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do tool <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format") - pgFormat <- initPgFormatPool (label @"pgFormat" tool) - let config = label @"logDatabaseQueries" LogDatabaseQueries + prettyPrintDatabaseQueries <- + Env.lookupEnv "WHATCD_RESOLVER_PRETTY_PRINT_DATABASE_QUERIES" >>= \case + Nothing -> pure DontPrettyPrintDatabaseQueries + Just _ -> do + pgFormat <- initPgFormatPool (label @"pgFormat" tool) + pure $ PrettyPrintDatabaseQueries pgFormat + let pgConfig = + T2 + (label @"logDatabaseQueries" LogDatabaseQueries) + (label @"prettyPrintDatabaseQueries" prettyPrintDatabaseQueries) pgConnPool <- Pool.newPool $ Pool.defaultPoolConfig @@ -649,12 +825,29 @@ runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do {- resource destruction -} Postgres.close {- unusedResourceOpenTime -} 10 {- max resources across all stripes -} 20 - transmissionSessionId <- newEmptyMVar + transmissionSessionId <- newIORef Nothing + redactedApiKey <- + Env.lookupEnv "WHATCD_RESOLVER_REDACTED_API_KEY" >>= \case + Just k -> pure (k & stringToBytesUtf8) + Nothing -> runStderrLoggingT $ do + logInfo "WHATCD_RESOLVER_REDACTED_API_KEY was not set, trying pass" + runCommandExpect0 "pass" ["internet/redacted/api-keys/whatcd-resolver"] let newAppT = do - logInfo [fmt|Running with config: {showPretty config}|] + logInfo [fmt|Running with config: {showPretty pgConfig}|] logInfo [fmt|Connected to database at {db & TmpPg.toDataDirectory} on socket {db & TmpPg.toConnectionString}|] appT runReaderT newAppT.unAppT Context {..} + `catch` ( \case + AppExceptionPretty p -> throwM $ EscapedException (p & Pretty.prettyErrs) + AppExceptionTree t -> throwM $ EscapedException (t & prettyErrorTree & textToString) + ) + +-- | Just a silly wrapper so that correctly format any 'AppException' that would escape the runAppWith scope. +newtype EscapedException = EscapedException String + deriving anyclass (Exception) + +instance Show EscapedException where + show (EscapedException s) = s withTracer :: (Otel.Tracer -> IO c) -> IO c withTracer f = do |