1
1
mirror of https://github.com/github/semantic.git synced 2024-11-23 16:37:50 +03:00

Merge pull request #1964 from github/telemetry-and-config

Telemetry and config refactor
This commit is contained in:
Timothy Clem 2018-06-15 11:13:44 -07:00 committed by GitHub
commit 14e03fb1d0
13 changed files with 379 additions and 296 deletions

View File

@ -154,16 +154,17 @@ library
, Semantic.Distribute
, Semantic.Env
, Semantic.Graph
, Semantic.Haystack
, Semantic.IO
, Semantic.Log
, Semantic.Parse
, Semantic.Queue
, Semantic.Resolution
, Semantic.Stat
, Semantic.Task
, Semantic.Telemetry
, Semantic.Telemetry.AsyncQueue
, Semantic.Telemetry.Haystack
, Semantic.Telemetry.Log
, Semantic.Telemetry.Stat
, Semantic.Util
, Semantic.Version
-- Serialization
, Serializing.DOT
, Serializing.Format

View File

@ -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
@ -7,24 +6,23 @@ module Semantic.CLI
, Parse.runParse
) where
import Data.Project
import Data.Language (ensureLanguage)
import Data.List (intercalate)
import Data.List.Split (splitWhen)
import Data.Version (showVersion)
import Development.GitRev
import Data.Project
import Options.Applicative hiding (style)
import qualified Paths_semantic as Library (version)
import Prologue
import Rendering.Renderer
import qualified Semantic.AST as AST
import Semantic.Config
import qualified Semantic.Diff as Diff
import qualified Semantic.Graph as Graph
import Semantic.IO as IO
import qualified Semantic.Log as Log
import qualified Semantic.Parse as Parse
import qualified Semantic.Task as Task
import Serializing.Format
import qualified Semantic.Telemetry.Log as Log
import Semantic.Version
import Serializing.Format hiding (Options)
import Text.Read
main :: IO ()
@ -33,20 +31,19 @@ main = customExecParser (prefs showHelpOnEmpty) arguments >>= uncurry Task.runTa
-- | A parser for the application's command-line arguments.
--
-- Returns a 'Task' to read the input, run the requested operation, and write the output to the specified output path or stdout.
arguments :: ParserInfo (Log.Options, Task.TaskEff ())
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
disableColour <- not <$> switch (long "disable-colour" <> long "disable-color" <> help "Disable ANSI colors in log messages even if the terminal is a TTY.")
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.")
requestId <- optional (strOption $ long "request-id" <> help "A string to use as the request identifier for any logged messages." <> metavar "id")
failOnWarning <- switch (long "fail-on-warning" <> help "Fail on assignment warnings.")
pure $ Log.Options disableColour logLevel requestId False False Log.logfmtFormatter 0 failOnWarning
pure $ Options logLevel requestId failOnWarning
argumentsParser = do
subparser <- hsubparser (diffCommand <> parseCommand <> tsParseCommand <> graphCommand)

View File

@ -1,58 +1,104 @@
module Semantic.Config where
import Network.BSD
import Network.HTTP.Client.TLS
import Network.URI
import Prologue
import Semantic.Haystack
import Semantic.Log
import Semantic.Stat
import System.Environment
import System.IO (stderr)
import System.Posix.Process
import System.Posix.Types
import Network.BSD
import Network.HTTP.Client.TLS
import Network.URI
import Parsing.TreeSitter (Timeout (..))
import Prologue
import Semantic.Env
import Semantic.Telemetry
import qualified Semantic.Telemetry.Haystack as Haystack
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
{ configAppName :: String -- ^ Application name (semantic)
, configHostName :: String -- ^ HostName from getHostName
, configProcessID :: ProcessID -- ^ ProcessID from getProcessID
, configHaystackURL :: Maybe String -- ^ URL of Haystack, with creds from environment
, configStatsAddr :: StatsAddr -- ^ Address of statsd/datadog
, configLogOptions :: Options -- ^ Options pertaining to logging
{ configAppName :: String -- ^ Application name ("semantic")
, configHostName :: String -- ^ HostName from getHostName
, configProcessID :: ProcessID -- ^ ProcessID from getProcessID
, configHaystackURL :: Maybe String -- ^ URL of Haystack (with creds) from environment
, configStatsHost :: Stat.Host -- ^ Host of statsd/datadog (default: "127.0.0.1")
, configStatsPort :: Stat.Port -- ^ Port of statsd/datadog (default: "28125")
, configTreeSitterParseTimeout :: Timeout -- ^ Timeout in milliseconds before canceling tree-sitter parsing (default: 10000).
, configMaxTelemetyQueueSize :: Int -- ^ Max size of telemetry queues before messages are dropped (default: 1000).
, configIsTerminal :: Bool -- ^ Whether a terminal is attached (set automaticaly at runtime).
, configLogPrintSource :: Bool -- ^ Whether to print the source reference when logging errors (set automatically at runtime).
, configLogFormatter :: LogFormatter -- ^ Log formatter to use (set automaticaly at runtime).
, configOptions :: Options -- ^ Options configurable via command line arguments.
}
data StatsAddr = StatsAddr { addrHost :: String, addrPort :: String }
-- Options configurable via command line arguments.
data Options
= Options
{ optionsLogLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging.
, optionsRequestID :: Maybe String -- ^ Optional request id for tracing across systems.
, optionsFailOnWarning :: Bool -- ^ Should semantic fail fast on assignment warnings (for testing)
}
defaultConfig :: IO Config
defaultConfig = do
defaultOptions :: Options
defaultOptions = Options (Just Warning) Nothing False
defaultConfig :: Options -> IO Config
defaultConfig options@Options{..} = do
pid <- getProcessID
hostName <- getHostName
isTerminal <- hIsTerminalDevice stderr
haystackURL <- lookupEnv "HAYSTACK_URL"
statsAddr <- lookupStatsAddr
logOptions <- configureOptionsForHandle stderr defaultOptions
(statsHost, statsPort) <- lookupStatsAddr
size <- envLookupInt 1000 "MAX_TELEMETRY_QUEUE_SIZE"
parseTimeout <- envLookupInt 10000 "TREE_SITTER_PARSE_TIMEOUT" -- Default is 10 seconds
pure Config
{ configAppName = "semantic"
, configHostName = hostName
, configProcessID = pid
, configHaystackURL = haystackURL
, configStatsAddr = statsAddr
, configLogOptions = logOptions
, configStatsHost = statsHost
, configStatsPort = statsPort
, configTreeSitterParseTimeout = Milliseconds parseTimeout
, configMaxTelemetyQueueSize = size
, configIsTerminal = isTerminal
, configLogPrintSource = isTerminal
, configLogFormatter = if isTerminal then terminalFormatter else logfmtFormatter
, configOptions = options
}
defaultHaystackClient :: IO HaystackClient
defaultHaystackClient = defaultConfig >>= haystackClientFromConfig
withTelemetry :: Config -> (TelemetryQueues -> IO c) -> IO c
withTelemetry config action =
withLoggerFromConfig config $ \logger ->
withHaystackFromConfig config (queueLogMessage logger Error) $ \haystack ->
withStatterFromConfig config $ \statter ->
action (TelemetryQueues logger statter haystack)
haystackClientFromConfig :: Config -> IO HaystackClient
haystackClientFromConfig Config{..} = haystackClient configHaystackURL tlsManagerSettings configHostName configAppName
withLoggerFromConfig :: Config -> (LogQueue -> IO c) -> IO c
withLoggerFromConfig Config{..} = withLogger opts configMaxTelemetyQueueSize
where opts = LogOptions {
logOptionsLevel = optionsLogLevel configOptions
, logOptionsFormatter = configLogFormatter
, logOptionsContext =
[ ("app", configAppName)
, ("pid", show configProcessID)
, ("hostname", configHostName)
, ("sha", buildSHA)
] <> [("request_id", x) | x <- toList (optionsRequestID configOptions) ]
}
defaultStatsClient :: IO StatsClient
defaultStatsClient = defaultConfig >>= statsClientFromConfig
withHaystackFromConfig :: Config -> Haystack.ErrorLogger -> (HaystackQueue -> IO c) -> IO c
withHaystackFromConfig Config{..} errorLogger =
withHaystack configHaystackURL tlsManagerSettings configAppName errorLogger configMaxTelemetyQueueSize
statsClientFromConfig :: Config -> IO StatsClient
statsClientFromConfig Config{..} = statsClient (addrHost configStatsAddr) (addrPort configStatsAddr) configAppName
withStatterFromConfig :: Config -> (StatQueue -> IO c) -> IO c
withStatterFromConfig Config{..} =
withStatter configStatsHost configStatsPort configAppName configMaxTelemetyQueueSize
lookupStatsAddr :: IO StatsAddr
lookupStatsAddr :: IO (Stat.Host, Stat.Port)
lookupStatsAddr = do
addr <- lookupEnv "STATS_ADDR"
let (host', port) = parseAddr (fmap ("statsd://" <>) addr)
@ -61,7 +107,7 @@ lookupStatsAddr = do
kubesHost <- lookupEnv "DOGSTATSD_HOST"
let host = fromMaybe host' kubesHost
pure (StatsAddr host port)
pure (host, port)
where
defaultHost = "127.0.0.1"
defaultPort = "28125"

View File

@ -15,7 +15,7 @@ import Prologue hiding (MonadError(..))
import Rendering.Graph
import Rendering.Renderer
import Semantic.IO (noLanguageForBlob)
import Semantic.Stat as Stat
import Semantic.Telemetry as Stat
import Semantic.Task as Task
import Serializing.Format

View File

@ -1,117 +0,0 @@
module Semantic.Log where
import Control.Monad.IO.Class
import Data.Error (withSGRCode)
import Data.List (intersperse)
import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
import qualified Data.Time.Format as Time
import qualified Data.Time.LocalTime as LocalTime
import Prologue
import Semantic.Queue
import System.Console.ANSI
import System.IO
import System.Posix.Process
import System.Posix.Types
import Text.Printf
-- | A log message at a specific level.
data Message = Message Level String [(String, String)] LocalTime.ZonedTime
deriving (Show)
data Level
= Error
| Warning
| Info
| Debug
deriving (Eq, Ord, Show)
type LogQueue = AsyncQueue Message Options
-- | 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, level <= logLevel = liftIO Time.getCurrentTime >>= liftIO . LocalTime.utcToLocalZonedTime >>= liftIO . queue q . Message level message pairs
| otherwise = pure ()
-- | Log a message to stderr.
logMessage :: MonadIO io => Options -> Message -> io ()
logMessage options@Options{..} = liftIO . hPutStr stderr . optionsFormatter options
-- | Format log messaging using "logfmt".
--
-- Logfmt is a loosely defined logging format (see https://brandur.org/logfmt)
-- for structured data, which plays very well with indexing tools like Splunk.
--
-- Example:
-- time=2006-01-02T15:04:05Z07:00 msg="this is a message" key=val int=42 key2="val with word" float=33.33
logfmtFormatter :: Options -> Message -> String
logfmtFormatter Options{..} (Message level message pairs time) =
showPairs
( kv "time" (showTime time)
: kv "msg" (shows message)
: kv "level" (shows level)
: kv "process_id" (shows optionsProcessID)
: kv "app" (showString "semantic")
: (uncurry kv . second shows <$> pairs)
<> [ kv "request_id" (shows x) | x <- toList optionsRequestID ] )
. showChar '\n' $ ""
where
kv k v = showString k . showChar '=' . v
showPairs = foldr (.) id . intersperse (showChar ' ')
showTime = showString . Time.formatTime Time.defaultTimeLocale "%FT%XZ%z"
-- | Format log messages to a terminal. Suitable for local development.
--
-- Example:
-- [16:52:41] INFO this is a message key=val language=Ruby time=0.000098s
terminalFormatter :: Options -> Message -> String
terminalFormatter Options{..} (Message level message pairs time) =
showChar '[' . showTime time . showString "] "
. showLevel level . showChar ' '
. showString (printf "%-20s " message)
. showPairs pairs
. showChar '\n' $ ""
where
colourize = optionsIsTerminal && optionsEnableColour
showLevel Error = withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "ERROR")
showLevel Warning = withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString " WARN")
showLevel Info = withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString " INFO")
showLevel Debug = withSGRCode colourize [SetColor Foreground Vivid White, SetConsoleIntensity BoldIntensity] (showString "DEBUG")
showPairs pairs = foldr (.) id $ intersperse (showChar ' ') (showPair <$> pairs)
showPair (k, v) = showString k . showChar '=' . withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString v)
showTime = showString . Time.formatTime Time.defaultTimeLocale "%X"
-- | Options controlling logging, error handling, &c.
data Options = Options
{ optionsEnableColour :: Bool -- ^ Whether to enable colour formatting for logging (Only works when logging to a terminal that supports ANSI colors).
, optionsLevel :: Maybe Level -- ^ What level of messages to log. 'Nothing' disabled logging.
, optionsRequestID :: Maybe String -- ^ Optional request id for tracing across systems.
, optionsIsTerminal :: Bool -- ^ Whether a terminal is attached (set automaticaly at runtime).
, optionsPrintSource :: Bool -- ^ Whether to print the source reference when logging errors (set automatically at runtime).
, optionsFormatter :: Options -> Message -> String -- ^ Log formatter to use (set automaticaly at runtime).
, optionsProcessID :: CPid -- ^ ProcessID (set automaticaly at runtime).
, optionsFailOnWarning :: Bool
}
defaultOptions :: Options
defaultOptions = Options
{ optionsEnableColour = True
, optionsLevel = Just Warning
, optionsRequestID = Nothing
, optionsIsTerminal = False
, optionsPrintSource = False
, optionsFormatter = logfmtFormatter
, optionsProcessID = 0
, optionsFailOnWarning = False
}
configureOptionsForHandle :: MonadIO io => Handle -> Options -> io Options
configureOptionsForHandle handle options = liftIO $ do
pid <- getProcessID
isTerminal <- hIsTerminalDevice handle
pure $ options
{ optionsIsTerminal = isTerminal
, optionsFormatter = if isTerminal then terminalFormatter else logfmtFormatter
, optionsPrintSource = isTerminal
, optionsProcessID = pid
}

View File

@ -31,14 +31,13 @@ module Semantic.Task
, distributeFor
, distributeFoldMap
-- * Configuration
, defaultOptions
, configureOptionsForHandle
, defaultConfig
, terminalFormatter
, logfmtFormatter
-- * Interpreting
, runTask
, runTaskWithOptions
, runTaskWithOptions'
, runTaskWithConfig
-- * Re-exports
, Distribute
, Eff
@ -71,23 +70,20 @@ import Parsing.CMark
import Parsing.Parser
import Parsing.TreeSitter
import Prologue hiding (MonadError (..), project)
import Semantic.Config
import Semantic.Distribute
import qualified Semantic.IO as IO
import Semantic.Resolution
import Semantic.Log
import Semantic.Queue
import Semantic.Stat as Stat
import Semantic.Telemetry
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
, Task
, Resolution
, IO.Files
, Reader Options
, Reader Config
, Trace
, Telemetry
, Exc SomeException
@ -131,21 +127,15 @@ runTask = runTaskWithOptions defaultOptions
-- | Execute a 'TaskEff' with the passed 'Options', yielding its result value in 'IO'.
runTaskWithOptions :: Options -> TaskEff a -> IO a
runTaskWithOptions options task = do
let size = 100 -- Max size of telemetry queues, less important for the CLI.
options <- configureOptionsForHandle stderr options
statter <- defaultStatsClient >>= newQueue size sendStat
logger <- newQueue size logMessage options
result <- runTaskWithOptions' options logger statter task
closeQueue statter
closeStatClient (asyncQueueExtra statter)
closeQueue logger
runTaskWithOptions opts task = do
config <- defaultConfig opts
result <- withTelemetry config $ \(TelemetryQueues logger statter _) ->
runTaskWithConfig config logger statter task
either (die . displayException) pure result
runTaskWithOptions' :: Options -> LogQueue -> AsyncQueue Stat StatsClient -> TaskEff a -> IO (Either SomeException a)
runTaskWithOptions' options logger statter task = do
-- | 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
let run :: TaskEff a -> IO (Either SomeException a)
run = runM . runError
@ -157,7 +147,7 @@ runTaskWithOptions' options logger statter task = do
. runTaskF
. runDistribute (run . unwrapTask)
run task
queue statter stat
queueStat statter stat
pure result
runTraceInTelemetry :: Member Telemetry effects => Eff (Trace ': effects) a -> Eff effects a
@ -174,7 +164,7 @@ data Task output where
Serialize :: Format input -> input -> Task Builder
-- | Run a 'Task' effect by performing the actions in 'IO'.
runTaskF :: (Member (Exc SomeException) effs, Member IO effs, Member (Reader Options) effs, Member Telemetry effs, Member Trace effs) => Eff (Task ': effs) a -> Eff effs a
runTaskF :: (Member (Exc SomeException) effs, Member IO effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs) => Eff (Task ': effs) a -> Eff effs a
runTaskF = interpret $ \ task -> case task of
Parse parser blob -> runParser blob parser
Analyze interpret analysis -> pure (interpret analysis)
@ -182,51 +172,49 @@ runTaskF = interpret $ \ task -> case task of
Semantic.Task.Diff terms -> pure (diffTermPair terms)
Render renderer input -> pure (renderer input)
Serialize format input -> do
formatStyle <- asks (bool Colourful Plain . optionsEnableColour)
formatStyle <- asks (bool Colourful Plain . configIsTerminal)
pure (runSerialize formatStyle format input)
-- | Log an 'Error.Error' at the specified 'Level'.
logError :: Member Telemetry effs => Options -> Level -> Blob -> Error.Error String -> [(String, String)] -> Eff effs ()
logError Options{..} level blob err = writeLog level (Error.formatError optionsPrintSource (optionsIsTerminal && optionsEnableColour) blob err)
logError :: Member Telemetry effs => Config -> Level -> Blob -> Error.Error String -> [(String, String)] -> Eff effs ()
logError Config{..} level blob err = writeLog level (Error.formatError configLogPrintSource configIsTerminal blob err)
data ParserCancelled = ParserTimedOut deriving (Show, Typeable)
instance Exception ParserCancelled
defaultTimeout :: Timeout
defaultTimeout = Milliseconds 5000
-- | Parse a 'Blob' in 'IO'.
runParser :: (Member (Exc SomeException) effs, Member IO effs, Member (Reader Options) effs, Member Telemetry effs, Member Trace effs) => Blob -> Parser term -> Eff effs term
runParser :: (Member (Exc SomeException) effs, Member IO effs, Member (Reader Config) effs, Member Telemetry effs, Member Trace effs) => Blob -> Parser term -> Eff effs term
runParser blob@Blob{..} parser = case parser of
ASTParser language ->
time "parse.tree_sitter_ast_parse" languageTag $
parseToAST defaultTimeout language blob
time "parse.tree_sitter_ast_parse" languageTag $ do
config <- ask
parseToAST (configTreeSitterParseTimeout config) language blob
>>= maybeM (throwError (SomeException ParserTimedOut))
AssignmentParser parser assignment -> do
ast <- runParser blob parser `catchError` \ (SomeException err) -> do
writeStat (Stat.increment "parse.parse_failures" languageTag)
writeStat (increment "parse.parse_failures" languageTag)
writeLog Error "failed parsing" (("task", "parse") : blobFields)
throwError (toException err)
options <- ask
config <- ask
time "parse.assign" languageTag $
case Assignment.assign blobSource assignment ast of
Left err -> do
writeStat (Stat.increment "parse.assign_errors" languageTag)
logError options Error blob err (("task", "assign") : blobFields)
writeStat (increment "parse.assign_errors" languageTag)
logError config Error blob err (("task", "assign") : blobFields)
throwError (toException err)
Right term -> do
for_ (errors term) $ \ err -> case Error.errorActual err of
Just "ParseError" -> do
writeStat (Stat.increment "parse.parse_errors" languageTag)
logError options Warning blob err (("task", "parse") : blobFields)
writeStat (increment "parse.parse_errors" languageTag)
logError config Warning blob err (("task", "parse") : blobFields)
_ -> do
writeStat (Stat.increment "parse.assign_warnings" languageTag)
logError options Warning blob err (("task", "assign") : blobFields)
when (optionsFailOnWarning options) $ throwError (toException err)
writeStat (Stat.count "parse.nodes" (length term) languageTag)
writeStat (increment "parse.assign_warnings" languageTag)
logError config Warning blob err (("task", "assign") : blobFields)
when (optionsFailOnWarning (configOptions config)) $ throwError (toException err)
writeStat (count "parse.nodes" (length term) languageTag)
pure term
MarkdownParser ->
time "parse.cmark_parse" languageTag $

View File

@ -1,6 +1,45 @@
{-# LANGUAGE GADTs, RankNTypes, TypeOperators, UndecidableInstances #-}
module Semantic.Telemetry
( writeLog
(
-- Async telemetry interface
withLogger
, withHaystack
, withStatter
, LogQueue
, StatQueue
, HaystackQueue
, TelemetryQueues(..)
, queueLogMessage
, queueErrorReport
, queueStat
-- Create stats
, Stat.increment
, Stat.decrement
, Stat.count
, Stat.gauge
, Stat.timing
, Stat.withTiming
, Stat.histogram
, Stat.set
-- Statsd client
, statsClient
, StatsClient
-- Haystack client
, haystackClient
, HaystackClient
-- Logging options and formatters
, Level(..)
, LogOptions(..)
, logfmtFormatter
, terminalFormatter
, LogFormatter
-- Eff interface for telemetry
, writeLog
, writeStat
, time
, Telemetry
@ -8,11 +47,71 @@ module Semantic.Telemetry
, ignoreTelemetry
) where
import Control.Monad.Effect
import Control.Monad.IO.Class
import Semantic.Log
import Semantic.Queue
import Semantic.Stat
import Control.Exception
import Control.Monad.Effect
import Control.Monad.IO.Class
import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
import qualified Data.Time.LocalTime as LocalTime
import Network.HTTP.Client
import Semantic.Telemetry.AsyncQueue
import Semantic.Telemetry.Haystack
import Semantic.Telemetry.Log
import Semantic.Telemetry.Stat as Stat
type LogQueue = AsyncQueue Message LogOptions
type StatQueue = AsyncQueue Stat StatsClient
type HaystackQueue = AsyncQueue ErrorReport HaystackClient
data TelemetryQueues
= TelemetryQueues
{ telemetryLogger :: LogQueue
, telemetryStatter :: StatQueue
, telemetryHaystack :: HaystackQueue
}
-- | Execute an action in IO with access to a logger (async log queue).
withLogger :: LogOptions -- ^ Log options
-> Int -- ^ Max stats queue size before dropping stats
-> (LogQueue -> IO c) -- ^ Action in IO
-> IO c
withLogger options size = bracket setup closeAsyncQueue
where setup = newAsyncQueue size writeLogMessage options
-- | Execute an action in IO with access to haystack (async error reporting queue).
withHaystack :: Maybe String -> ManagerSettings -> String -> ErrorLogger -> Int -> (HaystackQueue -> IO c) -> IO c
withHaystack url settings appName errorLogger size = bracket setup closeAsyncQueue
where setup = haystackClient url settings appName >>= newAsyncQueue size (reportError errorLogger)
-- | Execute an action in IO with access to a statter (async stat queue).
-- Handles the bracketed setup and teardown of the underlying 'AsyncQueue' and
-- 'StatsClient'.
withStatter :: Host -- ^ Statsd host
-> Port -- ^ Statsd port
-> Namespace -- ^ Namespace prefix for stats
-> Int -- ^ Max stats queue size before dropping stats
-> (StatQueue -> IO c) -- ^ Action in IO
-> IO c
withStatter host port ns size = bracket setup teardown
where setup = statsClient host port ns >>= newAsyncQueue size sendStat
teardown statter = closeAsyncQueue statter >> Stat.closeStatClient (asyncQueueExtra statter)
-- | Queue a message to be logged.
queueLogMessage :: MonadIO io => LogQueue -> Level -> String -> [(String, String)] -> io ()
queueLogMessage q@AsyncQueue{..} level message pairs
| Just logLevel <- logOptionsLevel asyncQueueExtra
, level <= logLevel = liftIO Time.getCurrentTime >>= liftIO . LocalTime.utcToLocalZonedTime >>= liftIO . writeAsyncQueue q . Message level message pairs
| otherwise = pure ()
-- | Queue an error to be reported to haystack.
queueErrorReport :: MonadIO io => HaystackQueue -> SomeException -> [(String, String)] -> io ()
queueErrorReport q@AsyncQueue{..} message = liftIO . writeAsyncQueue q . ErrorReport message
-- | Queue a stat to be sent to statsd.
queueStat :: MonadIO io => StatQueue -> Stat -> io ()
queueStat q = liftIO . writeAsyncQueue q
-- Eff interface
-- | A task which logs a message at a specific log level to stderr.
writeLog :: Member Telemetry effs => Level -> String -> [(String, String)] -> Eff effs ()
@ -35,9 +134,9 @@ data Telemetry output where
WriteLog :: Level -> String -> [(String, String)] -> Telemetry ()
-- | Run a 'Telemetry' effect by expecting a 'Reader' of 'Queue's to write stats and logs to.
runTelemetry :: Member IO effects => LogQueue -> AsyncQueue Stat StatsClient -> Eff (Telemetry ': effects) a -> Eff effects a
runTelemetry :: Member IO effects => LogQueue -> StatQueue -> Eff (Telemetry ': effects) a -> Eff effects a
runTelemetry logger statter = interpret (\ t -> case t of
WriteStat stat -> liftIO (queue statter stat)
WriteStat stat -> queueStat statter stat
WriteLog level message pairs -> queueLogMessage logger level message pairs)
-- | Run a 'Telemetry' effect by ignoring statting/logging.

View File

@ -1,10 +1,10 @@
module Semantic.Queue
module Semantic.Telemetry.AsyncQueue
(
AsyncQueue(..)
, newQueue
, newQueue'
, queue
, closeQueue
, newAsyncQueue
, newAsyncQueue'
, writeAsyncQueue
, closeAsyncQueue
)
where
@ -20,36 +20,35 @@ import GHC.Conc
-- * 'extra' - any other type needed to process messages on the queue.
data AsyncQueue a extra
= AsyncQueue
{ asyncQueue :: TBMQueue a -- ^ The underlying 'TBMQueue'.
, asyncQueueSink :: Async () -- ^ A sink that will drain the queue.
, asyncQueueExtra :: extra -- ^ Any exta data the queue needs to use.
{ asyncQueue :: TBMQueue a -- ^ The underlying 'TBMQueue'.
, asyncQueueSink :: Async () -- ^ A sink that will drain the queue.
, asyncQueueExtra :: extra -- ^ Any exta data the queue needs to use.
}
-- | Create a new AsyncQueue with the given capacity using the default sink.
newQueue :: Int -> (extra -> a -> IO ()) -> extra -> IO (AsyncQueue a extra)
newQueue i = newQueue' i . sink
-- | Create a new AsyncQueue with the given capacity using the defaultSink.
newAsyncQueue :: Int -> (extra -> a -> IO ()) -> extra -> IO (AsyncQueue a extra)
newAsyncQueue i = newAsyncQueue' i . defaultSink
-- | Create a new AsyncQueue with the given capacity, specifying a custom sink.
newQueue' :: Int -> (extra -> TBMQueue a -> IO ()) -> extra -> IO (AsyncQueue a extra)
newQueue' i f extra = do
newAsyncQueue' :: Int -> (extra -> TBMQueue a -> IO ()) -> extra -> IO (AsyncQueue a extra)
newAsyncQueue' i f extra = do
q <- newTBMQueueIO i
s <- Async.async (f extra q)
pure (AsyncQueue q s extra)
-- | Queue a message.
queue :: AsyncQueue a extra -> a -> IO ()
queue AsyncQueue{..} = void . atomically . tryWriteTBMQueue asyncQueue
-- | Write a message to the queue.
writeAsyncQueue :: AsyncQueue a extra -> a -> IO ()
writeAsyncQueue AsyncQueue{..} = void . atomically . tryWriteTBMQueue asyncQueue
-- | Drain messages from the queue, calling the specified function for each message.
sink :: (extra -> a -> IO ()) -> extra -> TBMQueue a -> IO ()
sink f extra q = do
defaultSink :: (extra -> a -> IO ()) -> extra -> TBMQueue a -> IO ()
defaultSink f extra q = do
msg <- atomically (readTBMQueue q)
maybe (pure ()) go msg
where go msg = f extra msg >> sink f extra q
where go msg = f extra msg >> defaultSink f extra q
-- | Close the queue.
closeQueue :: AsyncQueue a extra -> IO ()
closeQueue AsyncQueue{..} = do
closeAsyncQueue :: AsyncQueue a extra -> IO ()
closeAsyncQueue AsyncQueue{..} = do
atomically (closeTBMQueue asyncQueue)
Async.wait asyncQueueSink

View File

@ -1,7 +1,6 @@
module Semantic.Haystack where
module Semantic.Telemetry.Haystack where
import Control.Exception
import Control.Monad.IO.Class
import Crypto.Hash
import Data.Aeson hiding (Error)
import qualified Data.ByteString.Char8 as BC
@ -10,8 +9,6 @@ import qualified Data.Text.Encoding as Text
import Network.HTTP.Client
import Network.HTTP.Types.Status (statusCode)
import Prologue hiding (hash)
import Semantic.Log
import Semantic.Queue
import System.IO.Error
data ErrorReport
@ -24,18 +21,16 @@ data HaystackClient
= HaystackClient
{ haystackClientRequest :: Request
, haystackClientManager :: Manager
, haystackClientHostName :: String
, haystackClientAppName :: String
}
} -- ^ Standard HTTP client for Haystack
| NullHaystackClient -- ^ Doesn't report needles, good for testing or when the 'HAYSTACK_URL' env var isn't set.
-- Queue an error to be reported to haystack.
queueErrorReport :: MonadIO io => AsyncQueue ErrorReport HaystackClient -> SomeException -> [(String, String)] -> io ()
queueErrorReport q@AsyncQueue{..} message = liftIO . queue q . ErrorReport message
-- | Function to log if there are errors reporting to haystack.
type ErrorLogger = String -> [(String, String)] -> IO ()
-- Create a Haystack HTTP client.
haystackClient :: Maybe String -> ManagerSettings -> String -> String -> IO HaystackClient
haystackClient maybeURL managerSettings hostName appName
haystackClient :: Maybe String -> ManagerSettings -> String -> IO HaystackClient
haystackClient maybeURL managerSettings appName
| Just url <- maybeURL = do
manager <- newManager managerSettings
request' <- parseRequest url
@ -43,20 +38,18 @@ haystackClient maybeURL managerSettings hostName appName
{ method = "POST"
, requestHeaders = ("Content-Type", "application/json; charset=utf-8") : requestHeaders request'
}
pure $ HaystackClient request manager hostName appName
pure $ HaystackClient request manager appName
| otherwise = pure NullHaystackClient
-- Report an error to Haystack over HTTP (blocking).
reportError :: MonadIO io => String -> LogQueue -> HaystackClient -> ErrorReport -> io ()
reportError _ logger NullHaystackClient ErrorReport{..} = let msg = takeWhile (/= '\n') (displayException errorReportException) in queueLogMessage logger Error msg errorReportContext
reportError sha logger HaystackClient{..} ErrorReport{..} = do
reportError :: ErrorLogger -> HaystackClient -> ErrorReport -> IO ()
reportError logger NullHaystackClient ErrorReport{..} = let msg = takeWhile (/= '\n') (displayException errorReportException) in logger msg errorReportContext
reportError logger HaystackClient{..} ErrorReport{..} = do
let fullMsg = displayException errorReportException
let summary = takeWhile (/= '\n') fullMsg
queueLogMessage logger Error summary errorReportContext
logger summary errorReportContext
let payload = object $
[ "app" .= haystackClientAppName
, "host" .= haystackClientHostName
, "sha" .= sha
, "message" .= summary
, "class" .= summary
, "backtrace" .= fullMsg
@ -64,13 +57,13 @@ reportError sha logger HaystackClient{..} ErrorReport{..} = do
] <> foldr (\(k, v) acc -> Text.pack k .= v : acc) [] errorReportContext
let request = haystackClientRequest { requestBody = RequestBodyLBS (encode payload) }
response <- liftIO . tryIOError $ httpLbs request haystackClientManager
response <- tryIOError $ httpLbs request haystackClientManager
case response of
Left e -> queueLogMessage logger Error ("Failed to report error to haystack: " <> displayException e) []
Left e -> logger ("Failed to report error to haystack: " <> displayException e) []
Right response -> do
let status = statusCode (responseStatus response)
if status /= 201
then queueLogMessage logger Error ("Failed to report error to haystack, status=" <> show status <> ".") []
then logger ("Failed to report error to haystack, status=" <> show status <> ".") []
else pure ()
where
rollup :: String -> Text

View File

@ -0,0 +1,78 @@
module Semantic.Telemetry.Log where
import Control.Monad.IO.Class
import Data.Error (withSGRCode)
import Data.List (intersperse)
import qualified Data.Time.Format as Time
import qualified Data.Time.LocalTime as LocalTime
import Prologue
import System.Console.ANSI
import System.IO
import Text.Printf
-- | A log message at a specific level.
data Message = Message Level String [(String, String)] LocalTime.ZonedTime
deriving (Show)
-- | A formatter function for crafting log messages.
type LogFormatter = LogOptions -> Message -> String
-- | Logging level
data Level
= Error
| Warning
| Info
| Debug
deriving (Eq, Ord, Show)
-- | Options for controlling logging
data LogOptions = LogOptions
{ 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 . logOptionsFormatter options
-- | Format log messaging using "logfmt".
--
-- Logfmt is a loosely defined logging format (see https://brandur.org/logfmt)
-- for structured data, which plays very well with indexing tools like Splunk.
--
-- Example:
-- time=2006-01-02T15:04:05Z07:00 msg="this is a message" key=val int=42 key2="val with word" float=33.33
logfmtFormatter :: LogFormatter
logfmtFormatter LogOptions{..} (Message level message pairs time) =
showPairs
( kv "time" (showTime time)
: kv "msg" (shows message)
: kv "level" (shows level)
: (uncurry kv . second shows <$> (pairs <> logOptionsContext)))
. showChar '\n' $ ""
where
kv k v = showString k . showChar '=' . v
showPairs = foldr (.) id . intersperse (showChar ' ')
showTime = showString . Time.formatTime Time.defaultTimeLocale "%FT%XZ%z"
-- | Format log messages to a terminal. Suitable for local development.
--
-- Example:
-- [16:52:41] INFO this is a message key=val language=Ruby time=0.000098s
terminalFormatter :: LogFormatter
terminalFormatter LogOptions{..} (Message level message pairs time) =
showChar '[' . showTime time . showString "] "
. showLevel level . showChar ' '
. showString (printf "%-20s " message)
. showPairs (pairs <> logOptionsContext)
. showChar '\n' $ ""
where
colourize = True
showLevel Error = withSGRCode colourize [SetColor Foreground Vivid Red, SetConsoleIntensity BoldIntensity] (showString "ERROR")
showLevel Warning = withSGRCode colourize [SetColor Foreground Vivid Yellow, SetConsoleIntensity BoldIntensity] (showString " WARN")
showLevel Info = withSGRCode colourize [SetColor Foreground Vivid Cyan, SetConsoleIntensity BoldIntensity] (showString " INFO")
showLevel Debug = withSGRCode colourize [SetColor Foreground Vivid White, SetConsoleIntensity BoldIntensity] (showString "DEBUG")
showPairs pairs = foldr (.) id $ intersperse (showChar ' ') (showPair <$> pairs)
showPair (k, v) = showString k . showChar '=' . withSGRCode colourize [SetConsoleIntensity BoldIntensity] (showString v)
showTime = showString . Time.formatTime Time.defaultTimeLocale "%X"

View File

@ -1,4 +1,4 @@
module Semantic.Stat
module Semantic.Telemetry.Stat
(
-- Primary API for creating stats.
increment
@ -10,9 +10,12 @@ module Semantic.Stat
, histogram
, set
, Stat
, Tags
, Host
, Port
, Namespace
-- Client
, defaultStatsClient
, statsClient
, StatsClient(..)
, closeStatClient
@ -32,10 +35,8 @@ import qualified Data.Time.Clock.POSIX as Time (getCurrentTime)
import Network.Socket
(Socket (..), SocketType (..), addrAddress, addrFamily, close, connect, defaultProtocol, getAddrInfo, socket)
import Network.Socket.ByteString
import Network.URI
import Numeric
import Prologue
import System.Environment
import System.IO.Error
-- | A named piece of data you wish to record a specific 'Metric' for.
@ -101,43 +102,21 @@ data StatsClient
= StatsClient
{ statsClientUDPSocket :: Socket
, statsClientNamespace :: String
, statsClientUDPHost :: String
, statsClientUDPPort :: String
, statsClientUDPHost :: Host
, statsClientUDPPort :: Port
}
-- | Create a default stats client. This function consults two optional
-- environment variables for the stats URI (default: 127.0.0.1:28125).
-- * STATS_ADDR - String URI to send stats to in the form of `host:port`.
-- * DOGSTATSD_HOST - String hostname which will override the above host.
-- Generally used on kubes pods.
defaultStatsClient :: MonadIO io => io StatsClient
defaultStatsClient = liftIO $ do
addr <- lookupEnv "STATS_ADDR"
let (host', port) = parseAddr (fmap ("statsd://" <>) addr)
-- When running in Kubes, DOGSTATSD_HOST is set with the dogstatsd host.
kubesHost <- lookupEnv "DOGSTATSD_HOST"
let host = fromMaybe host' kubesHost
statsClient host port "semantic"
where
defaultHost = "127.0.0.1"
defaultPort = "28125"
parseAddr a | Just s <- a
, Just (Just (URIAuth _ host port)) <- uriAuthority <$> parseURI s
= (parseHost host, parsePort port)
| otherwise = (defaultHost, defaultPort)
parseHost s = if null s then defaultHost else s
parsePort s = if null s then defaultPort else dropWhile (':' ==) s
type Host = String
type Port = String
type Namespace = String
-- | Create a StatsClient at the specified host and port with a namespace prefix.
statsClient :: MonadIO io => String -> String -> String -> io StatsClient
statsClient host port statsClientNamespace = liftIO $ do
statsClient :: MonadIO io => Host -> Port -> Namespace -> io StatsClient
statsClient host port ns = liftIO $ do
(addr:_) <- getAddrInfo Nothing (Just host) (Just port)
sock <- socket (addrFamily addr) Datagram defaultProtocol
connect sock (addrAddress addr)
pure (StatsClient sock statsClientNamespace host port)
pure (StatsClient sock ns host port)
-- | Close the client's underlying socket.
closeStatClient :: MonadIO io => StatsClient -> io ()

15
src/Semantic/Version.hs Normal file
View File

@ -0,0 +1,15 @@
{-# OPTIONS_GHC -fforce-recomp #-} -- So that gitHash is correct.
{-# LANGUAGE TemplateHaskell #-}
module Semantic.Version where
import Data.Version (showVersion)
import Development.GitRev
import Paths_semantic (version)
-- The SHA1 hash of this build of semantic.
buildSHA :: String
buildSHA = $(gitHash)
-- The version string of this build of semantic.
buildVersion :: String
buildVersion = showVersion version

View File

@ -3,7 +3,8 @@ module Semantic.Stat.Spec (spec) where
import Control.Exception
import Network.Socket hiding (recv)
import Network.Socket.ByteString
import Semantic.Stat
import Semantic.Telemetry.Stat
import Semantic.Config
import System.Environment
import SpecHelpers
@ -80,3 +81,7 @@ spec = do
sendStat client { statsClientUDPSocket = clientSoc } (increment "app.metric" [])
info <- recv serverSoc 1024
info `shouldBe` "semantic.app.metric:1|c"
-- Defaults are all driven by defaultConfig.
defaultStatsClient :: IO StatsClient
defaultStatsClient = defaultConfig defaultOptions >>= \Config{..} -> statsClient configStatsHost configStatsPort configAppName