Make error reporter API generic

Instead of hard-coding the HTTP API we use for uploading errors to our
internal service, let the user provide an arbitrary function (in the IO
monad) for uploading them.  The default config will create an error
reporter that logs errors to the console, just like happened before if
you didn't set the `HAYSTACK_URL` environment variable.

Author: dcreager

script/generate-example

@@ -37,20 +37,20 @@ generate_example () {
 
   if [ -e "$fileA" ]; then
     status $parseFileA
-    cabal new-run semantic -- parse --sexpression $fileA > $parseFileA
+    cabal new-run --verbose=0 semantic -- parse --sexpression $fileA > $parseFileA
   fi
 
   if [ -e "$fileB" ]; then
     status $parseFileB
-    cabal new-run semantic -- parse --sexpression $fileB > $parseFileB
+    cabal new-run --verbose=0 semantic -- parse --sexpression $fileB > $parseFileB
   fi
 
   if [ -e "$fileA" -a -e "$fileB" ]; then
     status $diffFileAB
-    cabal new-run semantic -- diff --sexpression $fileA $fileB > $diffFileAB
+    cabal new-run --verbose=0 semantic -- diff --sexpression $fileA $fileB > $diffFileAB
 
     status $diffFileBA
-    cabal new-run semantic -- diff --sexpression $fileB $fileA > $diffFileBA
+    cabal new-run --verbose=0 semantic -- diff --sexpression $fileB $fileA > $diffFileBA
   fi
 }
 

semantic.cabal

@@ -267,7 +267,7 @@ library
                      , Semantic.Task.Files
                      , Semantic.Telemetry
                      , Semantic.Telemetry.AsyncQueue
-                     , Semantic.Telemetry.Haystack
+                     , Semantic.Telemetry.Error
                      , Semantic.Telemetry.Log
                      , Semantic.Telemetry.Stat
                      , Semantic.Timeout

src/Semantic/Config.hs

@@ -6,7 +6,7 @@ module Semantic.Config
   , debugOptions
   , infoOptions
   , lookupStatsAddr
-  , withHaystackFromConfig
+  , withErrorReporterFromConfig
   , logOptionsFromConfig
   , withLoggerFromConfig
   , withStatterFromConfig
@@ -23,12 +23,11 @@ import           Data.Duration
 import           Data.Error (LogPrintSource(..))
 import           Data.Flag
 import           Network.HostName
-import           Network.HTTP.Client.TLS
 import           Network.URI
 import           Prologue
 import           Semantic.Env
 import           Semantic.Telemetry
-import qualified Semantic.Telemetry.Haystack as Haystack
+import qualified Semantic.Telemetry.Error as Error
 import qualified Semantic.Telemetry.Stat as Stat
 import           System.Environment
 import           System.IO (hIsTerminalDevice, stdout)
@@ -45,7 +44,6 @@ data 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
   , configStatsHost              :: Stat.Host            -- ^ Host of statsd/datadog (default: "127.0.0.1")
   , configStatsPort              :: Stat.Port            -- ^ Port of statsd/datadog (default: "28125")
   , configTreeSitterParseTimeout :: Duration             -- ^ Timeout in milliseconds before canceling tree-sitter parsing (default: 6000).
@@ -81,7 +79,6 @@ defaultConfig options@Options{..} = do
   pid <- getProcessID
   hostName <- getHostName
   isTerminal <- hIsTerminalDevice stdout
-  haystackURL <- lookupEnv "HAYSTACK_URL"
   (statsHost, statsPort) <- lookupStatsAddr
   size <- envLookupNum 1000 "MAX_TELEMETRY_QUEUE_SIZE"
   parseTimeout <- envLookupNum 6000 "TREE_SITTER_PARSE_TIMEOUT"
@@ -90,7 +87,6 @@ defaultConfig options@Options{..} = do
     { configAppName = "semantic"
     , configHostName = hostName
     , configProcessID = pid
-    , configHaystackURL = haystackURL
     , configStatsHost = statsHost
     , configStatsPort = statsPort
 
@@ -109,9 +105,9 @@ defaultConfig options@Options{..} = do
 withTelemetry :: Config -> (TelemetryQueues -> IO c) -> IO c
 withTelemetry config action =
   withLoggerFromConfig config $ \logger ->
-  withHaystackFromConfig config (queueLogMessage logger Error) $ \haystack ->
+  withErrorReporterFromConfig config (queueLogMessage logger Error) $ \errorReporter ->
   withStatterFromConfig config $ \statter ->
-    action (TelemetryQueues logger statter haystack)
+    action (TelemetryQueues logger statter errorReporter)
 
 logOptionsFromConfig :: Config -> LogOptions
 logOptionsFromConfig Config{..} = LogOptions
@@ -132,9 +128,9 @@ withLoggerFromConfig :: Config -> (LogQueue -> IO c) -> IO c
 withLoggerFromConfig config = withLogger (logOptionsFromConfig config) (configMaxTelemetyQueueSize config)
 
 
-withHaystackFromConfig :: Config -> Haystack.ErrorLogger -> (HaystackQueue -> IO c) -> IO c
-withHaystackFromConfig Config{..} errorLogger =
-  withHaystack configHaystackURL tlsManagerSettings configAppName errorLogger configMaxTelemetyQueueSize
+withErrorReporterFromConfig :: Config -> Error.ErrorLogger -> (ErrorQueue -> IO c) -> IO c
+withErrorReporterFromConfig Config{..} errorLogger =
+  withErrorReporter (nullErrorReporter errorLogger) configMaxTelemetyQueueSize
 
 withStatterFromConfig :: Config -> (StatQueue -> IO c) -> IO c
 withStatterFromConfig Config{..} =

src/Semantic/Telemetry.hs

@@ -3,11 +3,11 @@ module Semantic.Telemetry
 (
   -- Async telemetry interface
   withLogger
-, withHaystack
+, withErrorReporter
 , withStatter
 , LogQueue
 , StatQueue
-, HaystackQueue
+, ErrorQueue
 , TelemetryQueues(..)
 , queueLogMessage
 , queueErrorReport
@@ -27,9 +27,8 @@ module Semantic.Telemetry
 , statsClient
 , StatsClient
 
--- Haystack client
-, haystackClient
-, HaystackClient
+-- Error reporters
+, nullErrorReporter
 
 -- Logging options and formatters
 , Level(..)
@@ -58,21 +57,20 @@ import           Control.Exception
 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.Error
 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
+type ErrorQueue = AsyncQueue ErrorReport ErrorReporter
 
 data TelemetryQueues
   = TelemetryQueues
-  { telemetryLogger   :: LogQueue
-  , telemetryStatter  :: StatQueue
-  , telemetryHaystack :: HaystackQueue
+  { telemetryLogger        :: LogQueue
+  , telemetryStatter       :: StatQueue
+  , telemetryErrorReporter :: ErrorQueue
   }
 
 -- | Execute an action in IO with access to a logger (async log queue).
@@ -83,10 +81,10 @@ withLogger :: LogOptions         -- ^ Log options
 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 an error reporter (async error reporting queue).
+withErrorReporter :: IO ErrorReporter -> Int -> (ErrorQueue -> IO c) -> IO c
+withErrorReporter errorReporter size = bracket setup closeAsyncQueue
+  where setup = errorReporter >>= newAsyncQueue size ($)
 
 -- | Execute an action in IO with access to a statter (async stat queue).
 -- Handles the bracketed setup and teardown of the underlying 'AsyncQueue' and
@@ -108,8 +106,8 @@ queueLogMessage q@AsyncQueue{..} level message pairs
   , 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 ()
+-- | Queue an error to be reported.
+queueErrorReport :: MonadIO io => ErrorQueue -> SomeException -> [(String, String)] -> io ()
 queueErrorReport q@AsyncQueue{..} message = liftIO . writeAsyncQueue q . ErrorReport message
 
 -- | Queue a stat to be sent to statsd.

src/Semantic/Telemetry/Error.hs

@@ -0,0 +1,27 @@
+module Semantic.Telemetry.Error
+  ( ErrorLogger
+  , ErrorReport (..)
+  , ErrorReporter
+  , nullErrorReporter
+  ) where
+
+import           Control.Exception
+
+data ErrorReport
+  = ErrorReport
+  { errorReportException :: SomeException
+  , errorReportContext   :: [(String, String)]
+  } deriving (Show)
+
+-- | Function to log if there are errors reporting an error.
+type ErrorLogger = String -> [(String, String)] -> IO ()
+
+type ErrorReporter = ErrorReport -> IO ()
+
+-- | Doesn't send error reports anywhere.  Useful in tests or for basic command-line usage.
+nullErrorReporter :: ErrorLogger -> IO ErrorReporter
+nullErrorReporter logger = pure reportError
+  where
+    reportError ErrorReport{..} = let
+      msg = takeWhile (/= '\n') (displayException errorReportException)
+      in logger msg errorReportContext

src/Semantic/Telemetry/Haystack.hs

@@ -147,13 +147,8 @@ ifte :: ( IvoryStore a
           -> Ivory eff a
           -> Ivory eff a
 
-haystackClient maybeURL managerSettings appName
-  | Just url <- maybeURL = do
-      manager  <- newManager managerSettings
-      request' <- parseRequest url
-      let request = request'
-            { method = "POST"
-            , requestHeaders = ("Content-Type", "application/json; charset=utf-8") : requestHeaders request'
-            }
-      pure $ HaystackClient request manager appName
-  | otherwise = pure NullHaystackClient
+nullErrorReporter logger = pure reportError
+  where
+    reportError ErrorReport{..} = let
+      msg = takeWhile (/= '\n') (displayException errorReportException)
+      in logger msg errorReportContext

test/fixtures/haskell/corpus/function-declarations.A.hs

@@ -148,13 +148,8 @@ g :: ( IvoryStore a
        -> Ivory eff a
        -> Ivory eff a
 
-needlestackClient maybeURL directorSettings appName
-  | Just url <- maybeURL = do
-      director  <- newDirector directorSettings
-      request' <- parseRequest url
-      let request = request'
-            { method = "POST"
-            , requestHeaders = ("Content-Type", "application/json; charset=utf-8") : requestHeaders request'
-            }
-      pure $ NeedlestackClient request director appName
-  | otherwise = pure NullNeedlestackClient
+emptyErrorReporter logger = pure reportError
+  where
+    reportError ErrorReport{..} = let
+      msg = takeWhile (/= '\n') (displayException errorReportException)
+      in logger msg errorReportContext