{-# 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

-- $setup
-- >>> import Database.InfluxDB.Ping

-- Ping requests do not require authentication
-- | The full set of parameters for the ping API
--
-- Following lenses are available to access its fields:
--
-- * 'server'
-- * 'manager'
-- * 'timeout'
data PingParams = PingParams
  { PingParams -> Server
pingServer :: !Server
  , PingParams -> Either ManagerSettings Manager
pingManager :: !(Either HC.ManagerSettings HC.Manager)
  -- ^ HTTP connection manager
  , PingParams -> Maybe NominalDiffTime
pingTimeout :: !(Maybe NominalDiffTime)
  -- ^ Timeout
  }

-- | Smart constructor for 'PingParams'
--
-- Default parameters:
--
--   ['server'] 'defaultServer'
--   ['manager'] @'Left' 'HC.defaultManagerSettings'@
--   ['timeout'] 'Nothing'
pingParams :: PingParams
pingParams :: PingParams
pingParams = PingParams
  { pingServer :: Server
pingServer = Server
defaultServer
  , pingManager :: Either ManagerSettings Manager
pingManager = ManagerSettings -> Either ManagerSettings Manager
forall a b. a -> Either a b
Left ManagerSettings
HC.defaultManagerSettings
  , pingTimeout :: Maybe NominalDiffTime
pingTimeout = Maybe NominalDiffTime
forall a. Maybe a
Nothing
  }

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

-- |
-- >>> pingParams ^. server.host
-- "localhost"
instance HasServer PingParams where
  server :: Lens' PingParams Server
server = (Server -> f Server) -> PingParams -> f PingParams
Lens' PingParams Server
_server

-- |
-- >>> let p = pingParams & manager .~ Left HC.defaultManagerSettings
instance HasManager PingParams where
  manager :: Lens' PingParams (Either ManagerSettings Manager)
manager = (Either ManagerSettings Manager
 -> f (Either ManagerSettings Manager))
-> PingParams -> f PingParams
Lens' PingParams (Either ManagerSettings 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 -> Request
pingRequest PingParams {Maybe NominalDiffTime
Either ManagerSettings Manager
Server
pingServer :: PingParams -> Server
pingManager :: PingParams -> Either ManagerSettings Manager
pingTimeout :: PingParams -> Maybe NominalDiffTime
pingServer :: Server
pingManager :: Either ManagerSettings Manager
pingTimeout :: Maybe NominalDiffTime
..} = Request
HC.defaultRequest
  { HC.host = TE.encodeUtf8 _host
  , HC.port = fromIntegral _port
  , HC.secure = _ssl
  , HC.method = "GET"
  , HC.path = "/ping"
  }
  where
    Server {Bool
Int
Text
_host :: Text
_port :: Int
_ssl :: Bool
_host :: Server -> Text
_port :: Server -> Int
_ssl :: Server -> Bool
..} = Server
pingServer

-- | Response of a ping request
data Pong = Pong
  { Pong -> TimeSpec
_roundtripTime :: !TimeSpec
  -- ^ Round-trip time of the ping
  , Pong -> Method
_influxdbVersion :: !BS.ByteString
  -- ^ Version string returned by InfluxDB
  } deriving (Int -> Pong -> ShowS
[Pong] -> ShowS
Pong -> String
(Int -> Pong -> ShowS)
-> (Pong -> String) -> ([Pong] -> ShowS) -> Show Pong
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Pong -> ShowS
showsPrec :: Int -> Pong -> ShowS
$cshow :: Pong -> String
show :: Pong -> String
$cshowList :: [Pong] -> ShowS
showList :: [Pong] -> ShowS
Show, Pong -> Pong -> Bool
(Pong -> Pong -> Bool) -> (Pong -> Pong -> Bool) -> Eq Pong
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Pong -> Pong -> Bool
== :: Pong -> Pong -> Bool
$c/= :: Pong -> Pong -> Bool
/= :: Pong -> Pong -> Bool
Eq, Eq Pong
Eq Pong =>
(Pong -> Pong -> Ordering)
-> (Pong -> Pong -> Bool)
-> (Pong -> Pong -> Bool)
-> (Pong -> Pong -> Bool)
-> (Pong -> Pong -> Bool)
-> (Pong -> Pong -> Pong)
-> (Pong -> Pong -> Pong)
-> Ord Pong
Pong -> Pong -> Bool
Pong -> Pong -> Ordering
Pong -> Pong -> Pong
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
$ccompare :: Pong -> Pong -> Ordering
compare :: Pong -> Pong -> Ordering
$c< :: Pong -> Pong -> Bool
< :: Pong -> Pong -> Bool
$c<= :: Pong -> Pong -> Bool
<= :: Pong -> Pong -> Bool
$c> :: Pong -> Pong -> Bool
> :: Pong -> Pong -> Bool
$c>= :: Pong -> Pong -> Bool
>= :: Pong -> Pong -> Bool
$cmax :: Pong -> Pong -> Pong
max :: Pong -> Pong -> Pong
$cmin :: Pong -> Pong -> Pong
min :: Pong -> Pong -> Pong
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 :: PingParams -> IO Pong
ping PingParams
params = do
  Manager
manager' <- (ManagerSettings -> IO Manager)
-> (Manager -> IO Manager)
-> Either ManagerSettings Manager
-> IO Manager
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either ManagerSettings -> IO Manager
HC.newManager Manager -> IO Manager
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ManagerSettings Manager -> IO Manager)
-> Either ManagerSettings Manager -> IO Manager
forall a b. (a -> b) -> a -> b
$ PingParams -> Either ManagerSettings Manager
pingManager PingParams
params
  TimeSpec
startTime <- IO TimeSpec
getTimeMonotonic
  Request -> Manager -> (Response BodyReader -> IO Pong) -> IO Pong
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
HC.withResponse Request
request Manager
manager' ((Response BodyReader -> IO Pong) -> IO Pong)
-> (Response BodyReader -> IO Pong) -> IO Pong
forall a b. (a -> b) -> a -> b
$ \Response BodyReader
response -> do
    TimeSpec
endTime <- IO TimeSpec
getTimeMonotonic
    case HeaderName -> [(HeaderName, Method)] -> Maybe Method
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
"X-Influxdb-Version" (Response BodyReader -> [(HeaderName, Method)]
forall body. Response body -> [(HeaderName, Method)]
HC.responseHeaders Response BodyReader
response) of
      Just Method
version ->
        Pong -> IO Pong
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Pong -> IO Pong) -> Pong -> IO Pong
forall a b. (a -> b) -> a -> b
$! TimeSpec -> Method -> Pong
Pong (TimeSpec -> TimeSpec -> TimeSpec
diffTimeSpec TimeSpec
endTime TimeSpec
startTime) Method
version
      Maybe Method
Nothing ->
        InfluxException -> IO Pong
forall e a. Exception e => e -> IO a
throwIO (InfluxException -> IO Pong) -> InfluxException -> IO Pong
forall a b. (a -> b) -> a -> b
$ String -> Request -> ByteString -> InfluxException
UnexpectedResponse
          String
"The X-Influxdb-Version header was missing in the response."
          Request
request
          ByteString
""
  IO Pong -> (HttpException -> IO Pong) -> IO Pong
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (InfluxException -> IO Pong
forall e a. Exception e => e -> IO a
throwIO (InfluxException -> IO Pong)
-> (HttpException -> InfluxException) -> HttpException -> IO Pong
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HttpException -> InfluxException
HTTPException)
  where
    request :: Request
request = (PingParams -> Request
pingRequest PingParams
params)
      { HC.responseTimeout = case pingTimeout params of
        Maybe NominalDiffTime
Nothing -> ResponseTimeout
HC.responseTimeoutNone
        Just NominalDiffTime
sec -> Int -> ResponseTimeout
HC.responseTimeoutMicro (Int -> ResponseTimeout) -> Int -> ResponseTimeout
forall a b. (a -> b) -> a -> b
$
          Double -> Int
forall b. Integral b => Double -> b
forall a b. (RealFrac a, Integral b) => a -> b
round (Double -> Int) -> Double -> Int
forall a b. (a -> b) -> a -> b
$ NominalDiffTime -> Double
forall a b. (Real a, Fractional b) => a -> b
realToFrac NominalDiffTime
sec Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ (Double
10Double -> Double -> Double
forall a. Floating a => a -> a -> a
**(-Double
6) :: Double)
      }
    getTimeMonotonic :: IO TimeSpec
getTimeMonotonic = Clock -> IO TimeSpec
getTime Clock
Monotonic