diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,10 @@ All notable changes to the LaunchDarkly Haskell Server-side SDK will be documented in this file. This project adheres to [Semantic Versioning](http://semver.org). +## [3.1.0] - 2023-01-27 +### Added: +- New `ApplicationInfo` type, for configuration of application metadata that may be used in LaunchDarkly analytics or other product features. This does not affect feature flag evaluations. + ## [3.0.4] - 2023-01-09 ### Changed: - Expanded upper version to allow `aeson-2.1`. (Thanks, [vrom911](https://github.com/launchdarkly/haskell-server-sdk/pull/49)) diff --git a/launchdarkly-server-sdk.cabal b/launchdarkly-server-sdk.cabal --- a/launchdarkly-server-sdk.cabal +++ b/launchdarkly-server-sdk.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: launchdarkly-server-sdk -version: 3.0.4 +version: 3.1.0 synopsis: Server-side SDK for integrating with LaunchDarkly description: Please see the README on GitHub at category: Web @@ -131,6 +131,7 @@ main-is: Spec.hs other-modules: Spec.Bucket + Spec.Config Spec.DataSource Spec.Evaluate Spec.Features diff --git a/src/LaunchDarkly/AesonCompat.hs b/src/LaunchDarkly/AesonCompat.hs --- a/src/LaunchDarkly/AesonCompat.hs +++ b/src/LaunchDarkly/AesonCompat.hs @@ -15,6 +15,9 @@ #if MIN_VERSION_aeson(2,0,0) type KeyMap = KeyMap.KeyMap +null :: KeyMap v -> Bool +null = KeyMap.null + emptyObject :: KeyMap v emptyObject = KeyMap.empty @@ -64,10 +67,13 @@ mapMaybeValues = KeyMap.mapMaybe keyMapUnion :: KeyMap.KeyMap v -> KeyMap.KeyMap v -> KeyMap.KeyMap v -keyMapUnion = KeyMap.union +keyMapUnion = KeyMap.union #else type KeyMap = HM.HashMap T.Text +null :: KeyMap v -> Bool +null = HM.null + emptyObject :: KeyMap v emptyObject = HM.empty @@ -117,5 +123,5 @@ mapMaybeValues = HM.mapMaybe keyMapUnion :: HM.HashMap T.Text v -> HM.HashMap T.Text v -> HM.HashMap T.Text v -keyMapUnion = HM.union +keyMapUnion = HM.union #endif diff --git a/src/LaunchDarkly/Server.hs b/src/LaunchDarkly/Server.hs --- a/src/LaunchDarkly/Server.hs +++ b/src/LaunchDarkly/Server.hs @@ -24,6 +24,10 @@ , configSetStoreTTL , configSetUseLdd , configSetDataSourceFactory + , configSetApplicationInfo + , ApplicationInfo + , makeApplicationInfo + , withApplicationValue , User , makeUser , userSetKey diff --git a/src/LaunchDarkly/Server/Client.hs b/src/LaunchDarkly/Server/Client.hs --- a/src/LaunchDarkly/Server/Client.hs +++ b/src/LaunchDarkly/Server/Client.hs @@ -54,7 +54,7 @@ import LaunchDarkly.Server.Client.Status (Status(..)) import LaunchDarkly.Server.Config.ClientContext (ClientContext(..)) import LaunchDarkly.Server.Config.HttpConfiguration (HttpConfiguration(..)) -import LaunchDarkly.Server.Config.Internal (ConfigI, Config(..), shouldSendEvents) +import LaunchDarkly.Server.Config.Internal (ConfigI, Config(..), shouldSendEvents, getApplicationInfoHeader, ApplicationInfo) import LaunchDarkly.Server.DataSource.Internal (DataSource(..), DataSourceFactory, DataSourceUpdates(..), defaultDataSourceUpdates, nullDataSourceFactory) import LaunchDarkly.Server.Details (EvaluationDetail(..), EvaluationReason(..), EvalErrorKind(..)) import LaunchDarkly.Server.Evaluate (evaluateTyped, evaluateDetail) @@ -66,8 +66,10 @@ import LaunchDarkly.Server.Store.Internal (makeStoreIO, getAllFlagsC) import LaunchDarkly.Server.User.Internal (User(..), userSerializeRedacted) import LaunchDarkly.AesonCompat (KeyMap, insertKey, emptyObject, mapValues, filterObject) - +import Data.ByteString (ByteString) +import Network.HTTP.Types (HeaderName) + networkDataSourceFactory :: (ClientContext -> DataSourceUpdates -> LoggingT IO ()) -> DataSourceFactory networkDataSourceFactory threadF clientContext dataSourceUpdates = do initialized <- liftIO $ newIORef False @@ -91,11 +93,18 @@ makeHttpConfiguration :: ConfigI -> IO HttpConfiguration makeHttpConfiguration config = do tlsManager <- newManager tlsManagerSettings - let defaultRequestHeaders = [ ("Authorization", encodeUtf8 $ getField @"key" config) - , ("User-Agent" , "HaskellServerClient/" <> encodeUtf8 clientVersion) - ] + let headers = [ ("Authorization", encodeUtf8 $ getField @"key" config) + , ("User-Agent" , "HaskellServerClient/" <> encodeUtf8 clientVersion) + ] + defaultRequestHeaders = addTagsHeader headers (getField @"applicationInfo" config) defaultRequestTimeout = Http.responseTimeoutMicro $ fromIntegral $ getField @"requestTimeoutSeconds" config * 1000000 pure $ HttpConfiguration{..} + where + addTagsHeader :: [(HeaderName, ByteString)] -> Maybe ApplicationInfo -> [(HeaderName, ByteString)] + addTagsHeader headers Nothing = headers + addTagsHeader headers (Just info) = case getApplicationInfoHeader info of + Nothing -> headers + Just header -> ("X-LaunchDarkly-Tags", encodeUtf8 header) : headers makeClientContext :: ConfigI -> IO ClientContext makeClientContext config = do @@ -119,7 +128,7 @@ dataSource <- dataSourceFactory config clientContext dataSourceUpdates eventThreadPair <- if not (shouldSendEvents config) then pure Nothing else do sync <- newEmptyMVar - thread <- forkFinally (runLogger clientContext $ eventThread manager client) (\_ -> putMVar sync ()) + thread <- forkFinally (runLogger clientContext $ eventThread manager client clientContext) (\_ -> putMVar sync ()) pure $ pure (thread, sync) dataSourceStart dataSource diff --git a/src/LaunchDarkly/Server/Client/Internal.hs b/src/LaunchDarkly/Server/Client/Internal.hs --- a/src/LaunchDarkly/Server/Client/Internal.hs +++ b/src/LaunchDarkly/Server/Client/Internal.hs @@ -27,7 +27,7 @@ -- | The version string for this library. clientVersion :: Text -clientVersion = "3.0.4" +clientVersion = "3.1.0" setStatus :: ClientI -> Status -> IO () setStatus client status' = diff --git a/src/LaunchDarkly/Server/Config.hs b/src/LaunchDarkly/Server/Config.hs --- a/src/LaunchDarkly/Server/Config.hs +++ b/src/LaunchDarkly/Server/Config.hs @@ -24,23 +24,26 @@ , configSetStoreTTL , configSetUseLdd , configSetDataSourceFactory + , configSetApplicationInfo + , ApplicationInfo + , makeApplicationInfo + , withApplicationValue ) where import Control.Monad.Logger (LoggingT, runStdoutLoggingT) import Data.Generics.Product (setField) import Data.Set (Set) import Data.Text (Text, dropWhileEnd) -import Data.Monoid (mempty) import GHC.Natural (Natural) import Network.HTTP.Client (Manager) -import LaunchDarkly.Server.Config.Internal (Config(..), mapConfig, ConfigI(..)) +import LaunchDarkly.Server.Config.Internal (Config(..), mapConfig, ConfigI(..), ApplicationInfo, makeApplicationInfo, withApplicationValue) import LaunchDarkly.Server.Store (StoreInterface) import LaunchDarkly.Server.DataSource.Internal (DataSourceFactory) -- | Create a default configuration from a given SDK key. makeConfig :: Text -> Config -makeConfig key = +makeConfig key = Config $ ConfigI { key = key , baseURI = "https://app.launchdarkly.com" @@ -61,8 +64,9 @@ , offline = False , requestTimeoutSeconds = 30 , useLdd = False - , dataSourceFactory = Nothing + , dataSourceFactory = Nothing , manager = Nothing + , applicationInfo = Nothing } -- | Set the SDK key used to authenticate with LaunchDarkly. @@ -161,7 +165,7 @@ configSetUseLdd :: Bool -> Config -> Config configSetUseLdd = mapConfig . setField @"useLdd" --- | Sets a data source to use instead of the default network based data source +-- | Sets a data source to use instead of the default network based data source -- see "LaunchDarkly.Server.Integrations.FileData" configSetDataSourceFactory :: Maybe DataSourceFactory -> Config -> Config configSetDataSourceFactory = mapConfig . setField @"dataSourceFactory" @@ -170,3 +174,13 @@ -- 'Manager' will be created when creating the client. configSetManager :: Manager -> Config -> Config configSetManager = mapConfig . setField @"manager" . Just + +-- | An object that allows configuration of application metadata. +-- +-- Application metadata may be used in LaunchDarkly analytics or other product +-- features, but does not affect feature flag evaluations. +-- +-- If you want to set non-default values for any of these fields, provide the +-- appropriately configured dict to the 'Config' object. +configSetApplicationInfo :: ApplicationInfo -> Config -> Config +configSetApplicationInfo = mapConfig . setField @"applicationInfo" . Just diff --git a/src/LaunchDarkly/Server/Config/Internal.hs b/src/LaunchDarkly/Server/Config/Internal.hs --- a/src/LaunchDarkly/Server/Config/Internal.hs +++ b/src/LaunchDarkly/Server/Config/Internal.hs @@ -3,11 +3,16 @@ , mapConfig , ConfigI(..) , shouldSendEvents + , ApplicationInfo + , makeApplicationInfo + , withApplicationValue + , getApplicationInfoHeader ) where import Control.Monad.Logger (LoggingT) import Data.Generics.Product (getField) import Data.Text (Text) +import qualified Data.Text as T import Data.Set (Set) import GHC.Natural (Natural) import GHC.Generics (Generic) @@ -15,6 +20,11 @@ import LaunchDarkly.Server.Store (StoreInterface) import LaunchDarkly.Server.DataSource.Internal (DataSourceFactory) +import LaunchDarkly.AesonCompat (KeyMap, insertKey, emptyObject, toList) +import qualified LaunchDarkly.AesonCompat as AesonCompat +import Data.List (sortBy) +import Control.Lens ((&)) +import Data.Ord (comparing) mapConfig :: (ConfigI -> ConfigI) -> Config -> Config mapConfig f (Config c) = Config $ f c @@ -47,4 +57,43 @@ , useLdd :: !Bool , dataSourceFactory :: !(Maybe DataSourceFactory) , manager :: !(Maybe Manager) + , applicationInfo :: !(Maybe ApplicationInfo) } deriving (Generic) + +-- | An object that allows configuration of application metadata. +-- +-- Application metadata may be used in LaunchDarkly analytics or other product +-- features, but does not affect feature flag evaluations. +-- +-- To use these properties, provide an instance of ApplicationInfo to the 'Config' with 'configSetApplicationInfo'. +newtype ApplicationInfo = ApplicationInfo (KeyMap Text) deriving (Show, Eq) + +-- | Create a default instance +makeApplicationInfo :: ApplicationInfo +makeApplicationInfo = ApplicationInfo emptyObject + +-- | Set a new name / value pair into the application info instance. +-- +-- Values have the following restrictions: +-- - Cannot be empty +-- - Cannot exceed 64 characters in length +-- - Can only contain a-z, A-Z, 0-9, period (.), dash (-), and underscore (_). +-- +-- Invalid values or unsupported keys will be ignored. +withApplicationValue :: Text -> Text -> ApplicationInfo -> ApplicationInfo +withApplicationValue _ "" info = info +withApplicationValue name value info@(ApplicationInfo map) + | (name `elem` ["id", "version"]) == False = info + | T.length(value) > 64 = info + | (all (`elem` ['a'..'z'] ++ ['A' .. 'Z'] ++ ['0' .. '9'] ++ ['.', '-', '_']) (T.unpack value)) == False = info + | otherwise = ApplicationInfo $ insertKey name value map + +getApplicationInfoHeader :: ApplicationInfo -> Maybe Text +getApplicationInfoHeader (ApplicationInfo values) + | AesonCompat.null values = Nothing + | otherwise = toList values + & sortBy (comparing fst) + & map makeTag + & T.unwords + & Just + where makeTag (key, value) = "application-" <> key <> "/" <> value diff --git a/src/LaunchDarkly/Server/Network/Common.hs b/src/LaunchDarkly/Server/Network/Common.hs --- a/src/LaunchDarkly/Server/Network/Common.hs +++ b/src/LaunchDarkly/Server/Network/Common.hs @@ -1,32 +1,26 @@ module LaunchDarkly.Server.Network.Common - ( prepareRequest - , withResponseGeneric + ( withResponseGeneric , tryAuthorized , checkAuthorization , getServerTime , tryHTTP , addToAL - , handleUnauthorized + , handleUnauthorized ) where -import Data.ByteString (append) import Data.ByteString.Internal (unpackChars) -import Network.HTTP.Client (HttpException, Manager, Request(..), Response(..), BodyReader, setRequestIgnoreStatus, responseOpen, responseTimeout, responseTimeoutMicro, responseClose) +import Network.HTTP.Client (HttpException, Manager, Request(..), Response(..), BodyReader, responseOpen, responseClose) import Network.HTTP.Types.Header (hDate) import Network.HTTP.Types.Status (unauthorized401, forbidden403) -import Data.Generics.Product (getField) -import Data.Text.Encoding (encodeUtf8) import Data.Time.Format (parseTimeM, defaultTimeLocale, rfc822DateFormat) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) -import Data.Function ((&)) import Data.Maybe (fromMaybe) import Control.Monad (when) import Control.Monad.Catch (Exception, MonadCatch, MonadMask, MonadThrow, try, bracket, throwM, handle) import Control.Monad.Logger (MonadLogger, logError) import Control.Monad.IO.Class (MonadIO, liftIO) -import LaunchDarkly.Server.Client.Internal (ClientI, Status(Unauthorized), clientVersion, setStatus) -import LaunchDarkly.Server.Config.Internal (ConfigI) +import LaunchDarkly.Server.Client.Internal (ClientI, Status(Unauthorized), setStatus) import LaunchDarkly.Server.DataSource.Internal (DataSourceUpdates(..)) tryHTTP :: MonadCatch m => m a -> m (Either HttpException a) @@ -34,14 +28,6 @@ addToAL :: Eq k => [(k, v)] -> k -> v -> [(k, v)] addToAL l k v = (k, v) : filter ((/=) k . fst) l - -prepareRequest :: ConfigI -> Request -> Request -prepareRequest config request = request - { requestHeaders = (requestHeaders request) - & \l -> addToAL l "Authorization" (encodeUtf8 $ getField @"key" config) - & \l -> addToAL l "User-Agent" (append "HaskellServerClient/" $ encodeUtf8 clientVersion) - , responseTimeout = responseTimeoutMicro $ (fromIntegral $ getField @"requestTimeoutSeconds" config) * 1000000 - } & setRequestIgnoreStatus withResponseGeneric :: (MonadIO m, MonadMask m) => Request -> Manager -> (Response BodyReader -> m a) -> m a withResponseGeneric req man f = bracket (liftIO $ responseOpen req man) (liftIO . responseClose) f diff --git a/src/LaunchDarkly/Server/Network/Eventing.hs b/src/LaunchDarkly/Server/Network/Eventing.hs --- a/src/LaunchDarkly/Server/Network/Eventing.hs +++ b/src/LaunchDarkly/Server/Network/Eventing.hs @@ -7,7 +7,7 @@ import qualified Data.UUID as UUID import Control.Monad.Logger (MonadLogger, logDebug, logWarn, logError) import Control.Monad.IO.Class (MonadIO, liftIO) -import Network.HTTP.Client (Manager, Request(..), RequestBody(..), httpLbs, parseRequest, responseStatus) +import Network.HTTP.Client (Manager, Request(..), RequestBody(..), httpLbs, responseStatus) import Data.Generics.Product (getField) import qualified Data.Text as T import Control.Concurrent (killThread, myThreadId) @@ -21,8 +21,10 @@ import Network.HTTP.Types.Status (status400, status408, status429, status500) import LaunchDarkly.Server.Client.Internal (ClientI, Status(ShuttingDown)) -import LaunchDarkly.Server.Network.Common (tryAuthorized, checkAuthorization, getServerTime, prepareRequest, tryHTTP, addToAL) +import LaunchDarkly.Server.Network.Common (tryAuthorized, checkAuthorization, getServerTime, tryHTTP, addToAL) import LaunchDarkly.Server.Events (processSummary, EventState) +import LaunchDarkly.Server.Config.ClientContext +import LaunchDarkly.Server.Config.HttpConfiguration (prepareRequest) -- A true result indicates a retry does not need to be attempted processSend :: (MonadIO m, MonadLogger m, MonadMask m, MonadThrow m) => Manager -> Request -> m (Bool, Integer) @@ -50,11 +52,11 @@ updateLastKnownServerTime :: EventState -> Integer -> IO () updateLastKnownServerTime state serverTime = modifyMVar_ (getField @"lastKnownServerTime" state) (\lastKnown -> pure $ max serverTime lastKnown) -eventThread :: (MonadIO m, MonadLogger m, MonadMask m) => Manager -> ClientI -> m () -eventThread manager client = do - let state = getField @"events" client; config = getField @"config" client; +eventThread :: (MonadIO m, MonadLogger m, MonadMask m) => Manager -> ClientI -> ClientContext -> m () +eventThread manager client clientContext = do + let state = getField @"events" client; config = getField @"config" client; httpConfig = httpConfiguration clientContext rngRef <- liftIO $ newStdGen >>= newIORef - req <- (liftIO $ parseRequest $ (T.unpack $ getField @"eventsURI" config) ++ "/bulk") >>= pure . setEventHeaders . prepareRequest config + req <- (liftIO $ prepareRequest httpConfig $ (T.unpack $ getField @"eventsURI" config) ++ "/bulk") >>= pure . setEventHeaders void $ tryAuthorized client $ forever $ do liftIO $ processSummary config state events' <- liftIO $ swapMVar (getField @"events" state) [] diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,6 +4,7 @@ import Test.HUnit (runTestTT, Test(TestList, TestLabel)) import qualified Spec.Bucket +import qualified Spec.Config import qualified Spec.Evaluate import qualified Spec.Features import qualified Spec.Operators @@ -21,6 +22,7 @@ main :: IO () main = void $ runTestTT $ TestList [ Spec.Bucket.allTests + , Spec.Config.allTests , Spec.Evaluate.allTests , Spec.Features.allTests , Spec.Operators.allTests diff --git a/test/Spec/Config.hs b/test/Spec/Config.hs new file mode 100644 --- /dev/null +++ b/test/Spec/Config.hs @@ -0,0 +1,51 @@ +module Spec.Config (allTests) where +import Test.HUnit +import LaunchDarkly.Server (makeApplicationInfo) +import LaunchDarkly.Server.Config.Internal (makeApplicationInfo, withApplicationValue, getApplicationInfoHeader) +import Control.Lens ((&)) + +testEmptyApplicationInfoGeneratesNoHeader :: Test +testEmptyApplicationInfoGeneratesNoHeader = TestCase $ do + assertEqual "" Nothing $ getApplicationInfoHeader $ makeApplicationInfo + +testEmptyApplicationInfoIgnoresInvalidKeys :: Test +testEmptyApplicationInfoIgnoresInvalidKeys = TestCase $ do + assertEqual "" emptyInfo modified + + where + + emptyInfo = makeApplicationInfo + modified = withApplicationValue "invalid-key" "value" emptyInfo + & withApplicationValue "another-invalid-key" "value" + +testEmptyApplicationInfoIgnoresInvalidValues :: Test +testEmptyApplicationInfoIgnoresInvalidValues = TestCase $ do + assertEqual "" emptyInfo modified + + where + + emptyInfo = makeApplicationInfo + modified = withApplicationValue "id" " " emptyInfo + & withApplicationValue "id" "&" + & withApplicationValue "id" "abcdefghijklmnopqrstuvwxyzABCDEFGHIJKLMNOPQRSTUVWXYZ0123456789._-a" + +testCorrectlyGeneratesHeaderText :: Test +testCorrectlyGeneratesHeaderText = TestCase $ do + assertEqual "" (Just "application-id/my-id application-version/my-version") value + assertEqual "" (Just "application-id/my-id application-version/my-version") ignoreError + + where + + info = makeApplicationInfo + & withApplicationValue "id" "my-id" + & withApplicationValue "version" "my-version" + value = getApplicationInfoHeader info + ignoreError = withApplicationValue "version" "should-ignore-@me" info & getApplicationInfoHeader + +allTests :: Test +allTests = TestList + [ testEmptyApplicationInfoGeneratesNoHeader + , testEmptyApplicationInfoIgnoresInvalidKeys + , testEmptyApplicationInfoIgnoresInvalidValues + , testCorrectlyGeneratesHeaderText + ]