diff --git a/.circleci/config.yml b/.circleci/config.yml index 55b2c94..bb8da0b 100644 --- a/.circleci/config.yml +++ b/.circleci/config.yml @@ -28,8 +28,13 @@ jobs: name: Resolve/Update Dependencies command: stack --no-terminal setup - run: - name: Build + name: Build library command: stack --no-terminal build + - run: + name: Build Redis store + command: | + cd ./stores/launchdarkly-server-sdk-redis/ + stack --no-terminal build - run: name: Install and run hlint command: @@ -143,7 +148,7 @@ jobs: command: | cd .. cabal update - cabal install hpack-0.35.0 + cabal install hpack-0.35.1 cd - - run: name: Verify the generated .cabal file is up-to-date diff --git a/.ldrelease/config.yml b/.ldrelease/config.yml index 02a8c3f..3dda34c 100644 --- a/.ldrelease/config.yml +++ b/.ldrelease/config.yml @@ -4,6 +4,10 @@ repo: public: haskell-server-sdk private: haskell-server-sdk-private +branches: + - name: main + - name: 3.x + jobs: # Have no fear! This is the officially sanctioned image as seen at # https://docs.haskellstack.org/en/stable/docker_integration/#image-repositories diff --git a/src/LaunchDarkly/Server/Network/Common.hs b/src/LaunchDarkly/Server/Network/Common.hs index b03154a..8ce9d78 100644 --- a/src/LaunchDarkly/Server/Network/Common.hs +++ b/src/LaunchDarkly/Server/Network/Common.hs @@ -6,6 +6,7 @@ module LaunchDarkly.Server.Network.Common , tryHTTP , addToAL , handleUnauthorized + , isHttpUnrecoverable ) where import Data.ByteString.Internal (unpackChars) @@ -56,3 +57,9 @@ getServerTime response where headers = responseHeaders response date = fromMaybe "" $ lookup hDate headers parsedTime = parseTimeM True defaultTimeLocale rfc822DateFormat (unpackChars date) + +isHttpUnrecoverable :: Int -> Bool +isHttpUnrecoverable status + | status < 400 || status >= 500 = False + | status `elem` [400, 408, 429] = False + | otherwise = True diff --git a/src/LaunchDarkly/Server/Network/Polling.hs b/src/LaunchDarkly/Server/Network/Polling.hs index 34d9b3b..5535a5a 100644 --- a/src/LaunchDarkly/Server/Network/Polling.hs +++ b/src/LaunchDarkly/Server/Network/Polling.hs @@ -5,15 +5,14 @@ import Data.Text (Text) import qualified Data.Text as T import Network.HTTP.Client (Manager, Request(..), Response(..), httpLbs) import Data.Generics.Product (getField) -import Control.Monad (forever) import Control.Concurrent (threadDelay) import Data.Aeson (eitherDecode, FromJSON(..)) import Control.Monad.Logger (MonadLogger, logInfo, logError) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Catch (MonadMask, MonadThrow) -import Network.HTTP.Types.Status (ok200) +import Network.HTTP.Types.Status (ok200, Status (statusCode)) -import LaunchDarkly.Server.Network.Common (checkAuthorization, tryHTTP, handleUnauthorized) +import LaunchDarkly.Server.Network.Common (checkAuthorization, tryHTTP, handleUnauthorized, isHttpUnrecoverable) import LaunchDarkly.Server.Features (Flag, Segment) import LaunchDarkly.AesonCompat (KeyMap) @@ -23,33 +22,60 @@ import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates(..)) import LaunchDarkly.Server.Config.ClientContext import LaunchDarkly.Server.Client.Internal (Status(..)) import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration(..), prepareRequest) +import Data.ByteString.Lazy (ByteString) data PollingResponse = PollingResponse { flags :: !(KeyMap Flag) , segments :: !(KeyMap Segment) } deriving (Generic, FromJSON, Show) -processPoll :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> DataSourceUpdates -> Request -> m () +processPoll :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> DataSourceUpdates -> Request -> m Bool processPoll manager dataSourceUpdates request = liftIO (tryHTTP $ httpLbs request manager) >>= \case - (Left err) -> $(logError) (T.pack $ show err) - (Right response) -> checkAuthorization response >> if responseStatus response /= ok200 - then $(logError) "unexpected polling status code" - else case (eitherDecode (responseBody response) :: Either String PollingResponse) of - (Left err) -> $(logError) (T.pack $ show err) + (Left err) -> do + $(logError) (T.pack $ show err) + pure True + (Right response) -> checkAuthorization response >> processResponse response + + where + + processResponse :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Response ByteString -> m Bool + processResponse response + | isHttpUnrecoverable $ statusCode $ responseStatus response = do + $(logError) "polling stopping after receiving unrecoverable error" + pure False + | responseStatus response /= ok200 = do + $(logError) "unexpected polling status code" + pure True + | otherwise = case (eitherDecode (responseBody response) :: Either String PollingResponse) of + (Left err) -> do + $(logError) (T.pack $ show err) + pure $ True (Right body) -> do status <- liftIO $ dataSourceUpdatesInit dataSourceUpdates (getField @"flags" body) (getField @"segments" body) case status of - Right () -> liftIO $ dataSourceUpdatesSetStatus dataSourceUpdates Initialized - Left err -> + Right () -> do + liftIO $ dataSourceUpdatesSetStatus dataSourceUpdates Initialized + pure $ True + Left err -> do $(logError) $ T.append "store failed put: " err + pure $ True + + pollingThread :: (MonadIO m, MonadLogger m, MonadMask m) => Text -> Natural -> ClientContext -> DataSourceUpdates -> m () pollingThread baseURI pollingIntervalSeconds clientContext dataSourceUpdates = do let pollingMicroseconds = fromIntegral pollingIntervalSeconds * 1000000 - req <- liftIO $ prepareRequest (httpConfiguration clientContext) (T.unpack baseURI ++ "/sdk/latest-all") - handleUnauthorized dataSourceUpdates $ forever $ do + req <- liftIO $ prepareRequest (httpConfiguration clientContext) (T.unpack baseURI ++ "/sdk/latest-all") + handleUnauthorized dataSourceUpdates $ (poll req pollingMicroseconds) + + where + + poll :: (MonadIO m, MonadLogger m, MonadMask m) => Request -> Int -> m () + poll req pollingMicroseconds = do $(logInfo) "starting poll" - processPoll (tlsManager $ httpConfiguration clientContext) dataSourceUpdates req - $(logInfo) "finished poll" - liftIO $ threadDelay pollingMicroseconds + processPoll (tlsManager $ httpConfiguration clientContext) dataSourceUpdates req >>= \case + True -> do + liftIO $ threadDelay pollingMicroseconds + poll req pollingMicroseconds + False -> pure () diff --git a/stack.yaml b/stack.yaml deleted file mode 100644 index a759242..0000000 --- a/stack.yaml +++ /dev/null @@ -1,4 +0,0 @@ -resolver: lts-14.1 - -packages: -- . diff --git a/stack.yaml b/stack.yaml new file mode 120000 index 0000000..f3454cf --- /dev/null +++ b/stack.yaml @@ -0,0 +1 @@ +stack-14.1.yaml \ No newline at end of file diff --git a/stores/launchdarkly-server-sdk-redis/package.yaml b/stores/launchdarkly-server-sdk-redis/package.yaml index a9d9f42..df63102 100644 --- a/stores/launchdarkly-server-sdk-redis/package.yaml +++ b/stores/launchdarkly-server-sdk-redis/package.yaml @@ -1,5 +1,5 @@ name: launchdarkly-server-sdk-redis -version: 0.1.0 +version: 0.1.1 github: "launchdarkly/haskell-server-sdk" license: Apache-2.0 license-file: "LICENSE" @@ -13,15 +13,15 @@ category: Web description: Please see the README on GitHub at dependencies: -- aeson >=1.4.4.0 && <1.5 +- aeson >=1.4.4.0 && <1.6 || >= 2.0.1.0 && <2.2 - base >=4.7 && <5 -- bytestring >=0.10.8.2 && <0.11 +- bytestring >=0.10.8.2 && <0.12 - bytestring-conversion >=0.3.1 && <0.4 - exceptions >=0.10.2 && <0.11 -- generic-lens >=1.1.0.0 && <1.2 -- hedis >=0.12.7 && <0.13 +- generic-lens >=1.1.0.0 && <2.3 +- hedis >=0.12.7 && <0.16 - launchdarkly-server-sdk >=1.0.0 && <4.0.0 -- text >=1.2.3.1 && <1.3 +- text >=1.2.3.1 && <2.1 - unordered-containers >=0.2.10.0 && <0.3 default-extensions: diff --git a/stores/launchdarkly-server-sdk-redis/stack-lts-14.1.yaml b/stores/launchdarkly-server-sdk-redis/stack-lts-14.1.yaml new file mode 100644 index 0000000..79104a8 --- /dev/null +++ b/stores/launchdarkly-server-sdk-redis/stack-lts-14.1.yaml @@ -0,0 +1,7 @@ +resolver: lts-14.1 + +packages: +- . + +extra-deps: +- ../../ diff --git a/stores/launchdarkly-server-sdk-redis/stack-lts-16.31.yaml b/stores/launchdarkly-server-sdk-redis/stack-lts-16.31.yaml new file mode 100644 index 0000000..fc64ee1 --- /dev/null +++ b/stores/launchdarkly-server-sdk-redis/stack-lts-16.31.yaml @@ -0,0 +1,7 @@ +resolver: lts-16.31 + +packages: +- . + +extra-deps: +- ../../ diff --git a/stores/launchdarkly-server-sdk-redis/stack-lts-18.27.yaml b/stores/launchdarkly-server-sdk-redis/stack-lts-18.27.yaml new file mode 100644 index 0000000..9cc47d5 --- /dev/null +++ b/stores/launchdarkly-server-sdk-redis/stack-lts-18.27.yaml @@ -0,0 +1,7 @@ +resolver: lts-18.27 + +packages: +- . + +extra-deps: +- ../../ diff --git a/stores/launchdarkly-server-sdk-redis/stack-lts-19.13.yaml b/stores/launchdarkly-server-sdk-redis/stack-lts-19.13.yaml new file mode 100644 index 0000000..72558b5 --- /dev/null +++ b/stores/launchdarkly-server-sdk-redis/stack-lts-19.13.yaml @@ -0,0 +1,7 @@ +resolver: lts-19.13 + +packages: +- . + +extra-deps: +- ../../