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:
commit
14e03fb1d0
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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"
|
||||
|
@ -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
|
||||
|
||||
|
@ -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
|
||||
}
|
@ -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 $
|
||||
|
@ -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.
|
||||
|
@ -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
|
@ -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
|
78
src/Semantic/Telemetry/Log.hs
Normal file
78
src/Semantic/Telemetry/Log.hs
Normal 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"
|
@ -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
15
src/Semantic/Version.hs
Normal 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
|
@ -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
|
||||
|
Loading…
Reference in New Issue
Block a user