diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,10 @@ +# log-elasticsearch-0.11.0.0 (2020-08-24) +* Drop dependency on bloodhound +* Unify V1 and V5 specific modules +* Add support for ElasticSearch 7.x +* Try harder to insert problematic messages into ElasticSearch +* Support building with GHC 8.8.4 and GHC 8.10.2 + # log-elasticsearch-0.10.2.0 (2020-02-03) * Modify data keys in deterministic manner in case of ES insertion failure diff --git a/log-elasticsearch.cabal b/log-elasticsearch.cabal --- a/log-elasticsearch.cabal +++ b/log-elasticsearch.cabal @@ -1,5 +1,5 @@ name: log-elasticsearch -version: 0.10.2.0 +version: 0.11.0.0 synopsis: Structured logging solution (Elasticsearch back end) description: Elasticsearch back end for the 'log' library suite. @@ -18,33 +18,27 @@ build-type: Simple cabal-version: >=1.10 extra-source-files: CHANGELOG.md, README.md -tested-with: GHC == 7.10.3, GHC == 8.0.2, GHC == 8.2.2, GHC == 8.4.4, - GHC == 8.6.5 +tested-with: GHC ==8.0.2 || ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.2 Source-repository head Type: git Location: https://github.com/scrive/log.git library - exposed-modules: Log.Backend.ElasticSearch.V1 - Log.Backend.ElasticSearch.V1.Internal - Log.Backend.ElasticSearch.V1.Lens - Log.Backend.ElasticSearch.V5 - Log.Backend.ElasticSearch.V5.Internal - Log.Backend.ElasticSearch.V5.Lens - Log.Backend.ElasticSearch - Log.Backend.ElasticSearch.Lens + exposed-modules: Log.Backend.ElasticSearch Log.Backend.ElasticSearch.Internal + Log.Backend.ElasticSearch.Lens build-depends: base >= 4.8 && <5, log-base >= 0.7, aeson >=1.0.0.0, aeson-pretty >=0.8.2, bytestring, base64-bytestring, - bloodhound >= 0.13 && < 0.17, deepseq, http-client, http-client-tls, + http-types, + network-uri, semigroups, text, text-show >= 2, @@ -54,7 +48,7 @@ vector hs-source-dirs: src - ghc-options: -O2 -Wall -funbox-strict-fields + ghc-options: -Wall default-language: Haskell2010 default-extensions: BangPatterns @@ -68,5 +62,6 @@ , RankNTypes , RecordWildCards , ScopedTypeVariables + , TupleSections , TypeFamilies , UndecidableInstances diff --git a/src/Log/Backend/ElasticSearch.hs b/src/Log/Backend/ElasticSearch.hs --- a/src/Log/Backend/ElasticSearch.hs +++ b/src/Log/Backend/ElasticSearch.hs @@ -1,5 +1,225 @@ +-- | Elasticsearch logging back-end. module Log.Backend.ElasticSearch - {-# DEPRECATED "Use directly Log.Backend.ElasticSearch.V1 or V5" #-} - ( module Log.Backend.ElasticSearch.V1 ) where + ( ElasticSearchConfig + , esServer + , esIndex + , esShardCount + , esReplicaCount + , esMapping + , esLogin + , esLoginInsecure + , checkElasticSearchLogin + , checkElasticSearchConnection + , defaultElasticSearchConfig + , withElasticSearchLogger + , elasticSearchLogger + ) where -import Log.Backend.ElasticSearch.V1 +import Control.Applicative +import Control.Concurrent +import Control.Exception +import Control.Monad +import Data.Aeson +import Data.Aeson.Encode.Pretty +import Data.IORef +import Data.Maybe +import Data.Semigroup +import Data.Time +import Data.Word +import Log +import Log.Internal.Logger +import Network.HTTP.Client +import Prelude +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Builder as T +import qualified Data.Traversable as F +import qualified Data.Vector as V + +import Log.Backend.ElasticSearch.Internal + +---------------------------------------- +-- | Create an 'elasticSearchLogger' for the duration of the given +-- action, and shut it down afterwards, making sure that all buffered +-- messages are actually written to the Elasticsearch store. +withElasticSearchLogger :: ElasticSearchConfig -> (Logger -> IO r) -> IO r +withElasticSearchLogger conf act = do + logger <- elasticSearchLogger conf + withLogger logger act + +{-# DEPRECATED elasticSearchLogger "Use 'withElasticSearchLogger' instead!" #-} + +-- | Start an asynchronous logger thread that stores messages using +-- Elasticsearch. +-- +-- Please use 'withElasticSearchLogger' instead, which is more +-- exception-safe (see the note attached to 'mkBulkLogger'). +elasticSearchLogger + :: ElasticSearchConfig -- ^ Configuration. + -> IO Logger +elasticSearchLogger esConf@ElasticSearchConfig{..} = do + checkElasticSearchLogin esConf + env <- mkEsEnv esConf + versionRef <- newIORef Nothing + indexRef <- newIORef T.empty + mkBulkLogger "ElasticSearch" (\msgs -> do + now <- getCurrentTime + oldIndex <- readIORef indexRef + retryOnException versionRef $ do + -- We need to consider version of ES because ES >= 5.0.0 and ES >= 7.0.0 + -- have slight differences in parts of API used for logging. + version <- readIORef versionRef >>= \case + Just version -> pure version + Nothing -> serverInfo env >>= \case + Left (ex :: HttpException) -> error + $ "elasticSearchLogger: unexpected error: " + <> show ex + <> " (is ElasticSearch server running?)" + Right reply -> case parseEsVersion $ responseBody reply of + Nothing -> error + $ "elasticSearchLogger: invalid response when parsing version number: " + <> show reply + Just version -> pure version + -- Elasticsearch index names are additionally indexed by date so that each + -- day is logged to a separate index to make log management easier. + let index = T.concat + [ esIndex + , "-" + , T.pack $ formatTime defaultTimeLocale "%F" now + ] + when (oldIndex /= index) $ do + -- There is an obvious race condition in presence of more than one + -- logger instance running, but it's irrelevant as attempting to create + -- index that already exists is harmless. + ixExists <- indexExists env index + unless ixExists $ do + reply <- createIndexWithMapping version env esConf index + unless (isSuccess reply) $ do + printEsError "error while creating index" $ responseBody reply + writeIORef indexRef index + let jsonMsgs = V.fromList $ map (toJsonMsg now) $ zip [1..] msgs + reply <- responseBody <$> bulkIndex version env esConf index jsonMsgs + -- Try to parse parts of reply to get information about log messages that + -- failed to be inserted for some reason. + case checkForBulkErrors jsonMsgs reply of + Nothing -> printEsError "unexpected response" reply + Just (hasErrors, responses) -> when hasErrors $ do + -- If any message failed to be inserted because of type mismatch, go + -- back to them, log the insertion failure and add type suffix to each + -- of the keys in their "data" fields to work around type errors. + let newMsgs = + let modifyData :: Maybe Value -> Value -> Value + modifyData merr (Object hm) = Object $ + let newData = H.foldlWithKey' keyAddValueTypeSuffix H.empty hm + in case merr of + -- We have the error message, i.e. we're at the top + -- level object, so add it to the data. + Just err -> newData `H.union` H.singleton "__es_error" err + Nothing -> newData + modifyData _ v = v + + keyAddValueTypeSuffix acc k v = H.insert + (case v of + Object{} -> k <> "_object" + Array{} -> k <> "_array" + String{} -> k <> "_string" + Number{} -> k <> "_number" + Bool{} -> k <> "_bool" + Null{} -> k <> "_null" + ) (modifyData Nothing v) acc + in adjustFailedMessagesWith modifyData jsonMsgs responses + -- Attempt to put modified messages. + newReply <- responseBody <$> bulkIndex version env esConf index newMsgs + case checkForBulkErrors newMsgs newReply of + Nothing -> printEsError "unexpected response" newReply + Just (newHasErrors, newResponses) -> when newHasErrors $ do + -- If some of the messages failed again (it might happen e.g. if + -- data contains an array with elements of different types), drop + -- their data field. + let newerMsgs = + let modifyData :: Maybe Value -> Value -> Value + modifyData (Just err) Object{} = object [ "__es_error" .= err ] + modifyData _ v = v + in adjustFailedMessagesWith modifyData newMsgs newResponses + -- Ignore any further errors. + void $ bulkIndex version env esConf index newerMsgs) + (refreshIndex env =<< readIORef indexRef) + where + -- Process reply of bulk indexing to get responses for each index operation + -- and check whether any insertion failed. + checkForBulkErrors + :: V.Vector a + -> Value + -> Maybe (Bool, V.Vector Object) + checkForBulkErrors jsonMsgs replyBody = do + Object response <- pure replyBody + Bool hasErrors <- "errors" `H.lookup` response + Array jsonItems <- "items" `H.lookup` response + items <- F.forM jsonItems $ \v -> do + Object item <- pure v + Object index_ <- "index" `H.lookup` item + -- ES <= 2.x returns 'create' for some reason, so consider both. + <|> "create" `H.lookup` item + pure index_ + guard $ V.length items == V.length jsonMsgs + pure (hasErrors, items) + + adjustFailedMessagesWith + :: (Maybe err -> obj -> obj) + -> V.Vector (H.HashMap T.Text obj) + -> V.Vector (H.HashMap T.Text err) + -> V.Vector (H.HashMap T.Text obj) + adjustFailedMessagesWith f jsonMsgs responses = + let failed = V.imapMaybe (\n item -> (n, ) <$> "error" `H.lookup` item) responses + in (`V.map` failed) $ \(n, err) -> H.adjust (f $ Just err) "data" $ jsonMsgs V.! n + + printEsError msg body = + T.putStrLn $ "elasticSearchLogger: " <> msg <> " " <> prettyJson body + + retryOnException :: forall r. IORef (Maybe EsVersion) -> IO r -> IO r + retryOnException versionRef m = try m >>= \case + Left (ex::SomeException) -> do + putStrLn $ "ElasticSearch: unexpected error: " + <> show ex <> ", retrying in 10 seconds" + -- If there was an exception, ElasticSearch version might've changed, so + -- reset it. + writeIORef versionRef Nothing + threadDelay $ 10 * 1000000 + retryOnException versionRef m + Right result -> return result + + prettyJson :: Value -> T.Text + prettyJson = TL.toStrict + . T.toLazyText + . encodePrettyToTextBuilder' defConfig { confIndent = Spaces 2 } + + toJsonMsg :: UTCTime -> (Word32, LogMessage) -> H.HashMap T.Text Value + toJsonMsg now (n, msg) = H.union jMsg $ H.fromList + [ ("insertion_order", toJSON n) + , ("insertion_time", toJSON now) + ] + where + Object jMsg = toJSON msg + +---------------------------------------- + +-- | Check that login credentials are specified properly. +-- +-- @since 0.10.0.0 +checkElasticSearchLogin :: ElasticSearchConfig -> IO () +checkElasticSearchLogin ElasticSearchConfig{..} = + when (isJust esLogin + && not esLoginInsecure + && not ("https:" `T.isPrefixOf` esServer)) $ + error $ "ElasticSearch: insecure login: " + <> "Attempting to send login credentials over an insecure connection. " + <> "Set esLoginInsecure = True to disable this check." + +-- | Check that we can connect to the ES server. +-- +-- @since 0.10.0.0 +checkElasticSearchConnection :: ElasticSearchConfig -> IO (Either HttpException ()) +checkElasticSearchConnection esConf = + fmap (const ()) <$> (serverInfo =<< mkEsEnv esConf) diff --git a/src/Log/Backend/ElasticSearch/Internal.hs b/src/Log/Backend/ElasticSearch/Internal.hs --- a/src/Log/Backend/ElasticSearch/Internal.hs +++ b/src/Log/Backend/ElasticSearch/Internal.hs @@ -1,5 +1,240 @@ +{-# LANGUAGE DeriveGeneric #-} module Log.Backend.ElasticSearch.Internal - {-# DEPRECATED "Use directly Log.Backend.ElasticSearch.V1 or V5" #-} - ( module Log.Backend.ElasticSearch.V1.Internal ) where + ( ElasticSearchConfig(..) + , defaultElasticSearchConfig + -- * ES version + , EsVersion(..) + , parseEsVersion + , esV5, esV7 + -- * ES commands + , serverInfo + , indexExists + , createIndexWithMapping + , bulkIndex + , refreshIndex + -- * ES communication details + , EsEnv(..) + , mkEsEnv + , dispatch + , decodeReply + , isSuccess + ) where -import Log.Backend.ElasticSearch.V1.Internal +import Control.Applicative +import Control.Exception +import Control.Monad +import Data.Aeson +import Data.Ix (inRange) +import Data.Maybe +import Data.Semigroup +import GHC.Generics (Generic) +import Network.HTTP.Client +import Network.HTTP.Types +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Prelude +import qualified Data.ByteString.Builder as BSB +import qualified Data.ByteString.Lazy.Char8 as BSL +import qualified Data.HashMap.Strict as H +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import qualified Data.Vector as V + + +-- | Configuration for the Elasticsearch 'Logger'. See +-- +-- for the explanation of terms. +data ElasticSearchConfig = ElasticSearchConfig + { esServer :: !T.Text -- ^ Elasticsearch server address. + , esIndex :: !T.Text -- ^ Elasticsearch index name. + , esShardCount :: !Int + -- ^ Elasticsearch shard count for the named index. + -- + -- @since 0.10.0.0 + , esReplicaCount :: !Int + -- ^ Elasticsearch replica count for the named index. + -- + -- @since 0.10.0.0 + , esMapping :: !T.Text + -- ^ Elasticsearch mapping name (unused with ES >= 7.0.0) + , esLogin :: Maybe (T.Text, T.Text) + -- ^ Elasticsearch basic authentication username and password. + , esLoginInsecure :: !Bool + -- ^ Allow basic authentication over non-TLS connections. + } deriving (Eq, Show, Generic) + +-- | Sensible defaults for 'ElasticSearchConfig'. +defaultElasticSearchConfig :: ElasticSearchConfig +defaultElasticSearchConfig = ElasticSearchConfig + { esServer = "http://localhost:9200" + , esIndex = "logs" + , esShardCount = 4 + , esReplicaCount = 1 + , esMapping = "log" + , esLogin = Nothing + , esLoginInsecure = False + } + +---------------------------------------- +-- ES communication + +-- Most of the below code is taken from the bloodhound library +-- (https://github.com/bitemyapp/bloodhound). + +data EsVersion = EsVersion !Int !Int !Int + deriving (Eq, Ord) + +parseEsVersion :: Value -> Maybe EsVersion +parseEsVersion js = do + Object props <- pure js + Object version <- "version" `H.lookup` props + String number <- "number" `H.lookup` version + [v1, v2, v3] <- mapM (maybeRead . T.unpack) $ T.splitOn "." number + pure $ EsVersion v1 v2 v3 + where + maybeRead s = do + [(v, "")] <- pure $ reads s + pure v + +-- | Minimum version with split 'string' type. +esV5 :: EsVersion +esV5 = EsVersion 5 0 0 + +-- | Minimum version without mapping types. +esV7 :: EsVersion +esV7 = EsVersion 7 0 0 + +---------------------------------------- + +-- | Check the ElasticSearch server for info. Result can be fed to +-- 'parseEsVersion' to determine version of the server. +serverInfo :: EsEnv -> IO (Either HttpException (Response Value)) +serverInfo env = try $ dispatch env methodGet [] Nothing + +-- | Check that given index exists. +indexExists :: EsEnv -> T.Text -> IO Bool +indexExists env index = + isSuccess <$> dispatch env methodHead [index] Nothing + +-- | Create an index with given mapping. +createIndexWithMapping + :: EsVersion + -> EsEnv + -> ElasticSearchConfig + -> T.Text + -> IO (Response Value) +createIndexWithMapping version env ElasticSearchConfig{..} index = do + dispatch env methodPut [index] . Just . encode $ object + [ "settings" .= object + [ "number_of_shards" .= esShardCount + , "number_of_replicas" .= esReplicaCount + ] + , "mappings" .= if version >= esV7 + then logsMapping + else object [ esMapping .= logsMapping ] + ] + where + logsMapping = object + [ "properties" .= object + [ "insertion_order" .= object + [ "type" .= ("integer"::T.Text) + ] + , "insertion_time" .= object + [ "type" .= ("date"::T.Text) + , "format" .= ("date_time"::T.Text) + ] + , "time" .= object + [ "type" .= ("date"::T.Text) + , "format" .= ("date_time"::T.Text) + ] + , "domain" .= object + [ "type" .= textTy + ] + , "level" .= object + [ "type" .= textTy + ] + , "component" .= object + [ "type" .= textTy + ] + , "message" .= object + [ "type" .= textTy + ] + ] + ] + where + textTy :: T.Text + textTy = if version >= esV5 + then "text" + else "string" + +-- Index multiple log messages. +bulkIndex + :: EsVersion + -> EsEnv + -> ElasticSearchConfig + -> T.Text + -> V.Vector (H.HashMap T.Text Value) + -> IO (Response Value) +bulkIndex version env conf index objs = do + dispatch env methodPost route . Just . BSB.toLazyByteString $ foldMap ixOp objs + where + route = if version >= esV7 + then [index, "_bulk"] + else [index, esMapping conf, "_bulk"] + + ixOp obj = ixCmd + <> BSB.char8 '\n' + <> BSB.lazyByteString (encode $ Object obj) + <> BSB.char8 '\n' + where + ixCmd = BSB.lazyByteString . encode $ object + [ "index" .= object [] + ] + +-- Refresh given index. +refreshIndex :: EsEnv -> T.Text -> IO () +refreshIndex env index = + void $ dispatch env methodPost [index, "_refresh"] Nothing + +---------------------------------------- + +data EsEnv = EsEnv + { envServer :: !T.Text + , envManager :: !Manager + , envRequestHook :: !(Request -> Request) + } + +mkEsEnv :: ElasticSearchConfig -> IO EsEnv +mkEsEnv ElasticSearchConfig{..} = do + envManager <- newManager tlsManagerSettings + let envServer = esServer + envRequestHook = maybe id mkAuthHook esLogin + pure EsEnv{..} + where + mkAuthHook (u, p) = applyBasicAuth (T.encodeUtf8 u) (T.encodeUtf8 p) + +---------------------------------------- + +dispatch :: EsEnv + -> Method + -> [T.Text] + -> Maybe BSL.ByteString + -> IO (Response Value) +dispatch EsEnv{..} dMethod url body = do + initReq <- parseRequest $ T.unpack $ T.intercalate "/" $ envServer : url + let req = envRequestHook . setRequestIgnoreStatus $ initReq + { method = dMethod + , requestBody = RequestBodyLBS $ fromMaybe BSL.empty body + , requestHeaders = ("Content-Type", "application/json") : requestHeaders initReq + } + fmap decodeReply <$> httpLbs req envManager + +decodeReply :: BSL.ByteString -> Value +decodeReply bs = case eitherDecode' bs of + Right js -> js + Left err -> object ["decoding_error" .= err] + +isSuccess :: Response a -> Bool +isSuccess = statusCheck (inRange (200, 299)) + where + statusCheck :: (Int -> Bool) -> Response a -> Bool + statusCheck p = p . statusCode . responseStatus diff --git a/src/Log/Backend/ElasticSearch/Lens.hs b/src/Log/Backend/ElasticSearch/Lens.hs --- a/src/Log/Backend/ElasticSearch/Lens.hs +++ b/src/Log/Backend/ElasticSearch/Lens.hs @@ -1,5 +1,59 @@ +{-# LANGUAGE RankNTypes #-} +-- | Lensified version of "Log.Backend.ElasticSearch". module Log.Backend.ElasticSearch.Lens - {-# DEPRECATED "Use directly Log.Backend.ElasticSearch.V1 or V5" #-} - ( module Log.Backend.ElasticSearch.V1.Lens ) where + ( I.ElasticSearchConfig + , esServer + , esIndex + , esShardCount + , esReplicaCount + , esMapping + , esLogin + , esLoginInsecure + , I.defaultElasticSearchConfig + , I.withElasticSearchLogger + ) where -import Log.Backend.ElasticSearch.V1.Lens +import Prelude +import qualified Data.Text as T +import qualified Log.Backend.ElasticSearch as I + +type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s + +-- | Elasticsearch server address. +esServer :: Lens' I.ElasticSearchConfig T.Text +esServer f esc = (\x -> esc { I.esServer = x }) <$> f (I.esServer esc) +{-# INLINE esServer #-} + +-- | Elasticsearch index name. +esIndex :: Lens' I.ElasticSearchConfig T.Text +esIndex f esc = (\x -> esc { I.esIndex = x }) <$> f (I.esIndex esc) +{-# INLINE esIndex #-} + +-- | Elasticsearch shard count for the named index. +-- +-- @since 0.10.0.0 +esShardCount :: Lens' I.ElasticSearchConfig Int +esShardCount f esc = (\x -> esc { I.esShardCount = x }) <$> f (I.esShardCount esc) +{-# INLINE esShardCount #-} + +-- | Elasticsearch replica count for the named index. +-- +-- @since 0.10.0.0 +esReplicaCount :: Lens' I.ElasticSearchConfig Int +esReplicaCount f esc = (\x -> esc { I.esReplicaCount = x }) <$> f (I.esReplicaCount esc) +{-# INLINE esReplicaCount #-} + +-- | Elasticsearch mapping name. +esMapping :: Lens' I.ElasticSearchConfig T.Text +esMapping f esc = (\x -> esc { I.esMapping = x }) <$> f (I.esMapping esc) +{-# INLINE esMapping #-} + +-- | Elasticsearch basic authentication username and password. +esLogin :: Lens' I.ElasticSearchConfig (Maybe (T.Text, T.Text)) +esLogin f esc = (\x -> esc { I.esLogin = x }) <$> f (I.esLogin esc) +{-# INLINE esLogin #-} + +-- | Allow basic authentication over non-TLS connections. +esLoginInsecure :: Lens' I.ElasticSearchConfig Bool +esLoginInsecure f esc = (\x -> esc { I.esLoginInsecure = x }) <$> f (I.esLoginInsecure esc) +{-# INLINE esLoginInsecure #-} diff --git a/src/Log/Backend/ElasticSearch/V1.hs b/src/Log/Backend/ElasticSearch/V1.hs deleted file mode 100644 --- a/src/Log/Backend/ElasticSearch/V1.hs +++ /dev/null @@ -1,313 +0,0 @@ --- | Elasticsearch logging back-end. -module Log.Backend.ElasticSearch.V1 ( - ElasticSearchConfig - , esServer - , esIndex - , esShardCount - , esReplicaCount - , esMapping - , esLogin - , esLoginInsecure - , checkElasticSearchLogin - , checkElasticSearchConnection - , defaultElasticSearchConfig - , withElasticSearchLogger - , elasticSearchLogger - ) where - -import Control.Applicative -import Control.Arrow (second) -import Control.Concurrent -import Control.Exception -import Control.Monad -import Control.Monad.IO.Class -import Data.Aeson -import Data.Aeson.Encode.Pretty -import Data.Bits -import Data.IORef -import Data.Maybe (isJust) -import Data.Semigroup -import Data.Time -import Data.Time.Clock.POSIX -import Data.Word -import Database.V1.Bloodhound hiding (Status) -import Log -import Log.Internal.Logger -import Network.HTTP.Client -import Network.HTTP.Client.TLS (tlsManagerSettings) -import Prelude -import System.IO -import qualified Data.Aeson.Encoding as Aeson -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.HashMap.Strict as H -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Traversable as F -import qualified Data.Vector as V - -import Log.Backend.ElasticSearch.V1.Internal - ----------------------------------------- --- | Create an 'elasticSearchLogger' for the duration of the given --- action, and shut it down afterwards, making sure that all buffered --- messages are actually written to the Elasticsearch store. -withElasticSearchLogger :: ElasticSearchConfig -> IO Word32 -> (Logger -> IO r) - -> IO r -withElasticSearchLogger conf randGen act = do - logger <- elasticSearchLogger conf randGen - withLogger logger act - -{-# DEPRECATED elasticSearchLogger "Use 'withElasticSearchLogger' instead!" #-} - --- | Start an asynchronous logger thread that stores messages using --- Elasticsearch. --- --- Please use 'withElasticSearchLogger' instead, which is more --- exception-safe (see the note attached to 'mkBulkLogger'). -elasticSearchLogger :: - ElasticSearchConfig -- ^ Configuration. - -> IO Word32 -- ^ Generate a random 32-bit word for use in - -- document IDs. - -> IO Logger -elasticSearchLogger esConf@ElasticSearchConfig{..} genRandomWord = do - - checkElasticSearchLogin esConf >>= \case - Left (ex :: IOException) -> error . show $ ex - Right _ -> return () - - checkElasticSearchConnection esConf >>= \case - Left (ex :: HttpException) -> - hPutStrLn stderr $ - "ElasticSearch: unexpected error: " <> - show ex <> - " (is ElasticSearch server running?)" - Right () -> return () - - indexRef <- newIORef $ IndexName T.empty - mkBulkLogger "ElasticSearch" (\msgs -> do - now <- getCurrentTime - oldIndex <- readIORef indexRef - -- Bloodhound doesn't support letting ES autogenerate IDs, so let's generate - -- them ourselves. An ID of a log message is 12 bytes (4 bytes: random, 4 - -- bytes: current time as epoch, 4 bytes: insertion order) encoded as - -- Base64. This makes eventual collisions practically impossible. - baseID <- (<>) - <$> (littleEndianRep <$> liftIO genRandomWord) - <*> pure (littleEndianRep . floor $ timeToDouble now) - retryOnException . runBH_ esConf $ do - -- Elasticsearch index names are additionally indexed by date so that each - -- day is logged to a separate index to make log management easier. - let index = IndexName $ T.concat [ - esIndex - , "-" - , T.pack $ formatTime defaultTimeLocale "%F" now - ] - when (oldIndex /= index) $ do - -- There is an obvious race condition in the presence of more than one - -- logger instance running, but it's irrelevant as attempting to create - -- index that already exists is harmless. - indexExists' <- indexExists index - unless indexExists' $ do - -- Note that Bloodhound won't let us create index using - -- default settings. - let indexSettings = IndexSettings { - indexShards = ShardCount esShardCount - , indexReplicas = ReplicaCount esReplicaCount - } - void $ createIndex indexSettings index - reply <- putMapping index mapping LogsMapping - when (not $ isSuccess reply) $ do - error $ "ElasticSearch: error while creating mapping: " - <> T.unpack (T.decodeUtf8 . BSL.toStrict . jsonToBSL - $ decodeReply reply) - liftIO $ writeIORef indexRef index - let jsonMsgs = V.fromList $ map (toJsonMsg now) $ zip [1..] msgs - reply <- bulk $ V.map (toBulk index baseID) jsonMsgs - -- Try to parse parts of reply to get information about log messages that - -- failed to be inserted for some reason. - let replyBody = decodeReply reply - result = do - Object response <- return replyBody - Bool hasErrors <- "errors" `H.lookup` response - Array jsonItems <- "items" `H.lookup` response - items <- F.forM jsonItems $ \v -> do - Object item <- return v - Object index_ <- "index" `H.lookup` item - return index_ - guard $ V.length items == V.length jsonMsgs - return (hasErrors, items) - case result of - Nothing -> liftIO . BSL.putStrLn - $ "ElasticSearch: unexpected response: " <> jsonToBSL replyBody - Just (hasErrors, items) -> when hasErrors $ do - -- If any message failed to be inserted because of type mismatch, go - -- back to them, log the insertion failure and add type suffix to each - -- of the keys in their "data" fields to work around type errors. - let failed = V.findIndices (H.member "error") items - newMsgs = (`V.map` failed) $ \n -> - let modifyData :: Bool -> Value -> Value - modifyData addError (Object hm) = Object $ - let newData = H.foldlWithKey' keyAddValueTypeSuffix H.empty hm - in if addError - then newData `H.union` H.fromList - [ "__es_error" .= H.lookup "error" (items V.! n) - , "__es_modified" .= True - ] - else newData - modifyData _ v = v - - keyAddValueTypeSuffix acc k v = H.insert - (case v of - Object{} -> k <> "_object" - Array{} -> k <> "_array" - String{} -> k <> "_string" - Number{} -> k <> "_number" - Bool{} -> k <> "_bool" - Null{} -> k <> "_null" - ) (modifyData False v) acc - in second (H.adjust (modifyData True) "data") $ jsonMsgs V.! n - -- Attempt to put modified messages and ignore any further errors. - void $ bulk (V.map (toBulk index baseID) newMsgs)) - (elasticSearchSync indexRef) - where - mapping = MappingName esMapping - - elasticSearchSync :: IORef IndexName -> IO () - elasticSearchSync indexRef = do - indexName <- readIORef indexRef - void . runBH_ esConf $ refreshIndex indexName - - retryOnException :: forall r. IO r -> IO r - retryOnException m = try m >>= \case - Left (ex::SomeException) -> do - putStrLn $ "ElasticSearch: unexpected error: " - <> show ex <> ", retrying in 10 seconds" - threadDelay $ 10 * 1000000 - retryOnException m - Right result -> return result - - timeToDouble :: UTCTime -> Double - timeToDouble = realToFrac . utcTimeToPOSIXSeconds - - jsonToBSL :: Value -> BSL.ByteString - jsonToBSL = encodePretty' defConfig { confIndent = Spaces 2 } - - toJsonMsg :: UTCTime -> (Word32, LogMessage) - -> (Word32, H.HashMap T.Text Value) - toJsonMsg now (n, msg) = (n, H.union jMsg $ H.fromList [ - ("insertion_order", toJSON n) - , ("insertion_time", toJSON now) - ]) - where - Object jMsg = toJSON msg - - mkDocId :: BS.ByteString -> Word32 -> DocId - mkDocId baseID insertionOrder = DocId . T.decodeUtf8 - . B64.encode $ BS.concat [ - baseID - , littleEndianRep insertionOrder - ] - - toBulk :: IndexName -> BS.ByteString -> (Word32, H.HashMap T.Text Value) - -> BulkOperation - toBulk index baseID (n, obj) = - BulkIndex index mapping (mkDocId baseID n) $ Object obj - -data LogsMapping = LogsMapping -instance ToJSON LogsMapping where - toJSON LogsMapping = object [ - "properties" .= object [ - "insertion_order" .= object [ - "type" .= ("integer"::T.Text) - ] - , "insertion_time" .= object [ - "type" .= ("date"::T.Text) - , "format" .= ("date_time"::T.Text) - ] - , "time" .= object [ - "type" .= ("date"::T.Text) - , "format" .= ("date_time"::T.Text) - ] - , "domain" .= object [ - "type" .= ("string"::T.Text) - ] - , "level" .= object [ - "type" .= ("string"::T.Text) - ] - , "component" .= object [ - "type" .= ("string"::T.Text) - ] - , "message" .= object [ - "type" .= ("string"::T.Text) - ] - ] - ] - - toEncoding LogsMapping = Aeson.pairs $ mconcat - [ Aeson.pair "properties" $ Aeson.pairs $ mconcat - [ Aeson.pair "insertion_order" $ Aeson.pairs $ mconcat - [ "type" .= ("integer"::T.Text) - ] - , Aeson.pair "insertion_time" $ Aeson.pairs $ mconcat - [ "type" .= ("date"::T.Text) - , "format" .= ("date_time"::T.Text) - ] - , Aeson.pair "time" $ Aeson.pairs $ mconcat - [ "type" .= ("date"::T.Text) - , "format" .= ("date_time"::T.Text) - ] - , Aeson.pair "domain" $ Aeson.pairs $ mconcat - [ "type" .= ("string"::T.Text) - ] - , Aeson.pair "level" $ Aeson.pairs $ mconcat - [ "type" .= ("string"::T.Text) - ] - , Aeson.pair "component" $ Aeson.pairs $ mconcat - [ "type" .= ("string"::T.Text) - ] - , Aeson.pair "message" $ Aeson.pairs $ mconcat - [ "type" .= ("string"::T.Text) - ] - ] - ] - ----------------------------------------- - -littleEndianRep :: Word32 -> BS.ByteString -littleEndianRep = fst . BS.unfoldrN 4 step - where - step n = Just (fromIntegral $ n .&. 0xff, n `shiftR` 8) - -decodeReply :: Reply -> Value -decodeReply reply = case eitherDecode' $ responseBody reply of - Right body -> body - Left err -> object ["decoding_error" .= err] - --- | Check that login credentials are specified properly. --- --- @since 0.10.0.0 -checkElasticSearchLogin :: ElasticSearchConfig -> IO (Either IOException ()) -checkElasticSearchLogin ElasticSearchConfig{..} = - try $ - when (isJust esLogin - && not esLoginInsecure - && not ("https:" `T.isPrefixOf` esServer)) $ - error $ "ElasticSearch: insecure login: " - <> "Attempting to send login credentials over an insecure connection. " - <> "Set esLoginInsecure = True to disable this check." - --- | Check that we can connect to the ES server. --- --- @since 0.10.0.0 -checkElasticSearchConnection :: ElasticSearchConfig -> IO (Either HttpException ()) -checkElasticSearchConnection esConf = - try (void $ runBH_ esConf listIndices) - -runBH_ :: forall r. ElasticSearchConfig -> BH IO r -> IO r -runBH_ ElasticSearchConfig{..} f = do - mgr <- newManager tlsManagerSettings - let hook = maybe return (uncurry basicAuthHook) esLogin - let env = (mkBHEnv (Server esServer) mgr) { bhRequestHook = hook } - runBH env f diff --git a/src/Log/Backend/ElasticSearch/V1/Internal.hs b/src/Log/Backend/ElasticSearch/V1/Internal.hs deleted file mode 100644 --- a/src/Log/Backend/ElasticSearch/V1/Internal.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Log.Backend.ElasticSearch.V1.Internal - (ElasticSearchConfig(..) - ,defaultElasticSearchConfig - ,EsUsername(..) - ,EsPassword(..)) -where - -import Database.V1.Bloodhound hiding (Status) -import GHC.Generics (Generic) -import Prelude -import qualified Data.Text as T - --- | Configuration for the Elasticsearch 'Logger'. See --- --- for the explanation of terms. -data ElasticSearchConfig = ElasticSearchConfig { - esServer :: !T.Text -- ^ Elasticsearch server address. - , esIndex :: !T.Text -- ^ Elasticsearch index name. - , esShardCount :: !Int - -- ^ Elasticsearch shard count for the named index. - -- - -- @since 0.10.0.0 - , esReplicaCount :: !Int - -- ^ Elasticsearch replica count for the named index. - -- - -- @since 0.10.0.0 - , esMapping :: !T.Text - -- ^ Elasticsearch mapping name. - , esLogin :: Maybe (EsUsername, EsPassword) - -- ^ Elasticsearch basic authentication username and password. - , esLoginInsecure :: !Bool - -- ^ Allow basic authentication over non-TLS connections. - } deriving (Eq, Show, Generic) - --- | Sensible defaults for 'ElasticSearchConfig'. -defaultElasticSearchConfig :: ElasticSearchConfig -defaultElasticSearchConfig = ElasticSearchConfig { - esServer = "http://localhost:9200", - esIndex = "logs", - esShardCount = 4, - esReplicaCount = 1, - esMapping = "log", - esLogin = Nothing, - esLoginInsecure = False - } diff --git a/src/Log/Backend/ElasticSearch/V1/Lens.hs b/src/Log/Backend/ElasticSearch/V1/Lens.hs deleted file mode 100644 --- a/src/Log/Backend/ElasticSearch/V1/Lens.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE RankNTypes #-} --- | Lensified version of "Log.Backend.ElasticSearch". -module Log.Backend.ElasticSearch.V1.Lens ( - I.ElasticSearchConfig - , esServer - , esIndex - , esShardCount - , esReplicaCount - , esMapping - , esLogin - , esLoginInsecure - , I.defaultElasticSearchConfig - , I.withElasticSearchLogger - ) where - -import Database.V1.Bloodhound hiding (Status) -import Prelude -import qualified Data.Text as T -import qualified Log.Backend.ElasticSearch.V1 as I -import qualified Log.Backend.ElasticSearch.V1.Internal () - -type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s - --- | Elasticsearch server address. -esServer :: Lens' I.ElasticSearchConfig T.Text -esServer f esc = fmap (\x -> esc { I.esServer = x }) $ f (I.esServer esc) - --- | Elasticsearch index name. -esIndex :: Lens' I.ElasticSearchConfig T.Text -esIndex f esc = fmap (\x -> esc { I.esIndex = x }) $ f (I.esIndex esc) - --- | Elasticsearch shard count for the named index. --- --- @since 0.10.0.0 -esShardCount :: Lens' I.ElasticSearchConfig Int -esShardCount f esc = fmap (\x -> esc { I.esShardCount = x }) $ f (I.esShardCount esc) - --- | Elasticsearch replica count for the named index. --- --- @since 0.10.0.0 -esReplicaCount :: Lens' I.ElasticSearchConfig Int -esReplicaCount f esc = fmap (\x -> esc { I.esReplicaCount = x }) $ f (I.esReplicaCount esc) - --- | Elasticsearch mapping name. -esMapping :: Lens' I.ElasticSearchConfig T.Text -esMapping f esc = fmap (\x -> esc { I.esMapping = x }) $ f (I.esMapping esc) - --- | Elasticsearch basic authentication username and password. -esLogin :: Lens' I.ElasticSearchConfig (Maybe (EsUsername, EsPassword)) -esLogin f esc = fmap (\x -> esc { I.esLogin = x }) $ f (I.esLogin esc) - --- | Allow basic authentication over non-TLS connections. -esLoginInsecure :: Lens' I.ElasticSearchConfig Bool -esLoginInsecure f esc = fmap (\x -> esc { I.esLoginInsecure = x }) $ f (I.esLoginInsecure esc) diff --git a/src/Log/Backend/ElasticSearch/V5.hs b/src/Log/Backend/ElasticSearch/V5.hs deleted file mode 100644 --- a/src/Log/Backend/ElasticSearch/V5.hs +++ /dev/null @@ -1,313 +0,0 @@ --- | Elasticsearch logging back-end. -module Log.Backend.ElasticSearch.V5 ( - ElasticSearchConfig - , esServer - , esIndex - , esShardCount - , esReplicaCount - , esMapping - , esLogin - , esLoginInsecure - , checkElasticSearchLogin - , checkElasticSearchConnection - , defaultElasticSearchConfig - , withElasticSearchLogger - , elasticSearchLogger - ) where - -import Control.Applicative -import Control.Arrow (second) -import Control.Concurrent -import Control.Exception -import Control.Monad -import Control.Monad.IO.Class -import Data.Aeson -import Data.Aeson.Encode.Pretty -import Data.Bits -import Data.IORef -import Data.Maybe (isJust) -import Data.Semigroup -import Data.Time -import Data.Time.Clock.POSIX -import Data.Word -import Database.V5.Bloodhound hiding (Status) -import Log -import Log.Internal.Logger -import Network.HTTP.Client -import Network.HTTP.Client.TLS (tlsManagerSettings) -import Prelude -import System.IO -import qualified Data.Aeson.Encoding as Aeson -import qualified Data.ByteString as BS -import qualified Data.ByteString.Base64 as B64 -import qualified Data.ByteString.Lazy.Char8 as BSL -import qualified Data.HashMap.Strict as H -import qualified Data.Text as T -import qualified Data.Text.Encoding as T -import qualified Data.Traversable as F -import qualified Data.Vector as V - -import Log.Backend.ElasticSearch.V5.Internal - ----------------------------------------- --- | Create an 'elasticSearchLogger' for the duration of the given --- action, and shut it down afterwards, making sure that all buffered --- messages are actually written to the Elasticsearch store. -withElasticSearchLogger :: ElasticSearchConfig -> IO Word32 -> (Logger -> IO r) - -> IO r -withElasticSearchLogger conf randGen act = do - logger <- elasticSearchLogger conf randGen - withLogger logger act - -{-# DEPRECATED elasticSearchLogger "Use 'withElasticSearchLogger' instead!" #-} - --- | Start an asynchronous logger thread that stores messages using --- Elasticsearch. --- --- Please use 'withElasticSearchLogger' instead, which is more --- exception-safe (see the note attached to 'mkBulkLogger'). -elasticSearchLogger :: - ElasticSearchConfig -- ^ Configuration. - -> IO Word32 -- ^ Generate a random 32-bit word for use in - -- document IDs. - -> IO Logger -elasticSearchLogger esConf@ElasticSearchConfig{..} genRandomWord = do - - checkElasticSearchLogin esConf >>= \case - Left (ex :: IOException) -> error . show $ ex - Right _ -> return () - - checkElasticSearchConnection esConf >>= \case - Left (ex :: HttpException) -> - hPutStrLn stderr $ - "ElasticSearch: unexpected error: " <> - show ex <> - " (is ElasticSearch server running?)" - Right () -> return () - - indexRef <- newIORef $ IndexName T.empty - mkBulkLogger "ElasticSearch" (\msgs -> do - now <- getCurrentTime - oldIndex <- readIORef indexRef - -- Bloodhound doesn't support letting ES autogenerate IDs, so let's generate - -- them ourselves. An ID of a log message is 12 bytes (4 bytes: random, 4 - -- bytes: current time as epoch, 4 bytes: insertion order) encoded as - -- Base64. This makes eventual collisions practically impossible. - baseID <- (<>) - <$> (littleEndianRep <$> liftIO genRandomWord) - <*> pure (littleEndianRep . floor $ timeToDouble now) - retryOnException . runBH_ esConf $ do - -- Elasticsearch index names are additionally indexed by date so that each - -- day is logged to a separate index to make log management easier. - let index = IndexName $ T.concat [ - esIndex - , "-" - , T.pack $ formatTime defaultTimeLocale "%F" now - ] - when (oldIndex /= index) $ do - -- There is an obvious race condition in the presence of more than one - -- logger instance running, but it's irrelevant as attempting to create - -- index that already exists is harmless. - indexExists' <- indexExists index - unless indexExists' $ do - -- Note that Bloodhound won't let us create index using - -- default settings. - let indexSettings = IndexSettings { - indexShards = ShardCount esShardCount - , indexReplicas = ReplicaCount esReplicaCount - } - void $ createIndex indexSettings index - reply <- putMapping index mapping LogsMapping - when (not $ isSuccess reply) $ do - error $ "ElasticSearch: error while creating mapping: " - <> T.unpack (T.decodeUtf8 . BSL.toStrict . jsonToBSL - $ decodeReply reply) - liftIO $ writeIORef indexRef index - let jsonMsgs = V.fromList $ map (toJsonMsg now) $ zip [1..] msgs - reply <- bulk $ V.map (toBulk index baseID) jsonMsgs - -- Try to parse parts of reply to get information about log messages that - -- failed to be inserted for some reason. - let replyBody = decodeReply reply - result = do - Object response <- return replyBody - Bool hasErrors <- "errors" `H.lookup` response - Array jsonItems <- "items" `H.lookup` response - items <- F.forM jsonItems $ \v -> do - Object item <- return v - Object index_ <- "index" `H.lookup` item - return index_ - guard $ V.length items == V.length jsonMsgs - return (hasErrors, items) - case result of - Nothing -> liftIO . BSL.putStrLn - $ "ElasticSearch: unexpected response: " <> jsonToBSL replyBody - Just (hasErrors, items) -> when hasErrors $ do - -- If any message failed to be inserted because of type mismatch, go - -- back to them, log the insertion failure and add type suffix to each - -- of the keys in their "data" fields to work around type errors. - let failed = V.findIndices (H.member "error") items - newMsgs = (`V.map` failed) $ \n -> - let modifyData :: Bool -> Value -> Value - modifyData addError (Object hm) = Object $ - let newData = H.foldlWithKey' keyAddValueTypeSuffix H.empty hm - in if addError - then newData `H.union` H.fromList - [ "__es_error" .= H.lookup "error" (items V.! n) - , "__es_modified" .= True - ] - else newData - modifyData _ v = v - - keyAddValueTypeSuffix acc k v = H.insert - (case v of - Object{} -> k <> "_object" - Array{} -> k <> "_array" - String{} -> k <> "_string" - Number{} -> k <> "_number" - Bool{} -> k <> "_bool" - Null{} -> k <> "_null" - ) (modifyData False v) acc - in second (H.adjust (modifyData True) "data") $ jsonMsgs V.! n - -- Attempt to put modified messages and ignore any further errors. - void $ bulk (V.map (toBulk index baseID) newMsgs)) - (elasticSearchSync indexRef) - where - mapping = MappingName esMapping - - elasticSearchSync :: IORef IndexName -> IO () - elasticSearchSync indexRef = do - indexName <- readIORef indexRef - void . runBH_ esConf $ refreshIndex indexName - - retryOnException :: forall r. IO r -> IO r - retryOnException m = try m >>= \case - Left (ex::SomeException) -> do - putStrLn $ "ElasticSearch: unexpected error: " - <> show ex <> ", retrying in 10 seconds" - threadDelay $ 10 * 1000000 - retryOnException m - Right result -> return result - - timeToDouble :: UTCTime -> Double - timeToDouble = realToFrac . utcTimeToPOSIXSeconds - - jsonToBSL :: Value -> BSL.ByteString - jsonToBSL = encodePretty' defConfig { confIndent = Spaces 2 } - - toJsonMsg :: UTCTime -> (Word32, LogMessage) - -> (Word32, H.HashMap T.Text Value) - toJsonMsg now (n, msg) = (n, H.union jMsg $ H.fromList [ - ("insertion_order", toJSON n) - , ("insertion_time", toJSON now) - ]) - where - Object jMsg = toJSON msg - - mkDocId :: BS.ByteString -> Word32 -> DocId - mkDocId baseID insertionOrder = DocId . T.decodeUtf8 - . B64.encode $ BS.concat [ - baseID - , littleEndianRep insertionOrder - ] - - toBulk :: IndexName -> BS.ByteString -> (Word32, H.HashMap T.Text Value) - -> BulkOperation - toBulk index baseID (n, obj) = - BulkIndex index mapping (mkDocId baseID n) $ Object obj - -data LogsMapping = LogsMapping -instance ToJSON LogsMapping where - toJSON LogsMapping = object [ - "properties" .= object [ - "insertion_order" .= object [ - "type" .= ("integer"::T.Text) - ] - , "insertion_time" .= object [ - "type" .= ("date"::T.Text) - , "format" .= ("date_time"::T.Text) - ] - , "time" .= object [ - "type" .= ("date"::T.Text) - , "format" .= ("date_time"::T.Text) - ] - , "domain" .= object [ - "type" .= ("text"::T.Text) - ] - , "level" .= object [ - "type" .= ("text"::T.Text) - ] - , "component" .= object [ - "type" .= ("text"::T.Text) - ] - , "message" .= object [ - "type" .= ("text"::T.Text) - ] - ] - ] - - toEncoding LogsMapping = Aeson.pairs $ mconcat - [ Aeson.pair "properties" $ Aeson.pairs $ mconcat - [ Aeson.pair "insertion_order" $ Aeson.pairs $ mconcat - [ "type" .= ("integer"::T.Text) - ] - , Aeson.pair "insertion_time" $ Aeson.pairs $ mconcat - [ "type" .= ("date"::T.Text) - , "format" .= ("date_time"::T.Text) - ] - , Aeson.pair "time" $ Aeson.pairs $ mconcat - [ "type" .= ("date"::T.Text) - , "format" .= ("date_time"::T.Text) - ] - , Aeson.pair "domain" $ Aeson.pairs $ mconcat - [ "type" .= ("text"::T.Text) - ] - , Aeson.pair "level" $ Aeson.pairs $ mconcat - [ "type" .= ("text"::T.Text) - ] - , Aeson.pair "component" $ Aeson.pairs $ mconcat - [ "type" .= ("text"::T.Text) - ] - , Aeson.pair "message" $ Aeson.pairs $ mconcat - [ "type" .= ("text"::T.Text) - ] - ] - ] - ----------------------------------------- - -littleEndianRep :: Word32 -> BS.ByteString -littleEndianRep = fst . BS.unfoldrN 4 step - where - step n = Just (fromIntegral $ n .&. 0xff, n `shiftR` 8) - -decodeReply :: Reply -> Value -decodeReply reply = case eitherDecode' $ responseBody reply of - Right body -> body - Left err -> object ["decoding_error" .= err] - --- | Check that login credentials are specified properly. --- --- @since 0.10.0.0 -checkElasticSearchLogin :: ElasticSearchConfig -> IO (Either IOException ()) -checkElasticSearchLogin ElasticSearchConfig{..} = - try $ - when (isJust esLogin - && not esLoginInsecure - && not ("https:" `T.isPrefixOf` esServer)) $ - error $ "ElasticSearch: insecure login: " - <> "Attempting to send login credentials over an insecure connection. " - <> "Set esLoginInsecure = True to disable this check." - --- | Check that we can connect to the ES server. --- --- @since 0.10.0.0 -checkElasticSearchConnection :: ElasticSearchConfig -> IO (Either HttpException ()) -checkElasticSearchConnection esConf = - try (void $ runBH_ esConf listIndices) - -runBH_ :: forall r. ElasticSearchConfig -> BH IO r -> IO r -runBH_ ElasticSearchConfig{..} f = do - mgr <- newManager tlsManagerSettings - let hook = maybe return (uncurry basicAuthHook) esLogin - let env = (mkBHEnv (Server esServer) mgr) { bhRequestHook = hook } - runBH env f diff --git a/src/Log/Backend/ElasticSearch/V5/Internal.hs b/src/Log/Backend/ElasticSearch/V5/Internal.hs deleted file mode 100644 --- a/src/Log/Backend/ElasticSearch/V5/Internal.hs +++ /dev/null @@ -1,46 +0,0 @@ -{-# LANGUAGE DeriveGeneric #-} -module Log.Backend.ElasticSearch.V5.Internal - (ElasticSearchConfig(..) - ,defaultElasticSearchConfig - ,EsUsername(..) - ,EsPassword(..)) -where - -import Database.V5.Bloodhound hiding (Status) -import GHC.Generics (Generic) -import Prelude -import qualified Data.Text as T - --- | Configuration for the Elasticsearch 'Logger'. See --- --- for the explanation of terms. -data ElasticSearchConfig = ElasticSearchConfig { - esServer :: !T.Text -- ^ Elasticsearch server address. - , esIndex :: !T.Text -- ^ Elasticsearch index name. - , esShardCount :: !Int - -- ^ Elasticsearch shard count for the named index. - -- - -- @since 0.10.0.0 - , esReplicaCount :: !Int - -- ^ Elasticsearch replica count for the named index. - -- - -- @since 0.10.0.0 - , esMapping :: !T.Text - -- ^ Elasticsearch mapping name. - , esLogin :: Maybe (EsUsername, EsPassword) - -- ^ Elasticsearch basic authentication username and password. - , esLoginInsecure :: !Bool - -- ^ Allow basic authentication over non-TLS connections. - } deriving (Eq, Show, Generic) - --- | Sensible defaults for 'ElasticSearchConfig'. -defaultElasticSearchConfig :: ElasticSearchConfig -defaultElasticSearchConfig = ElasticSearchConfig { - esServer = "http://localhost:9200", - esIndex = "logs", - esShardCount = 4, - esReplicaCount = 1, - esMapping = "log", - esLogin = Nothing, - esLoginInsecure = False - } diff --git a/src/Log/Backend/ElasticSearch/V5/Lens.hs b/src/Log/Backend/ElasticSearch/V5/Lens.hs deleted file mode 100644 --- a/src/Log/Backend/ElasticSearch/V5/Lens.hs +++ /dev/null @@ -1,54 +0,0 @@ -{-# LANGUAGE RankNTypes #-} --- | Lensified version of "Log.Backend.ElasticSearch". -module Log.Backend.ElasticSearch.V5.Lens ( - I.ElasticSearchConfig - , esServer - , esIndex - , esShardCount - , esReplicaCount - , esMapping - , esLogin - , esLoginInsecure - , I.defaultElasticSearchConfig - , I.withElasticSearchLogger - ) where - -import Database.V5.Bloodhound hiding (Status) -import Prelude -import qualified Data.Text as T -import qualified Log.Backend.ElasticSearch.V5 as I -import qualified Log.Backend.ElasticSearch.V5.Internal () - -type Lens' s a = forall f. Functor f => (a -> f a) -> s -> f s - --- | Elasticsearch server address. -esServer :: Lens' I.ElasticSearchConfig T.Text -esServer f esc = fmap (\x -> esc { I.esServer = x }) $ f (I.esServer esc) - --- | Elasticsearch index name. -esIndex :: Lens' I.ElasticSearchConfig T.Text -esIndex f esc = fmap (\x -> esc { I.esIndex = x }) $ f (I.esIndex esc) - --- | Elasticsearch shard count for the named index. --- --- @since 0.10.0.0 -esShardCount :: Lens' I.ElasticSearchConfig Int -esShardCount f esc = fmap (\x -> esc { I.esShardCount = x }) $ f (I.esShardCount esc) - --- | Elasticsearch replica count for the named index. --- --- @since 0.10.0.0 -esReplicaCount :: Lens' I.ElasticSearchConfig Int -esReplicaCount f esc = fmap (\x -> esc { I.esReplicaCount = x }) $ f (I.esReplicaCount esc) - --- | Elasticsearch mapping name. -esMapping :: Lens' I.ElasticSearchConfig T.Text -esMapping f esc = fmap (\x -> esc { I.esMapping = x }) $ f (I.esMapping esc) - --- | Elasticsearch basic authentication username and password. -esLogin :: Lens' I.ElasticSearchConfig (Maybe (EsUsername, EsPassword)) -esLogin f esc = fmap (\x -> esc { I.esLogin = x }) $ f (I.esLogin esc) - --- | Allow basic authentication over non-TLS connections. -esLoginInsecure :: Lens' I.ElasticSearchConfig Bool -esLoginInsecure f esc = fmap (\x -> esc { I.esLoginInsecure = x }) $ f (I.esLoginInsecure esc)