Start to extract common configuration

semantic.cabal

@@ -150,6 +150,7 @@ library
                      -- High-level flow & operational functionality (logging, stats, etc.)
                      , Semantic.AST
                      , Semantic.CLI
+                     , Semantic.Config
                      , Semantic.Diff
                      , Semantic.Distribute
                      , Semantic.Env

src/Semantic/Config.hs

@@ -0,0 +1,73 @@
+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
+
+data Config
+  = Config
+  { configAppName     :: String
+  , configHostName    :: String    -- ^ HostName
+  , configProcessID   :: ProcessID -- ^ ProcessID
+  , configHaystackURL :: Maybe String
+  , configStatsAddr   :: Addr
+  , configLogOptions  :: Options
+  }
+
+data Addr = Addr { addrHost :: String, addrPort :: String }
+
+defaultConfig :: IO Config
+defaultConfig = do
+  pid <- getProcessID
+  hostName <- getHostName
+  haystackURL <- lookupEnv "HAYSTACK_URL"
+  statsAddr <- lookupStatsAddr
+  logOptions <- configureOptionsForHandle stderr defaultOptions
+  pure Config
+    { configAppName = "semantic"
+    , configHostName = hostName
+    , configProcessID = pid
+    , configHaystackURL = haystackURL
+    , configStatsAddr = statsAddr
+    , configLogOptions = logOptions
+    }
+
+defaultHaystackClient :: IO HaystackClient
+defaultHaystackClient = defaultConfig >>= haystackClientFromConfig
+
+haystackClientFromConfig :: Config -> IO HaystackClient
+haystackClientFromConfig Config{..} = haystackClient configHaystackURL tlsManagerSettings configHostName configAppName
+
+defaultStatsClient :: IO StatsClient
+defaultStatsClient = defaultConfig >>= statsClientFromConfig
+
+statsClientFromConfig :: Config -> IO StatsClient
+statsClientFromConfig Config{..} = statsClient (addrHost configStatsAddr) (addrPort configStatsAddr) configAppName
+
+lookupStatsAddr :: IO Addr
+lookupStatsAddr = 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
+
+  pure (Addr host port)
+  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

src/Semantic/Haystack.hs

@@ -2,13 +2,10 @@ module Semantic.Haystack where
 
 import Control.Monad.IO.Class
 import Data.Aeson
-import Network.BSD
 import Network.HTTP.Client
-import Network.HTTP.Client.TLS
 import Network.HTTP.Types.Status (statusCode)
 import Prologue hiding (hash)
 import Semantic.Queue
-import System.Environment
 import System.IO.Error
 import qualified Data.Text.Encoding as Text
 import Crypto.Hash
@@ -32,21 +29,18 @@ data HaystackClient
 queueErrorReport :: MonadIO io => AsyncQueue ErrorReport HaystackClient -> Text -> [(Text, Text)] -> io ()
 queueErrorReport q@AsyncQueue{..} message = liftIO . queue q . ErrorReport message
 
--- Create the default Haystack client.
-defaultHaystackClient :: MonadIO io => io HaystackClient
-defaultHaystackClient = do
-  url <- liftIO $ lookupEnv "HAYSTACK_URL"
-  case url of
-    Nothing -> pure NullHaystackClient
-    Just url -> do
-      hostname <- liftIO getHostName
-      manager  <- liftIO $ newManager tlsManagerSettings
-      request' <- liftIO $ parseRequest url
+-- Create a Haystack HTTP client.
+haystackClient :: Maybe String -> ManagerSettings -> String -> String -> IO HaystackClient
+haystackClient maybeURL managerSettings hostName appName
+  | Just url <- maybeURL = do
+      manager  <- newManager managerSettings
+      request' <- parseRequest url
       let request = request'
             { method = "POST"
             , requestHeaders = [ ("Content-Type", "application/json; charset=utf-8") ]
             }
-      pure $ HaystackClient request manager hostname "semantic"
+      pure $ HaystackClient request manager hostName appName
+  | otherwise = pure NullHaystackClient
 
 -- Report an error to Haystack over HTTP.
 reportError :: MonadIO io => HaystackClient -> ErrorReport -> io (Maybe Int)

src/Semantic/Stat.hs

@@ -13,6 +13,7 @@ module Semantic.Stat
 
 -- Client
 , defaultStatsClient
+, statsClient
 , StatsClient(..)
 , closeStatClient