diff options
Diffstat (limited to 'users/Profpatsch/whatcd-resolver/src/Transmission.hs')
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Transmission.hs | 91 |
1 files changed, 64 insertions, 27 deletions
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) |