Continue to refine config API

src/Semantic/CLI.hs

@@ -1,5 +1,4 @@
-{-# OPTIONS_GHC -fforce-recomp #-} -- So that gitHash is correct.
+{-# LANGUAGE ApplicativeDo, RankNTypes #-}
-{-# LANGUAGE ApplicativeDo, RankNTypes, TemplateHaskell #-}
 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.")

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           Control.Exception
-import Network.BSD
+import           Network.BSD
-import Network.HTTP.Client.TLS
+import           Network.HTTP.Client.TLS
-import Network.URI
+import           Network.URI
-import Prologue
+import           Prologue
-import Semantic.Telemetry
+import           Semantic.Env
-import Semantic.Telemetry.AsyncQueue
+import           Semantic.Telemetry
-import qualified Semantic.Telemetry.Stat as Stat
+import           Semantic.Telemetry.AsyncQueue
+import qualified Semantic.Telemetry.Haystack as Haystack
 import qualified Semantic.Telemetry.Log as Log
-import Semantic.Env
+import qualified Semantic.Telemetry.Stat as Stat
-import System.Environment
+import           Semantic.Version
-import System.IO (hIsTerminalDevice, stderr)
+import           System.Environment
-import System.Posix.Process
+import           System.IO (hIsTerminalDevice, stderr)
-import System.Posix.Types
+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{
+  newAsyncQueue configMaxTelemetyQueueSize Log.writeLogMessage LogOptions {
-    optionsLevel      = optionsLogLevel configOptions
+    logOptionsLevel     = optionsLogLevel configOptions
-  , optionsFormatter  = configLogFormatter
+  , logOptionsFormatter = configLogFormatter
-  , optionsLogContext = [("app", configAppName), ("process_id", show configProcessID)] <> [("request_id", x) | x <- toList (optionsRequestID configOptions) ]
+  , 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

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
+    withStatter config $ \statter ->
-
+      runTaskWithConfig config logger statter task
-  -- closeQueue statter
-  -- closeStatClient (asyncQueueExtra statter)
-  -- closeQueue logger
   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

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 ()
 

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.
+  { logOptionsLevel      :: Maybe Level  -- ^ What level of messages to log. 'Nothing' disabled logging.
-  , optionsFormatter  :: LogFormatter -- ^ Log formatter to use.
+  , logOptionsFormatter  :: LogFormatter -- ^ Log formatter to use.
-  , optionsLogContext :: [(String, String)]
+  , 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