module LaunchDarkly.Server.Network.Polling (pollingThread) where

import Control.Concurrent (threadDelay)
import Control.Monad.Catch (MonadMask, MonadThrow)
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger (MonadLogger, logError, logInfo)
import Data.Aeson (FromJSON (..), eitherDecode)
import Data.Generics.Product (getField)
import Data.Text (Text)
import qualified Data.Text as T
import GHC.Generics (Generic)
import Network.HTTP.Client (Manager, Request (..), Response (..), httpLbs)
import Network.HTTP.Types.Status (Status (statusCode), ok200)

import LaunchDarkly.AesonCompat (KeyMap)
import LaunchDarkly.Server.Features (Flag, Segment)
import LaunchDarkly.Server.Network.Common (checkAuthorization, handleUnauthorized, isHttpUnrecoverable, tryHTTP)

import Data.ByteString.Lazy (ByteString)
import GHC.Natural (Natural)
import LaunchDarkly.Server.Client.Internal (Status (..))
import LaunchDarkly.Server.Config.ClientContext
import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration (..), prepareRequest)
import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates (..))

data PollingResponse = PollingResponse
    { PollingResponse -> KeyMap Flag
flags :: !(KeyMap Flag)
    , PollingResponse -> KeyMap Segment
segments :: !(KeyMap Segment)
    }
    deriving (forall x. Rep PollingResponse x -> PollingResponse
forall x. PollingResponse -> Rep PollingResponse x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PollingResponse x -> PollingResponse
$cfrom :: forall x. PollingResponse -> Rep PollingResponse x
Generic, Value -> Parser [PollingResponse]
Value -> Parser PollingResponse
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [PollingResponse]
$cparseJSONList :: Value -> Parser [PollingResponse]
parseJSON :: Value -> Parser PollingResponse
$cparseJSON :: Value -> Parser PollingResponse
FromJSON, Int -> PollingResponse -> ShowS
[PollingResponse] -> ShowS
PollingResponse -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [PollingResponse] -> ShowS
$cshowList :: [PollingResponse] -> ShowS
show :: PollingResponse -> String
$cshow :: PollingResponse -> String
showsPrec :: Int -> PollingResponse -> ShowS
$cshowsPrec :: Int -> PollingResponse -> ShowS
Show)

processPoll :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> DataSourceUpdates -> Request -> m Bool
processPoll :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) =>
Manager -> DataSourceUpdates -> Request -> m Bool
processPoll Manager
manager DataSourceUpdates
dataSourceUpdates Request
request =
    forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (forall (m :: * -> *) a.
MonadCatch m =>
m a -> m (Either HttpException a)
tryHTTP forall a b. (a -> b) -> a -> b
$ Request -> Manager -> IO (Response ByteString)
httpLbs Request
request Manager
manager) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        (Left HttpException
err) -> do
            $(logError) (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show HttpException
err)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        (Right Response ByteString
response) ->
            forall (m :: * -> *) body. MonadThrow m => Response body -> m ()
checkAuthorization Response ByteString
response forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) =>
Response ByteString -> m Bool
processResponse Response ByteString
response
  where
    processResponse :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Response ByteString -> m Bool
    processResponse :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) =>
Response ByteString -> m Bool
processResponse Response ByteString
response
        | Int -> Bool
isHttpUnrecoverable forall a b. (a -> b) -> a -> b
$ Status -> Int
statusCode forall a b. (a -> b) -> a -> b
$ forall body. Response body -> Status
responseStatus Response ByteString
response = do
            $(logError) Text
"polling stopping after receiving unrecoverable error"
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
        | forall body. Response body -> Status
responseStatus Response ByteString
response forall a. Eq a => a -> a -> Bool
/= Status
ok200 = do
            $(logError) Text
"unexpected polling status code"
            forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        | Bool
otherwise = case (forall a. FromJSON a => ByteString -> Either String a
eitherDecode (forall body. Response body -> body
responseBody Response ByteString
response) :: Either String PollingResponse) of
            (Left String
err) -> do
                $(logError) (String -> Text
T.pack forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show String
err)
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool
True
            (Right PollingResponse
body) -> do
                Either Text ()
status <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DataSourceUpdates
-> KeyMap Flag -> KeyMap Segment -> IO (Either Text ())
dataSourceUpdatesInit DataSourceUpdates
dataSourceUpdates (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"flags" PollingResponse
body) (forall (f :: Symbol) a s. HasField' f s a => s -> a
getField @"segments" PollingResponse
body)
                case Either Text ()
status of
                    Right () -> do
                        forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ DataSourceUpdates -> Status -> IO ()
dataSourceUpdatesSetStatus DataSourceUpdates
dataSourceUpdates Status
Initialized
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool
True
                    Left Text
err -> do
                        $(logError) forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text
T.append Text
"store failed put: " Text
err
                        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bool
True

pollingThread :: (MonadIO m, MonadLogger m, MonadMask m) => Text -> Natural -> ClientContext -> DataSourceUpdates -> m ()
pollingThread :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadMask m) =>
Text -> Natural -> ClientContext -> DataSourceUpdates -> m ()
pollingThread Text
baseURI Natural
pollingIntervalSeconds ClientContext
clientContext DataSourceUpdates
dataSourceUpdates = do
    let pollingMicroseconds :: Int
pollingMicroseconds = forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
pollingIntervalSeconds forall a. Num a => a -> a -> a
* Int
1000000
    Request
req <- forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadThrow m =>
HttpConfiguration -> String -> m Request
prepareRequest (ClientContext -> HttpConfiguration
httpConfiguration ClientContext
clientContext) (Text -> String
T.unpack Text
baseURI forall a. [a] -> [a] -> [a]
++ String
"/sdk/latest-all")
    forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadCatch m) =>
DataSourceUpdates -> m () -> m ()
handleUnauthorized DataSourceUpdates
dataSourceUpdates forall a b. (a -> b) -> a -> b
$ (forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadMask m) =>
Request -> Int -> m ()
poll Request
req Int
pollingMicroseconds)
  where
    poll :: (MonadIO m, MonadLogger m, MonadMask m) => Request -> Int -> m ()
    poll :: forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadMask m) =>
Request -> Int -> m ()
poll Request
req Int
pollingMicroseconds = do
        $(logInfo) Text
"starting poll"
        forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) =>
Manager -> DataSourceUpdates -> Request -> m Bool
processPoll (HttpConfiguration -> Manager
tlsManager forall a b. (a -> b) -> a -> b
$ ClientContext -> HttpConfiguration
httpConfiguration ClientContext
clientContext) DataSourceUpdates
dataSourceUpdates Request
req forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Bool
True -> do
                forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
pollingMicroseconds
                forall (m :: * -> *).
(MonadIO m, MonadLogger m, MonadMask m) =>
Request -> Int -> m ()
poll Request
req Int
pollingMicroseconds
            Bool
False -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()