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:
parent
e9f1bb9917
commit
b800bf2bd4
7 changed files with 84 additions and 70 deletions
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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
|
||||
|
|
|
@ -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 ::
|
||||
|
|
|
@ -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 ::
|
||||
|
|
|
@ -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)
|
||||
|
|
|
@ -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
|
||||
|
|
Loading…
Reference in a new issue