diff options
Diffstat (limited to 'users')
| -rw-r--r-- | users/Profpatsch/my-prelude/src/Pretty.hs | 15 | ||||
| -rw-r--r-- | users/Profpatsch/openlab-tools/src/OpenlabTools.hs | 2 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/AppT.hs | 61 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Http.hs | 4 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Redacted.hs | 4 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/Transmission.hs | 8 | ||||
| -rw-r--r-- | users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs | 60 |
7 files changed, 84 insertions, 70 deletions
diff --git a/users/Profpatsch/my-prelude/src/Pretty.hs b/users/Profpatsch/my-prelude/src/Pretty.hs index d9d4ce132b11..6711ea951a48 100644 --- a/users/Profpatsch/my-prelude/src/Pretty.hs +++ b/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 diff --git a/users/Profpatsch/openlab-tools/src/OpenlabTools.hs b/users/Profpatsch/openlab-tools/src/OpenlabTools.hs index 16f1b626ac10..7ba52c30229d 100644 --- a/users/Profpatsch/openlab-tools/src/OpenlabTools.hs +++ b/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 diff --git a/users/Profpatsch/whatcd-resolver/src/AppT.hs b/users/Profpatsch/whatcd-resolver/src/AppT.hs index 6a8637bb1660..8550d4aa713e 100644 --- a/users/Profpatsch/whatcd-resolver/src/AppT.hs +++ b/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 - 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 diff --git a/users/Profpatsch/whatcd-resolver/src/Http.hs b/users/Profpatsch/whatcd-resolver/src/Http.hs index f0f635e7d837..14ce191d520e 100644 --- a/users/Profpatsch/whatcd-resolver/src/Http.hs +++ b/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 :: diff --git a/users/Profpatsch/whatcd-resolver/src/Redacted.hs b/users/Profpatsch/whatcd-resolver/src/Redacted.hs index 5b6751346b18..cb9d87a279e2 100644 --- a/users/Profpatsch/whatcd-resolver/src/Redacted.hs +++ b/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 :: diff --git a/users/Profpatsch/whatcd-resolver/src/Transmission.hs b/users/Profpatsch/whatcd-resolver/src/Transmission.hs index acbab001621c..b36c14d74378 100644 --- a/users/Profpatsch/whatcd-resolver/src/Transmission.hs +++ b/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 - _ -> 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) diff --git a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs b/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs index cfca79f04fbb..a2743a872962 100644 --- a/users/Profpatsch/whatcd-resolver/src/WhatcdResolver.hs +++ b/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 - 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 |