fix(users/Profpatsch/whatcd-resolver): pretty AppException

AppException would be a console-pretty-printed version for http
errors, which would print all the escape codes in the jaeger traces of
the exception, making it more-or-less unreadable.

So instead, let’s make AppException two cases, an ErrorTree case which
is printed as-is (no color), and a “Pretty” case which is printed
using the pretty module (colors on console, no colors in otel).

Somewhat involved, I guess this is temporary until I figure out what
is really needed.

Change-Id: Iff4a8651c5f5368a5b798541efc19cc7ab9de34b
Reviewed-on: https://cl.tvl.fyi/c/depot/+/12232
Reviewed-by: Profpatsch <mail@profpatsch.de>
Tested-by: BuildkiteCI
This commit is contained in:
Profpatsch 2024-08-18 17:30:29 +02:00
parent e9f1bb9917
commit b800bf2bd4
7 changed files with 84 additions and 70 deletions

View file

@ -8,6 +8,7 @@ module Pretty
printShowedStringPretty,
-- constructors hidden
prettyErrs,
prettyErrsNoColor,
message,
messageString,
pretty,
@ -19,6 +20,7 @@ where
import Data.Aeson qualified as Json
import Data.Aeson.Encode.Pretty qualified as Aeson.Pretty
import Data.List qualified as List
import Data.String (IsString (fromString))
import Data.Text.Lazy.Builder qualified as Text.Builder
import Language.Haskell.HsColour
( Output (TTYg),
@ -62,7 +64,6 @@ showPrettyJson val =
& toStrict
-- | Display a list of 'Err's as a colored error message
-- and abort the test.
prettyErrs :: [Err] -> String
prettyErrs errs = res
where
@ -74,6 +75,15 @@ prettyErrs errs = res
prettyShowString :: String -> String
prettyShowString = hscolour' . nicify
-- | Display a list of 'Err's as a plain-colored error message
prettyErrsNoColor :: [Err] -> String
prettyErrsNoColor errs = res
where
res = List.intercalate "\n" $ map one errs
one = \case
ErrMsg s -> s
ErrPrettyString s -> nicify s
-- | Small DSL for pretty-printing errors
data Err
= -- | Message to display in the error
@ -81,6 +91,9 @@ data Err
| -- | Pretty print a String that was produced by 'show'
ErrPrettyString String
instance IsString Err where
fromString s = ErrMsg s
-- | Plain message to display, as 'Text'
message :: Text -> Err
message = ErrMsg . textToString

View file

@ -389,7 +389,7 @@ httpJson opts span parser req = do
| 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}|]
| code <- statusCode -> Left $ singleError [fmt|Server returned an non-200 error code, code {code}: {[pretty resp] & prettyErrsNoColor}|]
)
>>= assertM
span

View file

@ -9,8 +9,11 @@ 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
@ -20,6 +23,7 @@ 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)
@ -40,13 +44,17 @@ data Context = Context
newtype AppT m a = AppT {unAppT :: ReaderT Context m a}
deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadThrow)
newtype AppException = AppException Text
data AppException
= AppExceptionTree ErrorTree
| AppExceptionPretty [Pretty.Err]
deriving anyclass (Exception)
instance Show AppException where
showsPrec _ (AppException t) = ("AppException: " ++) . (textToString t ++)
instance IsString AppException where
fromString s = AppExceptionTree (fromString s)
-- * Logging & Opentelemetry
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)
@ -88,47 +96,58 @@ addEventSimple span name =
jsonAttribute :: Enc -> Otel.Attribute
jsonAttribute e = e & Enc.encToTextPretty & Otel.toAttribute
orThrowAppErrorNewSpan :: (MonadThrow m, MonadOtel m) => Text -> Either ErrorTree a -> m a
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 -> appThrowTreeNewSpan msg err
Left err -> appThrowNewSpan 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
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

View file

@ -91,13 +91,13 @@ httpJson opts parser req = inSpan' "HTTP Request (JSON)" $ \span -> do
| 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}|]
| code <- statusCode -> Left $ AppExceptionPretty [[fmt|Server returned an non-200 error code, code {code}:|], pretty resp]
)
>>= assertM
span
( \body ->
Json.parseStrict parser body
& first (Json.parseErrorTree "could not parse redacted response")
& first (AppExceptionTree . Json.parseErrorTree "could not parse HTTP response")
)
doRequestJson ::

View file

@ -357,7 +357,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)|])
data TorrentData transmissionInfo = TorrentData
{ groupId :: Int,
@ -513,7 +513,7 @@ httpTorrent span req =
| 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}|]
| code <- statusCode -> Left $ AppExceptionPretty [[fmt|Redacted returned an non-200 error code, code {code}|], pretty resp]
)
redactedApiRequestJson ::

View file

@ -205,9 +205,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.
@ -305,8 +305,8 @@ 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
getCurrentTransmissionSessionId :: m (Maybe ByteString)

View file

@ -1,3 +1,4 @@
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE QuasiQuotes #-}
module WhatcdResolver where
@ -41,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
@ -91,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
@ -111,7 +114,7 @@ htmlUi = do
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 =
@ -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 $
@ -689,7 +692,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,
@ -784,38 +787,6 @@ migrate = inSpan "Database Migration" $ do
|]
()
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")
@ -848,6 +819,17 @@ runAppWith appT = withTracer $ \tracer -> withDb $ \db -> do
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