1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
|
{-# LANGUAGE DeriveAnyClass #-}
module AppT where
import Control.Monad.Logger qualified as Logger
import Control.Monad.Logger.CallStack
import Control.Monad.Reader
import Data.Error.Tree
import Data.HashMap.Strict qualified as HashMap
import Data.Pool (Pool)
import Data.Text qualified as Text
import Database.PostgreSQL.Simple qualified as Postgres
import GHC.Stack qualified
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 System.IO qualified as IO
import Tool (Tool)
import UnliftIO
import Prelude hiding (span)
data Context = Context
{ config :: Label "logDatabaseQueries" DebugLogDatabaseQueries,
tracer :: Otel.Tracer,
pgFormat :: Tool,
pgConnPool :: Pool Postgres.Connection,
transmissionSessionId :: MVar 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)
deriving anyclass (Exception)
-- * Logging & Opentelemetry
instance (MonadIO m) => MonadLogger (AppT m) where
monadLoggerLog loc src lvl msg = liftIO $ Logger.defaultOutput IO.stderr loc src lvl (Logger.toLogStr msg)
instance (Monad m) => Otel.MonadTracer (AppT m) where
getTracer = AppT $ asks (.tracer)
inSpan :: (MonadUnliftIO m, Otel.MonadTracer m) => Text -> m a -> m a
inSpan name = Otel.inSpan name Otel.defaultSpanArguments
inSpan' :: (MonadUnliftIO m, Otel.MonadTracer m) => Text -> (Otel.Span -> m a) -> m a
inSpan' name = Otel.inSpan' name Otel.defaultSpanArguments
appThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> ErrorTree -> m a
appThrowTree span exc = do
let msg = prettyErrorTree exc
recordException
span
( T2
(label @"type_" "AppException")
(label @"message" msg)
)
throwM $ AppException msg
orAppThrowTree :: (MonadThrow m, MonadIO m) => Otel.Span -> Either ErrorTree a -> m a
orAppThrowTree span = \case
Left err -> appThrowTree span err
Right a -> pure a
assertM :: (MonadThrow f, MonadIO f) => Otel.Span -> (t -> Either ErrorTree a) -> t -> f a
assertM span f v = case f v of
Right a -> pure a
Left err -> appThrowTree span err
-- | A specialized variant of @addEvent@ that records attributes conforming to
-- the OpenTelemetry specification's
-- <https://github.com/open-telemetry/opentelemetry-specification/blob/49c2f56f3c0468ceb2b69518bcadadd96e0a5a8b/specification/trace/semantic_conventions/exceptions.md semantic conventions>
--
-- @since 0.0.1.0
recordException ::
( MonadIO m,
HasField "message" r Text,
HasField "type_" r Text
) =>
Otel.Span ->
r ->
m ()
recordException span dat = liftIO $ do
callStack <- GHC.Stack.whoCreated dat.message
newEventTimestamp <- Just <$> Otel.getTimestamp
Otel.addEvent span $
Otel.NewEvent
{ newEventName = "exception",
newEventAttributes =
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)
],
..
}
-- * Postgres
instance (MonadThrow m, MonadUnliftIO m) => MonadPostgres (AppT m) where
execute = executeImpl (AppT ask) (AppT $ asks (.config.logDatabaseQueries))
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)
foldRows = foldRowsImpl (AppT ask)
runTransaction = runPGTransaction
runPGTransaction :: (MonadUnliftIO m) => Transaction (AppT m) a -> AppT m a
runPGTransaction (Transaction transaction) = do
pool <- AppT ask <&> (.pgConnPool)
withRunInIO $ \unliftIO ->
withPGTransaction pool $ \conn -> do
unliftIO $ runReaderT transaction conn
|
