1 files changed, 86 insertions, 29 deletions
diff --git a/users/Profpatsch/whatcd-resolver/src/AppT.hs b/users/Profpatsch/whatcd-resolver/src/AppT.hs
index abe8ccad4cd3..8550d4aa713e 100644
--- a/users/Profpatsch/whatcd-resolver/src/AppT.hs
+++ b/users/Profpatsch/whatcd-resolver/src/AppT.hs
@@ -9,35 +9,52 @@ 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
 import Label
 import OpenTelemetry.Trace qualified as Otel hiding (getTracer, inSpan, inSpan')
 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)
 
 data Context = Context
-  { config :: Label "logDatabaseQueries" DebugLogDatabaseQueries,
+  { pgConfig ::
+      T2
+        "logDatabaseQueries"
+        DebugLogDatabaseQueries
+        "prettyPrintDatabaseQueries"
+        PrettyPrintDatabaseQueries,
+    pgConnPool :: (Pool Postgres.Connection),
     tracer :: Otel.Tracer,
-    pgFormat :: PgFormatPool,
-    pgConnPool :: Pool Postgres.Connection,
-    transmissionSessionId :: MVar ByteString
+    transmissionSessionId :: IORef (Maybe ByteString),
+    redactedApiKey :: ByteString
   }
 
 newtype AppT m a = AppT {unAppT :: ReaderT Context m a}
   deriving newtype (Functor, Applicative, Monad, MonadIO, MonadUnliftIO, MonadThrow)
 
-data AppException = AppException Text
-  deriving stock (Show)
+data AppException
+  = AppExceptionTree ErrorTree
+  | AppExceptionPretty [Pretty.Err]
   deriving anyclass (Exception)
 
--- *  Logging & Opentelemetry
+instance IsString AppException where
+  fromString s = AppExceptionTree (fromString s)
+
+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)
@@ -65,42 +82,72 @@ addAttribute span key a = Otel.addAttribute span ("_." <> key) a
 addAttributes :: (MonadIO m) => Otel.Span -> HashMap Text Otel.Attribute -> m ()
 addAttributes span attrs = Otel.addAttributes span $ attrs & HashMap.mapKeys ("_." <>)
 
-appThrowTreeNewSpan :: (MonadThrow m, MonadOtel m) => Text -> ErrorTree -> m a
-appThrowTreeNewSpan spanName exc = inSpan' spanName $ \span -> do
-  let msg = prettyErrorTree exc
+addEventSimple :: (MonadIO m) => Otel.Span -> Text -> m ()
+addEventSimple span name =
+  Otel.addEvent
+    span
+    Otel.NewEvent
+      { Otel.newEventName = name,
+        Otel.newEventTimestamp = Nothing,
+        Otel.newEventAttributes = mempty
+      }
+
+-- | Create an otel attribute from a json encoder
+jsonAttribute :: Enc -> Otel.Attribute
+jsonAttribute e = e & Enc.encToTextPretty & Otel.toAttribute
+
+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 -> appThrowNewSpan msg err
+  Right a -> pure a
+
+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
@@ -125,7 +172,7 @@ recordException span dat = liftIO $ do
           HashMap.fromList
             [ ("exception.type", Otel.toAttribute @Text dat.type_),
               ("exception.message", Otel.toAttribute @Text dat.message),
-              ("exception.stacktrace", Otel.toAttribute @Text $ Text.unlines $ map stringToText callStack)
+              ("exception.stacktrace", Otel.toAttribute @Text $ Text.unlines $ Prelude.map stringToText callStack)
             ],
         ..
       }
@@ -133,15 +180,25 @@ recordException span dat = liftIO $ do
 -- * Postgres
 
 instance (MonadThrow m, MonadUnliftIO m) => MonadPostgres (AppT m) where
-  execute = executeImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
-  executeMany = executeManyImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
-  executeManyReturningWith = executeManyReturningWithImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
-  queryWith = queryWithImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
-  queryWith_ = queryWithImpl_ (AppT ask)
+  execute = executeImpl dbConfig
+  executeMany = executeManyImpl dbConfig
+  executeManyReturningWith = executeManyReturningWithImpl dbConfig
+  queryWith = queryWithImpl dbConfig
+  queryWith_ = queryWithImpl_ (dbConfig <&> snd)
 
-  foldRowsWithAcc = foldRowsWithAccImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
+  foldRowsWithAcc = foldRowsWithAccImpl dbConfig
   runTransaction = runPGTransaction
 
+dbConfig :: (Monad m) => AppT m (DebugLogDatabaseQueries, PrettyPrintDatabaseQueries)
+dbConfig =
+  AppT $
+    asks
+      ( \c ->
+          ( c.pgConfig.logDatabaseQueries,
+            c.pgConfig.prettyPrintDatabaseQueries
+          )
+      )
+
 runPGTransaction :: (MonadUnliftIO m) => Transaction (AppT m) a -> AppT m a
 runPGTransaction (Transaction transaction) = do
   pool <- AppT ask <&> (.pgConnPool)