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
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
|
{-# 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 (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
{ pgConfig ::
T2
"logDatabaseQueries"
DebugLogDatabaseQueries
"prettyPrintDatabaseQueries"
PrettyPrintDatabaseQueries,
pgConnPool :: (Pool Postgres.Connection),
tracer :: Otel.Tracer,
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
= AppExceptionTree ErrorTree
| AppExceptionPretty [Pretty.Err]
deriving anyclass (Exception)
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)
instance (Monad m) => Otel.MonadTracer (AppT m) where
getTracer = AppT $ asks (.tracer)
class (MonadUnliftIO m, Otel.MonadTracer m) => MonadOtel m
instance (MonadUnliftIO m) => MonadOtel (AppT m)
instance (MonadOtel m) => MonadOtel (Transaction m)
inSpan :: (MonadOtel m) => Text -> m a -> m a
inSpan name = Otel.inSpan name Otel.defaultSpanArguments
inSpan' :: (MonadOtel m) => Text -> (Otel.Span -> m a) -> m a
inSpan' name = Otel.inSpan' name Otel.defaultSpanArguments
-- | Add the attribute to the span, prefixing it with the `_` namespace (to easier distinguish our application’s tags from standard tags)
addAttribute :: (MonadIO m, Otel.ToAttribute a) => Otel.Span -> Text -> a -> m ()
addAttribute span key a = Otel.addAttribute span ("_." <> key) a
-- | Add the attributes to the span, prefixing each key with the `_` namespace (to easier distinguish our application’s tags from standard tags)
addAttributes :: (MonadIO m) => Otel.Span -> HashMap Text Otel.Attribute -> m ()
addAttributes span attrs = Otel.addAttributes span $ attrs & HashMap.mapKeys ("_." <>)
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 $ 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 $ exc
orAppThrow :: (MonadThrow m, MonadIO m) => Otel.Span -> Either AppException a -> m a
orAppThrow span = \case
Left err -> appThrow span err
Right a -> pure 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 -> appThrow span err
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 -> appThrowNewSpan spanName 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 $ Prelude.map stringToText callStack)
],
..
}
-- * Postgres
instance (MonadThrow m, MonadUnliftIO m) => MonadPostgres (AppT m) where
execute = executeImpl dbConfig
executeMany = executeManyImpl dbConfig
executeManyReturningWith = executeManyReturningWithImpl dbConfig
queryWith = queryWithImpl dbConfig
queryWith_ = queryWithImpl_ (dbConfig <&> snd)
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)
withRunInIO $ \unliftIO ->
withPGTransaction pool $ \conn -> do
unliftIO $ runReaderT transaction conn
|
