Ping.hs

{-# LANGUAGE CPP #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
#if __GLASGOW_HASKELL__ >= 800
{-# OPTIONS_GHC -Wno-missing-signatures #-}
#else
{-# OPTIONS_GHC -fno-warn-missing-signatures #-}
#endif
module Database.InfluxDB.Ping
  ( -- * Ping interface
    ping

  -- * Ping parameters
  , PingParams
  , pingParams
  , server
  , manager
  , timeout

  -- * Pong
  , Pong
  , roundtripTime
  , influxdbVersion
  ) where
import Control.Exception

import Control.Lens
import Data.Time.Clock (NominalDiffTime)
import System.Clock
import qualified Data.ByteString as BS
import qualified Data.Text.Encoding as TE
import qualified Network.HTTP.Client as HC

import Database.InfluxDB.Types as Types

-- Ping requests do not require authentication
-- | The full set of parameters for the ping API
data PingParams = PingParams
  { pingServer :: !Server
  , pingManager :: !(Either HC.ManagerSettings HC.Manager)
  -- ^ HTTP connection manager
  , pingTimeout :: !(Maybe NominalDiffTime)
  -- ^ Timeout
  }

-- | Smart constructor for 'PingParams'
--
-- Default parameters:
--
--   ['L.server'] 'defaultServer'
--   ['L.manager'] @'Left' 'HC.defaultManagerSettings'@
--   ['L.timeout'] 'Nothing'
pingParams :: PingParams
pingParams = PingParams
  { pingServer = defaultServer
  , pingManager = Left HC.defaultManagerSettings
  , pingTimeout = Nothing
  }

makeLensesWith
  ( lensRules
    & generateSignatures .~ False
    & lensField .~ lookingupNamer
      [ ("pingServer", "_server")
      , ("pingManager", "_manager")
      , ("pingTimeout", "timeout")
      ]
    )
  ''PingParams

-- |
-- >>> pingParams ^. server.host
-- "localhost"
instance HasServer PingParams where
  server = _server

-- |
-- >>> let p = pingParams & manager .~ Left HC.defaultManagerSettings
instance HasManager PingParams where
  manager = _manager

-- | The number of seconds to wait before returning a response
--
-- >>> pingParams ^. timeout
-- Nothing
-- >>> let p = pingParams & timeout ?~ 1
timeout :: Lens' PingParams (Maybe NominalDiffTime)

pingRequest :: PingParams -> HC.Request
pingRequest PingParams {..} = HC.defaultRequest
  { HC.host = TE.encodeUtf8 _host
  , HC.port = fromIntegral _port
  , HC.secure = _ssl
  , HC.method = "GET"
  , HC.path = "/ping"
  }
  where
    Server {..} = pingServer

-- | Response of a ping request
data Pong = Pong
  { _roundtripTime :: !TimeSpec
  -- ^ Round-trip time of the ping
  , _influxdbVersion :: !BS.ByteString
  -- ^ Version string returned by InfluxDB
  } deriving (Show, Eq, Ord)

makeLensesWith (lensRules & generateSignatures .~ False) ''Pong

-- | Round-trip time of the ping
roundtripTime :: Lens' Pong TimeSpec

-- | Version string returned by InfluxDB
influxdbVersion :: Lens' Pong BS.ByteString

-- | Send a ping to InfluxDB.
--
-- It may throw an 'InfluxException'.
ping :: PingParams -> IO Pong
ping params = do
  manager' <- either HC.newManager return $ pingManager params
  startTime <- getTimeMonotonic
  HC.withResponse request manager' $ \response -> do
    endTime <- getTimeMonotonic
    case lookup "X-Influxdb-Version" (HC.responseHeaders response) of
      Just version ->
        return $! Pong (diffTimeSpec endTime startTime) version
      Nothing ->
        throwIO $ UnexpectedResponse
          "The X-Influxdb-Version header was missing in the response."
          ""
  `catch` (throwIO . HTTPException)
  where
    request = (pingRequest params)
      { HC.responseTimeout = case pingTimeout params of
        Nothing -> HC.responseTimeoutNone
        Just sec -> HC.responseTimeoutMicro $
          round $ realToFrac sec / (10**(-6) :: Double)
      }
    getTimeMonotonic = getTime Monotonic