From 797099946317d14aa1979712a06ce080330a8580 Mon Sep 17 00:00:00 2001 From: Timothy Clem Date: Wed, 13 Jun 2018 16:42:04 -0700 Subject: [PATCH] Continue to refine config API --- src/Semantic/CLI.hs | 11 +++---- src/Semantic/Config.hs | 55 +++++++++++++++++++++++------------ src/Semantic/Task.hs | 18 ++++-------- src/Semantic/Telemetry.hs | 2 +- src/Semantic/Telemetry/Log.hs | 12 ++++---- 5 files changed, 52 insertions(+), 46 deletions(-) diff --git a/src/Semantic/CLI.hs b/src/Semantic/CLI.hs index f19f690aa..a949eb77f 100644 --- a/src/Semantic/CLI.hs +++ b/src/Semantic/CLI.hs @@ -1,5 +1,4 @@ -{-# OPTIONS_GHC -fforce-recomp #-} -- So that gitHash is correct. -{-# LANGUAGE ApplicativeDo, RankNTypes, TemplateHaskell #-} +{-# LANGUAGE ApplicativeDo, RankNTypes #-} module Semantic.CLI ( main -- Testing @@ -11,10 +10,7 @@ import Data.Language (ensureLanguage) import Data.List (intercalate) import Data.List.Split (splitWhen) import Data.Project -import Data.Version (showVersion) -import Development.GitRev import Options.Applicative hiding (style) -import qualified Paths_semantic as Library (version) import Prologue import Rendering.Renderer import qualified Semantic.AST as AST @@ -25,6 +21,7 @@ import Semantic.IO as IO import qualified Semantic.Parse as Parse import qualified Semantic.Task as Task import qualified Semantic.Telemetry.Log as Log +import Semantic.Version import Serializing.Format hiding (Options) import Text.Read @@ -38,9 +35,9 @@ arguments :: ParserInfo (Options, Task.TaskEff ()) arguments = info (version <*> helper <*> ((,) <$> optionsParser <*> argumentsParser)) description where version = infoOption versionString (long "version" <> short 'v' <> help "Output the version of the program") - versionString = "semantic version " <> showVersion Library.version <> " (" <> $(gitHash) <> ")" + versionString = "semantic version " <> buildVersion <> " (" <> buildSHA <> ")" description = fullDesc <> header "semantic -- Parse and diff semantically" - + optionsParser = do logLevel <- options [ ("error", Just Log.Error) , ("warning", Just Log.Warning) , ("info", Just Log.Info) , ("debug", Just Log.Debug) , ("none", Nothing)] (long "log-level" <> value (Just Log.Warning) <> help "Log messages at or above this level, or disable logging entirely.") diff --git a/src/Semantic/Config.hs b/src/Semantic/Config.hs index 2999849c3..c3652e7fa 100644 --- a/src/Semantic/Config.hs +++ b/src/Semantic/Config.hs @@ -1,19 +1,23 @@ +{-# OPTIONS_GHC -fforce-recomp #-} -- So that gitHash is correct. +{-# LANGUAGE TemplateHaskell #-} module Semantic.Config where -import Control.Exception -import Network.BSD -import Network.HTTP.Client.TLS -import Network.URI -import Prologue -import Semantic.Telemetry -import Semantic.Telemetry.AsyncQueue -import qualified Semantic.Telemetry.Stat as Stat +import Control.Exception +import Network.BSD +import Network.HTTP.Client.TLS +import Network.URI +import Prologue +import Semantic.Env +import Semantic.Telemetry +import Semantic.Telemetry.AsyncQueue +import qualified Semantic.Telemetry.Haystack as Haystack import qualified Semantic.Telemetry.Log as Log -import Semantic.Env -import System.Environment -import System.IO (hIsTerminalDevice, stderr) -import System.Posix.Process -import System.Posix.Types +import qualified Semantic.Telemetry.Stat as Stat +import Semantic.Version +import System.Environment +import System.IO (hIsTerminalDevice, stderr) +import System.Posix.Process +import System.Posix.Types data Config = Config @@ -65,13 +69,17 @@ defaultConfig' options@Options{..} = do , configMaxTelemetyQueueSize = size , configIsTerminal = isTerminal , configLogPrintSource = isTerminal - , configLogFormatter = logfmtFormatter + , configLogFormatter = if isTerminal then terminalFormatter else logfmtFormatter , configOptions = options } + +defaultHaystackFromConfig :: Config -> Haystack.ErrorLogger IO -> IO HaystackQueue +defaultHaystackFromConfig c@Config{..} logError = haystackClientFromConfig c >>= newAsyncQueue configMaxTelemetyQueueSize (Haystack.reportError logError) + haystackClientFromConfig :: Config -> IO HaystackClient -haystackClientFromConfig Config{..} = haystackClient configHaystackURL tlsManagerSettings configHostName configAppName +haystackClientFromConfig Config{..} = haystackClient configHaystackURL tlsManagerSettings configAppName withLogger :: Config -> (LogQueue -> IO c) -> IO c @@ -79,12 +87,21 @@ withLogger c = bracket (defaultLoggerFromConfig c) closeAsyncQueue defaultLoggerFromConfig :: Config -> IO LogQueue defaultLoggerFromConfig Config{..} = - newAsyncQueue configMaxTelemetyQueueSize Log.writeLogMessage LogOptions{ - optionsLevel = optionsLogLevel configOptions - , optionsFormatter = configLogFormatter - , optionsLogContext = [("app", configAppName), ("process_id", show configProcessID)] <> [("request_id", x) | x <- toList (optionsRequestID configOptions) ] + newAsyncQueue configMaxTelemetyQueueSize Log.writeLogMessage LogOptions { + logOptionsLevel = optionsLogLevel configOptions + , logOptionsFormatter = configLogFormatter + , logOptionsContext = + [ ("app", configAppName) + , ("pid", show configProcessID) + , ("hostname", configHostName) + , ("sha", buildSHA) + ] <> [("request_id", x) | x <- toList (optionsRequestID configOptions) ] } +withStatter :: Config -> (StatQueue -> IO c) -> IO c +withStatter c = bracket (defaultStatterFromConfig c) $ \statter -> do + closeAsyncQueue statter + Stat.closeStatClient (asyncQueueExtra statter) defaultStatterFromConfig :: Config -> IO StatQueue defaultStatterFromConfig c@Config{..} = statsClientFromConfig c >>= newAsyncQueue configMaxTelemetyQueueSize Stat.sendStat diff --git a/src/Semantic/Task.hs b/src/Semantic/Task.hs index 2628e3225..aed9c5959 100644 --- a/src/Semantic/Task.hs +++ b/src/Semantic/Task.hs @@ -73,14 +73,11 @@ import Prologue hiding (MonadError (..), project) import Semantic.Config import Semantic.Distribute import qualified Semantic.IO as IO --- import Semantic.Log --- import Semantic.Queue import Semantic.Resolution -import Semantic.Telemetry.Stat as Stat import Semantic.Telemetry +import Semantic.Telemetry.Stat as Stat import Serializing.Format hiding (Options) import System.Exit (die) -import System.IO (stderr) -- | A high-level task producing some result, e.g. parsing, diffing, rendering. 'Task's can also specify explicit concurrency via 'distribute', 'distributeFor', and 'distributeFoldMap' type TaskEff = Eff '[Distribute WrappedTask @@ -129,21 +126,16 @@ serialize format = send . Serialize format runTask :: TaskEff a -> IO a runTask = runTaskWithOptions defaultOptions --- | Execute a 'TaskEff' with the passed 'Config', yielding its result value in 'IO'. +-- | Execute a 'TaskEff' with the passed 'Options', yielding its result value in 'IO'. runTaskWithOptions :: Options -> TaskEff a -> IO a runTaskWithOptions opts task = do config <- defaultConfig' opts - statter <- defaultStatterFromConfig config - -- logger <- defaultLoggerFromConfig c - result <- withLogger config $ \logger -> - runTaskWithConfig config logger statter task - - -- closeQueue statter - -- closeStatClient (asyncQueueExtra statter) - -- closeQueue logger + withStatter config $ \statter -> + runTaskWithConfig config logger statter task either (die . displayException) pure result +-- | Execute a 'TaskEff' yielding its result value in 'IO'. runTaskWithConfig :: Config -> LogQueue -> StatQueue -> TaskEff a -> IO (Either SomeException a) runTaskWithConfig options logger statter task = do (result, stat) <- withTiming "run" [] $ do diff --git a/src/Semantic/Telemetry.hs b/src/Semantic/Telemetry.hs index 60f23a65e..4d93b8de7 100644 --- a/src/Semantic/Telemetry.hs +++ b/src/Semantic/Telemetry.hs @@ -55,7 +55,7 @@ type HaystackQueue = AsyncQueue ErrorReport HaystackClient -- | Queue a message to be logged. queueLogMessage :: MonadIO io => LogQueue -> Level -> String -> [(String, String)] -> io () queueLogMessage q@AsyncQueue{..} level message pairs - | Just logLevel <- optionsLevel asyncQueueExtra + | Just logLevel <- logOptionsLevel asyncQueueExtra , level <= logLevel = liftIO Time.getCurrentTime >>= liftIO . LocalTime.utcToLocalZonedTime >>= liftIO . writeAsyncQueue q . Message level message pairs | otherwise = pure () diff --git a/src/Semantic/Telemetry/Log.hs b/src/Semantic/Telemetry/Log.hs index 7ad10bbd8..8a116e017 100644 --- a/src/Semantic/Telemetry/Log.hs +++ b/src/Semantic/Telemetry/Log.hs @@ -27,14 +27,14 @@ data Level -- | Options for controlling logging data LogOptions = LogOptions - { optionsLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging. - , optionsFormatter :: LogFormatter -- ^ Log formatter to use. - , optionsLogContext :: [(String, String)] + { logOptionsLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging. + , logOptionsFormatter :: LogFormatter -- ^ Log formatter to use. + , logOptionsContext :: [(String, String)] } -- | Write a log a message to stderr. writeLogMessage :: MonadIO io => LogOptions -> Message -> io () -writeLogMessage options@LogOptions{..} = liftIO . hPutStr stderr . optionsFormatter options +writeLogMessage options@LogOptions{..} = liftIO . hPutStr stderr . logOptionsFormatter options -- | Format log messaging using "logfmt". -- @@ -49,7 +49,7 @@ logfmtFormatter LogOptions{..} (Message level message pairs time) = ( kv "time" (showTime time) : kv "msg" (shows message) : kv "level" (shows level) - : (uncurry kv . second shows <$> (pairs <> optionsLogContext))) + : (uncurry kv . second shows <$> (pairs <> logOptionsContext))) . showChar '\n' $ "" where kv k v = showString k . showChar '=' . v @@ -65,7 +65,7 @@ terminalFormatter LogOptions{..} (Message level message pairs time) = showChar '[' . showTime time . showString "] " . showLevel level . showChar ' ' . showString (printf "%-20s " message) - . showPairs pairs + . showPairs (pairs <> logOptionsContext) . showChar '\n' $ "" where colourize = True