github/semantic
1
1
Fork 0
mirror of https://github.com/github/semantic.git synced 2024-11-24 08:54:07 +03:00
Code Issues Projects Releases Wiki Activity

Custom logging and statting for http server

Browse Source
This commit is contained in:
Timothy Clem 2018-06-06 15:09:25 -07:00
parent 3b21774413
commit 985ac4ade9
1 changed files with 18 additions and 0 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

18
src/Semantic/Task.hs
View File

@ -38,6 +38,7 @@ module Semantic.Task
-- * Interpreting
, runTask
, runTaskWithOptions
, runTaskWithOptions'
-- * Re-exports
, Distribute
, Eff
@ -153,6 +154,23 @@ runTaskWithOptions options task = do
closeQueue logger
either (die . displayException) pure result
runTaskWithOptions' :: Options -> AsyncQueue Message Options -> AsyncQueue Stat StatsClient -> TaskEff a -> IO a
runTaskWithOptions' options logger statter task = do
(result, stat) <- withTiming "run" [] $ do
let run :: TaskEff a -> IO (Either SomeException a)
run = runM . runError
. runTelemetry logger statter
. runTraceInTelemetry
. runReader options
. IO.runFiles
. runResolution
. runTaskF
. runDistribute (run . unwrapTask)
run task
queue statter stat
either (die . displayException) pure result
runTraceInTelemetry :: Member Telemetry effects => Eff (Trace ': effects) a -> Eff effects a
runTraceInTelemetry = interpret (\ (Trace str) -> writeLog Debug str [])