diff options
Diffstat (limited to 'users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs')
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs | 733 |
1 files changed, 2 insertions, 731 deletions
diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index d21892b9e7..4b449559f7 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs @@ -11,23 +11,19 @@ import Data.Aeson qualified as Json import Data.Aeson.BetterErrors qualified as Json import Data.Aeson.KeyMap qualified as KeyMap import Data.ByteString.Builder qualified as Builder -import Data.Error.Tree import Data.HashMap.Strict qualified as HashMap import Data.List qualified as List -import Data.List.NonEmpty qualified as NonEmpty import Data.Map.Strict qualified as Map import Data.Pool qualified as Pool import Data.Set (Set) import Data.Set qualified as Set import Data.Text qualified as Text -import Database.PostgreSQL.Simple (Binary (Binary), Only (..)) 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 GHC.Records (HasField (..)) import Html qualified import IHP.HSX.QQ (hsx) import Json qualified @@ -54,7 +50,7 @@ import Parse qualified import Postgres.Decoder qualified as Dec import Postgres.MonadPostgres import Pretty -import RunCommand (runCommandExpect0) +import Redacted import System.Directory qualified as Dir import System.Directory qualified as Xdg import System.Environment qualified as Env @@ -64,6 +60,7 @@ import Text.Blaze.Html.Renderer.Pretty qualified as Html.Pretty import Text.Blaze.Html.Renderer.Utf8 qualified as Html import Text.Blaze.Html5 qualified as Html import Tool (readTool, readTools) +import Transmission import UnliftIO import Prelude hiding (span) @@ -551,58 +548,6 @@ renderJsonld = \case schemaType t = let href :: Text = [fmt|https://schema.org/{t}|] in [hsx|<a href={href} target="_blank">{t}</a>|] --- | A value between (inclusive) 0% and (inclusive) 100%. Precise to 1% steps. -newtype Percentage = Percentage {unPercentage :: Int} - deriving stock (Show) - --- | Parse a scientific into a Percentage -scientificPercentage :: FieldParser' Error Scientific Percentage -scientificPercentage = - Field.boundedScientificRealFloat @Float - >>> ( FieldParser $ \f -> - if - | f < 0 -> Left "percentage cannot be negative" - | f > 1 -> Left "percentage cannot be over 100%" - | 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 -getAndUpdateTransmissionTorrentsStatus :: - ( MonadTransmission m, - MonadThrow m, - MonadLogger m, - MonadPostgres m, - MonadOtel m - ) => - Map (Label "torrentHash" Text) () -> - (Transaction m (Map (Label "torrentHash" Text) (Label "percentDone" Percentage))) -getAndUpdateTransmissionTorrentsStatus knownTorrents = do - let fields = ["hashString", "percentDone"] - actualTorrents <- - lift @Transaction $ - doTransmissionRequest' - ( transmissionRequestListOnlyTorrents - ( T2 - (label @"fields" fields) - (label @"ids" (Map.keys knownTorrents)) - ) - $ do - torrentHash <- Json.keyLabel @"torrentHash" "hashString" Json.asText - percentDone <- Json.keyLabel @"percentDone" "percentDone" (Field.toJsonParser $ Field.jsonNumber >>> scientificPercentage) - pure (torrentHash, percentDone) - ) - <&> 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 - getTransmissionTorrentsTable :: (MonadTransmission m, MonadThrow m, MonadLogger m, MonadOtel m) => m Html getTransmissionTorrentsTable = do @@ -627,513 +572,9 @@ getTransmissionTorrentsTable = do & List.take 100 ) -data TransmissionRequest = TransmissionRequest - { method :: Text, - arguments :: Map Text Enc, - tag :: Maybe Int - } - deriving stock (Show) - -testTransmission :: (Show out) => (TransmissionRequest, Json.Parse Error out) -> IO (Either TmpPg.StartError ()) -testTransmission req = runAppWith $ inSpan' "Test Transmission" $ \span -> - doTransmissionRequest - span - transmissionConnectionConfig - req - >>= liftIO . printPretty - -transmissionConnectionConfig :: T2 "host" Text "port" Text -transmissionConnectionConfig = (T2 (label @"host" "localhost") (label @"port" "9091")) - -transmissionRequestListAllTorrents :: (Monad m) => [Text] -> Json.ParseT e m out -> (TransmissionRequest, Json.ParseT e m [out]) -transmissionRequestListAllTorrents fields parseTorrent = - ( TransmissionRequest - { method = "torrent-get", - arguments = - Map.fromList - [ ("fields", Enc.list Enc.text fields) - ], - tag = Nothing - }, - Json.key "torrents" $ Json.eachInArray parseTorrent - ) - -transmissionRequestListOnlyTorrents :: - ( HasField "ids" r1 [(Label "torrentHash" Text)], - HasField "fields" r1 [Text], - Monad m - ) => - r1 -> - Json.ParseT e m out -> - (TransmissionRequest, Json.ParseT e m [out]) -transmissionRequestListOnlyTorrents dat parseTorrent = - ( TransmissionRequest - { method = "torrent-get", - arguments = - Map.fromList - [ ("ids", Enc.list (\i -> Enc.text i.torrentHash) dat.ids), - ("fields", Enc.list Enc.text dat.fields) - ], - tag = Nothing - }, - Json.key "torrents" $ Json.eachInArray parseTorrent - ) - -transmissionRequestAddTorrent :: - (HasField "torrentFile" r ByteString, Monad m) => - r -> - ( TransmissionRequest, - Json.ParseT err m (T2 "torrentHash" Text "torrentName" Text) - ) -transmissionRequestAddTorrent dat = - ( TransmissionRequest - { method = "torrent-add", - arguments = - Map.fromList - [ ("metainfo", Enc.base64Bytes dat.torrentFile), - ("paused", Enc.bool False) - ], - tag = Nothing - }, - do - let p method = Json.key method $ do - hash <- Json.keyLabel @"torrentHash" "hashString" Json.asText - name <- Json.keyLabel @"torrentName" "name" Json.asText - pure $ T2 hash name - p "torrent-duplicate" Json.<|> p "torrent-added" - ) - -data TransmissionResponse output = TransmissionResponse - { result :: TransmissionResponseStatus, - arguments :: Maybe output, - tag :: Maybe Int - } - deriving stock (Show) - -data TransmissionResponseStatus - = TransmissionResponseSuccess - | TransmissionResponseFailure Text - deriving stock (Show) - -doTransmissionRequest' :: - ( MonadTransmission m, - MonadThrow m, - MonadLogger m, - MonadOtel m - ) => - (TransmissionRequest, Json.Parse Error output) -> - m output -doTransmissionRequest' req = inSpan' "Transmission Request" $ \span -> do - resp <- - doTransmissionRequest - span - transmissionConnectionConfig - req - case resp.result of - TransmissionResponseFailure err -> appThrowTree span (nestedError "Transmission RPC error" $ singleError $ newError err) - TransmissionResponseSuccess -> case resp.arguments of - Nothing -> appThrowTree span "Transmission RPC error: No `arguments` field in response" - Just out -> pure out - --- | Contact the transmission RPC, and do the CSRF protection dance. --- --- Spec: https://github.com/transmission/transmission/blob/main/docs/rpc-spec.md -doTransmissionRequest :: - ( MonadTransmission m, - HasField "host" t1 Text, - HasField "port" t1 Text, - MonadThrow m, - MonadLogger m, - Otel.MonadTracer m, - MonadUnliftIO m - ) => - Otel.Span -> - t1 -> - (TransmissionRequest, Json.Parse Error output) -> - m (TransmissionResponse output) -doTransmissionRequest span dat (req, parser) = do - sessionId <- getTransmissionId - 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) - - let body :: [(Text, (Enc, Otel.Attribute))] = - ( [ ("method", req.method & textArg), - ("arguments", encArg $ Enc.map id req.arguments) - ] - <> (req.tag & foldMap (\t -> [("tag", t & intArg)])) - ) - addAttributes - span - ( HashMap.fromList $ - body - <&> bimap - (\k -> [fmt|transmission.{k}|]) - (\(_, attr) -> attr) - ) - let httpReq = - [fmt|http://{dat.host}:{dat.port}/transmission/rpc|] - & Http.setRequestMethod "POST" - & Http.setRequestBodyLBS (Enc.encToBytesUtf8Lazy (body <&> second fst & Enc.object)) - & (sessionId & maybe id (Http.setRequestHeader "X-Transmission-Session-Id" . (: []))) - resp <- Http.httpBS httpReq - -- Implement the CSRF protection thingy - case resp & Http.getResponseStatus & (.statusCode) of - 409 -> do - tid <- - resp - & Http.getResponseHeader "X-Transmission-Session-Id" - & nonEmpty - & annotate [fmt|Missing "X-Transmission-Session-Id" header in 409 response: {showPretty resp}|] - & unwrapIOError - & liftIO - <&> NonEmpty.head - setTransmissionId tid - doTransmissionRequest span dat (req, parser) - 200 -> - resp - & Http.getResponseBody - & Json.parseStrict - ( Json.mapError singleError $ do - result <- - Json.key "result" Json.asText <&> \case - "success" -> TransmissionResponseSuccess - err -> TransmissionResponseFailure err - arguments <- - Json.keyMay "arguments" parser - tag <- - Json.keyMay - "tag" - (Field.toJsonParser (Field.jsonNumber >>> Field.boundedScientificIntegral "tag too long")) - pure TransmissionResponse {..} - ) - & first (Json.parseErrorTree "Cannot parse transmission RPC response") - & \case - Right a -> pure a - Left err -> 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}|] - -redactedSearch :: - (MonadLogger m, MonadThrow m, MonadOtel m) => - [(ByteString, ByteString)] -> - Json.Parse ErrorTree a -> - m a -redactedSearch advanced parser = - inSpan "Redacted API Search" $ - redactedApiRequestJson - ( T2 - (label @"action" "browse") - (label @"actionArgs" ((advanced <&> second Just))) - ) - parser - -redactedGetTorrentFile :: - ( MonadLogger m, - MonadThrow m, - HasField "torrentId" dat Int, - MonadOtel m - ) => - dat -> - m ByteString -redactedGetTorrentFile dat = inSpan' "Redacted Get Torrent File" $ \span -> do - req <- - mkRedactedApiRequest - ( T2 - (label @"action" "download") - ( label @"actionArgs" - [ ("id", Just (dat.torrentId & showToText @Int & textToBytesUtf8)) - -- try using tokens as long as we have them (TODO: what if there’s no tokens left? - -- ANSWER: it breaks: - -- responseBody = "{\"status\":\"failure\",\"error\":\"You do not have any freeleech tokens left. Please use the regular DL link.\"}", - -- ("usetoken", Just "1") - ] - ) - ) - httpTorrent span req - --- fix --- ( \io -> do --- logInfo "delay" --- liftIO $ threadDelay 10_000_000 --- io --- ) - -exampleSearch :: (MonadThrow m, MonadLogger m, MonadPostgres m, MonadOtel m) => m (Transaction m ()) -exampleSearch = do - t1 <- - redactedSearchAndInsert - [ ("searchstr", "cherish"), - ("artistname", "kirinji"), - -- ("year", "1982"), - -- ("format", "MP3"), - -- ("releasetype", "album"), - ("order_by", "year") - ] - t3 <- - redactedSearchAndInsert - [ ("searchstr", "mouss et hakim"), - ("artistname", "mouss et hakim"), - -- ("year", "1982"), - -- ("format", "MP3"), - -- ("releasetype", "album"), - ("order_by", "year") - ] - t2 <- - redactedSearchAndInsert - [ ("searchstr", "thriller"), - ("artistname", "michael jackson"), - -- ("year", "1982"), - -- ("format", "MP3"), - -- ("releasetype", "album"), - ("order_by", "year") - ] - pure (t1 >> t2 >> t3) - --- | Do the search, return a transaction that inserts all results from all pages of the search. -redactedSearchAndInsert :: - forall m. - ( MonadLogger m, - MonadPostgres m, - MonadThrow m, - MonadOtel m - ) => - [(ByteString, ByteString)] -> - m (Transaction m ()) -redactedSearchAndInsert extraArguments = do - logInfo [fmt|Doing redacted search with arguments: {showPretty extraArguments}|] - -- The first search returns the amount of pages, so we use that to query all results piece by piece. - firstPage <- go Nothing - let remainingPages = firstPage.pages - 1 - logInfo [fmt|Got the first page, found {remainingPages} more pages|] - let otherPagesNum = [(2 :: Natural) .. remainingPages] - otherPages <- traverse go (Just <$> otherPagesNum) - pure $ - (firstPage : otherPages) - & concatMap (.tourGroups) - & \case - IsNonEmpty tgs -> tgs & insertTourGroupsAndTorrents - IsEmpty -> pure () - where - go mpage = - redactedSearch - ( extraArguments - -- pass the page (for every search but the first one) - <> ifExists (mpage <&> (\page -> [("page", (page :: Natural) & showToText & textToBytesUtf8)])) - ) - ( do - status <- Json.key "status" Json.asText - when (status /= "success") $ do - Json.throwCustomError [fmt|Status was not "success", but {status}|] - Json.key "response" $ do - pages <- - Json.keyMay "pages" (Field.toJsonParser (Field.mapError singleError $ Field.jsonNumber >>> Field.boundedScientificIntegral @Int "not an Integer" >>> Field.integralToNatural)) - -- in case the field is missing, let’s assume there is only one page - <&> fromMaybe 1 - Json.key "results" $ do - tourGroups <- - label @"tourGroups" - <$> ( Json.eachInArray $ do - groupId <- Json.keyLabel @"groupId" "groupId" (Json.asIntegral @_ @Int) - groupName <- Json.keyLabel @"groupName" "groupName" Json.asText - fullJsonResult <- - label @"fullJsonResult" - <$> ( Json.asObject - -- remove torrents cause they are inserted separately below - <&> KeyMap.filterWithKey (\k _ -> k /= "torrents") - <&> Json.Object - ) - let tourGroup = T3 groupId groupName fullJsonResult - torrents <- Json.keyLabel @"torrents" "torrents" $ - Json.eachInArray $ do - torrentId <- Json.keyLabel @"torrentId" "torrentId" (Json.asIntegral @_ @Int) - fullJsonResultT <- label @"fullJsonResult" <$> Json.asValue - pure $ T2 torrentId fullJsonResultT - pure (T2 (label @"tourGroup" tourGroup) torrents) - ) - pure - ( T2 - (label @"pages" pages) - tourGroups - ) - ) - insertTourGroupsAndTorrents :: - NonEmpty - ( T2 - "tourGroup" - (T3 "groupId" Int "groupName" Text "fullJsonResult" Json.Value) - "torrents" - [T2 "torrentId" Int "fullJsonResult" Json.Value] - ) -> - Transaction m () - insertTourGroupsAndTorrents dat = do - let tourGroups = dat <&> (.tourGroup) - let torrents = dat <&> (.torrents) - insertTourGroups tourGroups - >>= ( \res -> - insertTorrents $ - zipT2 $ - T2 - (label @"torrentGroupIdPg" $ res <&> (.tourGroupIdPg)) - (label @"torrents" (torrents & toList)) - ) - insertTourGroups :: - NonEmpty - ( T3 - "groupId" - Int - "groupName" - Text - "fullJsonResult" - Json.Value - ) -> - Transaction m [Label "tourGroupIdPg" Int] - insertTourGroups dats = do - let groupNames = - dats <&> \dat -> [fmt|{dat.groupId}: {dat.groupName}|] - logInfo [fmt|Inserting tour groups for {showPretty groupNames}|] - _ <- - execute - [fmt| - DELETE FROM redacted.torrent_groups - WHERE group_id = ANY (?::integer[]) - |] - (Only $ (dats <&> (.groupId) & toList & PGArray :: PGArray Int)) - executeManyReturningWith - [fmt| - INSERT INTO redacted.torrent_groups ( - group_id, group_name, full_json_result - ) VALUES - ( ?, ? , ? ) - ON CONFLICT (group_id) DO UPDATE SET - group_id = excluded.group_id, - group_name = excluded.group_name, - full_json_result = excluded.full_json_result - RETURNING (id) - |] - ( dats <&> \dat -> - ( dat.groupId, - dat.groupName, - dat.fullJsonResult - ) - ) - (label @"tourGroupIdPg" <$> Dec.fromField @Int) - - insertTorrents :: - [ T2 - "torrentGroupIdPg" - Int - "torrents" - [T2 "torrentId" Int "fullJsonResult" Json.Value] - ] -> - Transaction m () - insertTorrents dats = do - _ <- - execute - [sql| - DELETE FROM redacted.torrents_json - WHERE torrent_id = ANY (?::integer[]) - |] - ( Only $ - PGArray - [ torrent.torrentId - | dat <- dats, - torrent <- dat.torrents - ] - ) - - execute - [sql| - INSERT INTO redacted.torrents_json - ( torrent_group - , torrent_id - , full_json_result) - SELECT * - FROM UNNEST( - ?::integer[] - , ?::integer[] - , ?::jsonb[] - ) AS inputs( - torrent_group - , torrent_id - , full_json_result) - |] - ( [ ( dat.torrentGroupIdPg :: Int, - group.torrentId :: Int, - group.fullJsonResult :: Json.Value - ) - | dat <- dats, - group <- dat.torrents - ] - & unzip3PGArray - ) - 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 - ) => - r -> - Transaction m (Label "torrentFile" ByteString) -redactedGetTorrentFileAndInsert dat = inSpan' "Redacted Get Torrent File and Insert" $ \span -> do - bytes <- redactedGetTorrentFile dat - execute - [sql| - UPDATE redacted.torrents_json - SET torrent_file = ?::bytea - WHERE torrent_id = ?::integer - |] - ( (Binary bytes :: Binary ByteString), - dat.torrentId - ) - >>= assertOneUpdated span "redactedGetTorrentFileAndInsert" - >>= \() -> pure (label @"torrentFile" bytes) - -getTorrentFileById :: - ( MonadPostgres m, - HasField "torrentId" r Int, - MonadThrow m - ) => - r -> - Transaction m (Maybe (Label "torrentFile" ByteString)) -getTorrentFileById dat = do - queryWith - [sql| - SELECT torrent_file - FROM redacted.torrents - WHERE torrent_id = ?::integer - |] - (Only $ (dat.torrentId :: Int)) - (fmap @Maybe (label @"torrentFile") <$> Dec.byteaMay) - >>= ensureSingleRow - -updateTransmissionTorrentHashById :: - ( MonadPostgres m, - HasField "torrentId" r Int, - HasField "torrentHash" r Text - ) => - r -> - Transaction m (Label "numberOfRowsAffected" Natural) -updateTransmissionTorrentHashById dat = do - execute - [sql| - UPDATE redacted.torrents_json - SET transmission_torrent_hash = ?::text - WHERE torrent_id = ?::integer - |] - ( dat.torrentHash :: Text, - dat.torrentId :: Int - ) - assertOneUpdated :: (HasField "numberOfRowsAffected" r Natural, MonadThrow m, MonadIO m) => Otel.Span -> @@ -1204,97 +645,6 @@ migrate = inSpan "Database Migration" $ do |] () -data TorrentData transmissionInfo = TorrentData - { groupId :: Int, - torrentId :: Int, - seedingWeight :: Int, - torrentJson :: Json.Value, - torrentGroupJson :: T2 "artist" Text "groupName" Text, - torrentStatus :: TorrentStatus transmissionInfo - } - -data TorrentStatus transmissionInfo - = NoTorrentFileYet - | NotInTransmissionYet - | InTransmission (T2 "torrentHash" Text "transmissionInfo" transmissionInfo) - -getTorrentById :: (MonadPostgres m, HasField "torrentId" r Int, MonadThrow m) => r -> Transaction m Json.Value -getTorrentById dat = do - queryWith - [sql| - SELECT full_json_result FROM redacted.torrents - WHERE torrent_id = ?::integer - |] - (getLabel @"torrentId" dat) - (Dec.json Json.asValue) - >>= ensureSingleRow - --- | Find the best torrent for each torrent group (based on the seeding_weight) -getBestTorrents :: (MonadPostgres m) => Transaction m [TorrentData ()] -getBestTorrents = 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, - 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 _ - ORDER BY seeding_weight DESC - |] - () - ( 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 - pure $ T2 artist groupName - ) - hasTorrentFile <- Dec.fromField @Bool - transmissionTorrentHash <- - Dec.fromField @(Maybe Text) - pure $ - TorrentData - { torrentStatus = - if - | not hasTorrentFile -> NoTorrentFileYet - | Nothing <- transmissionTorrentHash -> NotInTransmissionYet - | Just hash <- transmissionTorrentHash -> - InTransmission $ - T2 (label @"torrentHash" hash) (label @"transmissionInfo" ()), - .. - } - ) - --- | 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)] - ) => - p -> - m Http.Request -mkRedactedApiRequest dat = do - authKey <- runCommandExpect0 "pass" ["internet/redacted/api-keys/whatcd-resolver"] - pure $ - [fmt|https://redacted.ch/ajax.php|] - & Http.setRequestMethod "GET" - & Http.setQueryString (("action", Just dat.action) : dat.actionArgs) - & Http.setRequestHeader "Authorization" [authKey] - httpGetJsonLd :: (MonadThrow m, MonadOtel m) => (URI, Http.Request) -> m Jsonld httpGetJsonLd (uri, req) = inSpan' "Fetch json+ld" $ \span -> do addAttribute span "json+ld.targetUrl" (uri & showToText) @@ -1338,75 +688,6 @@ httpTorrent span req = | code <- statusCode -> Left [fmt|Redacted returned an non-200 error code, code {code}: {resp & showPretty}|] ) -newtype Optional a = OptionalInternal (Maybe a) - -mkOptional :: a -> Optional a -mkOptional defaultValue = OptionalInternal $ Just defaultValue - -defaults :: Optional a -defaults = OptionalInternal Nothing - -instance HasField "withDefault" (Optional a) (a -> a) where - getField (OptionalInternal m) defaultValue = case m of - Nothing -> defaultValue - Just a -> a - -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") - ) - -redactedApiRequestJson :: - ( MonadThrow m, - MonadLogger m, - HasField "action" p ByteString, - HasField "actionArgs" p [(ByteString, Maybe ByteString)], - MonadOtel m - ) => - p -> - Json.Parse ErrorTree a -> - m a -redactedApiRequestJson dat parser = - do - mkRedactedApiRequest dat - >>= httpJson defaults parser - runAppWith :: AppT IO a -> IO (Either TmpPg.StartError a) runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do pgFormat <- readTools (label @"toolsEnvVar" "WHATCD_RESOLVER_TOOLS") (readTool "pg_format") @@ -1466,13 +747,3 @@ withDb act = do -- print [fmt|data dir: {db & TmpPg.toDataDirectory}|] -- print [fmt|conn string: {db & TmpPg.toConnectionString}|] act db - -class MonadTransmission m where - getTransmissionId :: m (Maybe ByteString) - setTransmissionId :: ByteString -> m () - -instance (MonadIO m) => MonadTransmission (AppT m) where - getTransmissionId = AppT (asks (.transmissionSessionId)) >>= tryTakeMVar - setTransmissionId t = do - var <- AppT $ asks (.transmissionSessionId) - putMVar var t |