diff --git a/users/Profpatsch/whatcd-resolver/src/AppT.hs b/users/Profpatsch/whatcd-resolver/src/AppT.hs index 0c93cbadd..4363e2dbb 100644 --- a/users/Profpatsch/whatcd-resolver/src/AppT.hs +++ b/users/Profpatsch/whatcd-resolver/src/AppT.hs @@ -12,6 +12,8 @@ import Data.Pool (Pool) import Data.Text qualified as Text import Database.PostgreSQL.Simple qualified as Postgres 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') @@ -27,7 +29,8 @@ data Context = Context tracer :: Otel.Tracer, pgFormat :: PgFormatPool, pgConnPool :: Pool Postgres.Connection, - transmissionSessionId :: IORef (Maybe ByteString) + transmissionSessionId :: IORef (Maybe ByteString), + redactedApiKey :: ByteString } newtype AppT m a = AppT {unAppT :: ReaderT Context m a} @@ -67,6 +70,15 @@ 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 ("_." <>) +-- | Create an otel attribute from a json encoder +jsonAttribute :: Enc -> Otel.Attribute +jsonAttribute e = e & Enc.encToTextPretty & Otel.toAttribute + +orThrowAppErrorNewSpan :: (MonadThrow m, MonadOtel m) => Text -> Either ErrorTree a -> m a +orThrowAppErrorNewSpan msg = \case + Left err -> appThrowTreeNewSpan msg err + Right a -> pure a + appThrowTreeNewSpan :: (MonadThrow m, MonadOtel m) => Text -> ErrorTree -> m a appThrowTreeNewSpan spanName exc = inSpan' spanName $ \span -> do let msg = prettyErrorTree exc @@ -127,7 +139,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) ], .. } diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index c0ad9071a..3427d9c94 100644 --- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs +++ b/users/Profpatsch/whatcd-resolver/src/Redacted.hs @@ -27,11 +27,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 @@ -48,7 +53,8 @@ redactedGetTorrentFile :: ( MonadLogger m, MonadThrow m, HasField "torrentId" dat Int, - MonadOtel m + MonadOtel m, + MonadRedacted m ) => dat -> m ByteString @@ -71,7 +77,7 @@ redactedGetTorrentFile dat = inSpan' "Redacted Get Torrent File" $ \span -> do 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 @@ -108,7 +114,8 @@ redactedSearchAndInsert :: ( MonadLogger m, MonadPostgres m, MonadThrow m, - MonadOtel m + MonadOtel m, + MonadRedacted m ) => [(ByteString, ByteString)] -> m (Transaction m ()) @@ -289,12 +296,13 @@ redactedGetTorrentFileAndInsert :: 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 @@ -468,15 +476,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" @@ -558,10 +565,10 @@ httpJson opts parser req = inSpan' "HTTP Request (JSON)" $ \span -> do 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 -> diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index 73a9dccb1..a3fa07c18 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -11,7 +11,7 @@ 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 (prettyErrorTree) +import Data.Error.Tree import Data.HashMap.Strict qualified as HashMap import Data.List qualified as List import Data.Map.Strict qualified as Map @@ -52,6 +52,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 @@ -469,7 +470,8 @@ snipsRedactedSearch :: HasField "searchstr" r ByteString, MonadThrow m, MonadTransmission m, - MonadOtel m + MonadOtel m, + MonadRedacted m ) => r -> m Html @@ -758,6 +760,12 @@ runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do {- unusedResourceOpenTime -} 10 {- max resources across all stripes -} 20 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|Connected to database at {db & TmpPg.toDataDirectory} on socket {db & TmpPg.toConnectionString}|]