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

users/Profpatsch/my-prelude/src/Pretty.hs

@@ -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

users/Profpatsch/openlab-tools/src/OpenlabTools.hs

@@ -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

users/Profpatsch/whatcd-resolver/src/AppT.hs

@@ -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
+instance IsString AppException where
-  showsPrec _ (AppException t) = ("AppException: " ++) . (textToString t ++)
+  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
+appThrowNewSpan :: (MonadThrow m, MonadOtel m) => Text -> AppException -> m a
-appThrowTreeNewSpan spanName exc = inSpan' spanName $ \span -> do
+appThrowNewSpan spanName exc = inSpan' spanName $ \span -> do
-  let msg = prettyErrorTree exc
+  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
+appThrow :: (MonadThrow m, MonadIO m) => Otel.Span -> AppException -> m a
-appThrowTree span exc = do
+appThrow span exc = do
-  let msg = prettyErrorTree exc
+  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
+orAppThrow :: (MonadThrow m, MonadIO m) => Otel.Span -> Either AppException a -> m a
-orAppThrowTree span = \case
+orAppThrow span = \case
-  Left err -> appThrowTree span err
+  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

users/Profpatsch/whatcd-resolver/src/Http.hs

@@ -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 ::

users/Profpatsch/whatcd-resolver/src/Redacted.hs

@@ -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 ::

users/Profpatsch/whatcd-resolver/src/Transmission.hs

@@ -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
+            appThrow span (AppExceptionTree err)
-    _ -> liftIO $ unwrapIOError $ Left [fmt|Non-200 response: {showPretty resp}|]
+    _ -> appThrow span $ AppExceptionPretty [[fmt|Non-200 response:|], pretty resp]
 
 class MonadTransmission m where
   getCurrentTransmissionSessionId :: m (Maybe ByteString)

users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs

@@ -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
+            Left (AppExceptionTree err) -> do
-              runInIO (logError err)
+              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