-- | Elasticsearch logging back-end.
module Log.Backend.ElasticSearch
  ( ElasticSearchConfig
  , esServer
  , esIndex
  , esShardCount
  , esReplicaCount
  , esMapping
  , esLogin
  , esLoginInsecure
  , checkElasticSearchLogin
  , checkElasticSearchConnection
  , defaultElasticSearchConfig
  , withElasticSearchLogger
  , elasticSearchLogger
  ) where

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 Log
import Log.Internal.Logger
import Network.HTTP.Client
import Prelude
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
import qualified Log.Internal.Aeson.Compat as AC

----------------------------------------
-- | 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 :: ElasticSearchConfig -> (Logger -> IO r) -> IO r
withElasticSearchLogger ElasticSearchConfig
conf Logger -> IO r
act = do
  Logger
logger <- ElasticSearchConfig -> IO Logger
elasticSearchLogger ElasticSearchConfig
conf
  Logger -> (Logger -> IO r) -> IO r
forall r. Logger -> (Logger -> IO r) -> IO r
withLogger Logger
logger Logger -> IO r
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 :: ElasticSearchConfig -> IO Logger
elasticSearchLogger esConf :: ElasticSearchConfig
esConf@ElasticSearchConfig{Bool
Int
Maybe (Text, Text)
Text
esLoginInsecure :: Bool
esLogin :: Maybe (Text, Text)
esMapping :: Text
esReplicaCount :: Int
esShardCount :: Int
esIndex :: Text
esServer :: Text
esLoginInsecure :: ElasticSearchConfig -> Bool
esLogin :: ElasticSearchConfig -> Maybe (Text, Text)
esMapping :: ElasticSearchConfig -> Text
esReplicaCount :: ElasticSearchConfig -> Int
esShardCount :: ElasticSearchConfig -> Int
esIndex :: ElasticSearchConfig -> Text
esServer :: ElasticSearchConfig -> Text
..} = do
  ElasticSearchConfig -> IO ()
checkElasticSearchLogin ElasticSearchConfig
esConf
  EsEnv
env <- ElasticSearchConfig -> IO EsEnv
mkEsEnv ElasticSearchConfig
esConf
  IORef (Maybe EsVersion)
versionRef <- Maybe EsVersion -> IO (IORef (Maybe EsVersion))
forall a. a -> IO (IORef a)
newIORef Maybe EsVersion
forall a. Maybe a
Nothing
  IORef Text
indexRef <- Text -> IO (IORef Text)
forall a. a -> IO (IORef a)
newIORef Text
T.empty
  Text -> ([LogMessage] -> IO ()) -> IO () -> IO Logger
mkBulkLogger Text
"ElasticSearch" (\[LogMessage]
msgs -> do
    UTCTime
now <- IO UTCTime
getCurrentTime
    Text
oldIndex <- IORef Text -> IO Text
forall a. IORef a -> IO a
readIORef IORef Text
indexRef
    IORef (Maybe EsVersion) -> IO () -> IO ()
forall r. IORef (Maybe EsVersion) -> IO r -> IO r
retryOnException IORef (Maybe EsVersion)
versionRef (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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.
      EsVersion
version <- IORef (Maybe EsVersion) -> IO (Maybe EsVersion)
forall a. IORef a -> IO a
readIORef IORef (Maybe EsVersion)
versionRef IO (Maybe EsVersion)
-> (Maybe EsVersion -> IO EsVersion) -> IO EsVersion
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just EsVersion
version -> EsVersion -> IO EsVersion
forall (f :: * -> *) a. Applicative f => a -> f a
pure EsVersion
version
        Maybe EsVersion
Nothing -> EsEnv -> IO (Either HttpException (Response Value))
serverInfo EsEnv
env IO (Either HttpException (Response Value))
-> (Either HttpException (Response Value) -> IO EsVersion)
-> IO EsVersion
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Left (HttpException
ex :: HttpException) -> [Char] -> IO EsVersion
forall a. HasCallStack => [Char] -> a
error
            ([Char] -> IO EsVersion) -> [Char] -> IO EsVersion
forall a b. (a -> b) -> a -> b
$  [Char]
"elasticSearchLogger: unexpected error: "
            [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> HttpException -> [Char]
forall a. Show a => a -> [Char]
show HttpException
ex
            [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
" (is ElasticSearch server running?)"
          Right Response Value
reply -> case Value -> Maybe EsVersion
parseEsVersion (Value -> Maybe EsVersion) -> Value -> Maybe EsVersion
forall a b. (a -> b) -> a -> b
$ Response Value -> Value
forall body. Response body -> body
responseBody Response Value
reply of
            Maybe EsVersion
Nothing -> [Char] -> IO EsVersion
forall a. HasCallStack => [Char] -> a
error
              ([Char] -> IO EsVersion) -> [Char] -> IO EsVersion
forall a b. (a -> b) -> a -> b
$  [Char]
"elasticSearchLogger: invalid response when parsing version number: "
              [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Response Value -> [Char]
forall a. Show a => a -> [Char]
show Response Value
reply
            Just EsVersion
version -> EsVersion -> IO EsVersion
forall (f :: * -> *) a. Applicative f => a -> f a
pure EsVersion
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 :: Text
index = [Text] -> Text
T.concat
            [ Text
esIndex
            , Text
"-"
            , [Char] -> Text
T.pack ([Char] -> Text) -> [Char] -> Text
forall a b. (a -> b) -> a -> b
$ TimeLocale -> [Char] -> UTCTime -> [Char]
forall t. FormatTime t => TimeLocale -> [Char] -> t -> [Char]
formatTime TimeLocale
defaultTimeLocale [Char]
"%F" UTCTime
now
            ]
      Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
oldIndex Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
index) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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.
        Bool
ixExists <- EsEnv -> Text -> IO Bool
indexExists EsEnv
env Text
index
        Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
ixExists (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
          Response Value
reply <- EsVersion
-> EsEnv -> ElasticSearchConfig -> Text -> IO (Response Value)
createIndexWithMapping EsVersion
version EsEnv
env ElasticSearchConfig
esConf Text
index
          Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Response Value -> Bool
forall a. Response a -> Bool
isSuccess Response Value
reply) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ do
            Text -> Value -> IO ()
printEsError Text
"error while creating index" (Value -> IO ()) -> Value -> IO ()
forall a b. (a -> b) -> a -> b
$ Response Value -> Value
forall body. Response body -> body
responseBody Response Value
reply
        IORef Text -> Text -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef Text
indexRef Text
index
      let jsonMsgs :: Vector Object
jsonMsgs = [Object] -> Vector Object
forall a. [a] -> Vector a
V.fromList ([Object] -> Vector Object) -> [Object] -> Vector Object
forall a b. (a -> b) -> a -> b
$ (LogMessage -> Object) -> [LogMessage] -> [Object]
forall a b. (a -> b) -> [a] -> [b]
map LogMessage -> Object
toJsonMsg [LogMessage]
msgs
      Value
reply <- Response Value -> Value
forall body. Response body -> body
responseBody (Response Value -> Value) -> IO (Response Value) -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EsVersion
-> EsEnv
-> ElasticSearchConfig
-> Text
-> Vector Object
-> IO (Response Value)
bulkIndex EsVersion
version EsEnv
env ElasticSearchConfig
esConf Text
index Vector Object
jsonMsgs
      -- Try to parse parts of reply to get information about log messages that
      -- failed to be inserted for some reason.
      case Vector Object -> Value -> Maybe (Bool, Vector Object)
forall a. Vector a -> Value -> Maybe (Bool, Vector Object)
checkForBulkErrors Vector Object
jsonMsgs Value
reply of
        Maybe (Bool, Vector Object)
Nothing -> Text -> Value -> IO ()
printEsError Text
"unexpected response" Value
reply
        Just (Bool
hasErrors, Vector Object
responses) -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
hasErrors (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 :: Vector Object
newMsgs =
                let modifyData :: Maybe Value -> Value -> Value
                    modifyData :: Maybe Value -> Value -> Value
modifyData Maybe Value
merr (Object Object
hm) = Object -> Value
Object (Object -> Value) -> Object -> Value
forall a b. (a -> b) -> a -> b
$
                      let newData :: Object
newData = (Key -> Value -> Object -> Object) -> Object -> Object -> Object
forall v a. (Key -> v -> a -> a) -> a -> KeyMap v -> a
AC.foldrWithKey Key -> Value -> Object -> Object
keyAddValueTypeSuffix Object
forall v. KeyMap v
AC.empty Object
hm
                      in case Maybe Value
merr of
                        -- We have the error message, i.e. we're at the top
                        -- level object, so add it to the data.
                        Just Value
err -> Object
newData Object -> Object -> Object
forall v. KeyMap v -> KeyMap v -> KeyMap v
`AC.union` Key -> Value -> Object
forall v. Key -> v -> KeyMap v
AC.singleton Key
"__es_error" Value
err
                        Maybe Value
Nothing  -> Object
newData
                    modifyData Maybe Value
_ Value
v = Value
v

                    keyAddValueTypeSuffix :: Key -> Value -> Object -> Object
keyAddValueTypeSuffix Key
k Value
v Object
acc = Key -> Value -> Object -> Object
forall v. Key -> v -> KeyMap v -> KeyMap v
AC.insert
                      (case Value
v of
                          Object{} -> Key
k Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
"_object"
                          Array{}  -> Key
k Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
"_array"
                          String{} -> Key
k Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
"_string"
                          Number{} -> Key
k Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
"_number"
                          Bool{}   -> Key
k Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
"_bool"
                          Null{}   -> Key
k Key -> Key -> Key
forall a. Semigroup a => a -> a -> a
<> Key
"_null"
                      ) (Maybe Value -> Value -> Value
modifyData Maybe Value
forall a. Maybe a
Nothing Value
v) Object
acc
                in (Maybe Value -> Value -> Value)
-> Vector Object -> Vector Object -> Vector Object
forall err obj.
(Maybe err -> obj -> obj)
-> Vector (KeyMap obj)
-> Vector (KeyMap err)
-> Vector (KeyMap obj)
adjustFailedMessagesWith Maybe Value -> Value -> Value
modifyData Vector Object
jsonMsgs Vector Object
responses
          -- Attempt to put modified messages.
          Value
newReply <- Response Value -> Value
forall body. Response body -> body
responseBody (Response Value -> Value) -> IO (Response Value) -> IO Value
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EsVersion
-> EsEnv
-> ElasticSearchConfig
-> Text
-> Vector Object
-> IO (Response Value)
bulkIndex EsVersion
version EsEnv
env ElasticSearchConfig
esConf Text
index Vector Object
newMsgs
          case Vector Object -> Value -> Maybe (Bool, Vector Object)
forall a. Vector a -> Value -> Maybe (Bool, Vector Object)
checkForBulkErrors Vector Object
newMsgs Value
newReply of
            Maybe (Bool, Vector Object)
Nothing -> Text -> Value -> IO ()
printEsError Text
"unexpected response" Value
newReply
            Just (Bool
newHasErrors, Vector Object
newResponses) -> Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
newHasErrors (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ 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 :: Vector Object
newerMsgs =
                    let modifyData :: Maybe Value -> Value -> Value
                        modifyData :: Maybe Value -> Value -> Value
modifyData (Just Value
err) Object{} = [Pair] -> Value
object [ Key
"__es_error" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
err ]
                        modifyData Maybe Value
_ Value
v = Value
v
                    in (Maybe Value -> Value -> Value)
-> Vector Object -> Vector Object -> Vector Object
forall err obj.
(Maybe err -> obj -> obj)
-> Vector (KeyMap obj)
-> Vector (KeyMap err)
-> Vector (KeyMap obj)
adjustFailedMessagesWith Maybe Value -> Value -> Value
modifyData Vector Object
newMsgs Vector Object
newResponses
              -- Ignore any further errors.
              IO (Response Value) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (IO (Response Value) -> IO ()) -> IO (Response Value) -> IO ()
forall a b. (a -> b) -> a -> b
$ EsVersion
-> EsEnv
-> ElasticSearchConfig
-> Text
-> Vector Object
-> IO (Response Value)
bulkIndex EsVersion
version EsEnv
env ElasticSearchConfig
esConf Text
index Vector Object
newerMsgs)
    (EsEnv -> Text -> IO ()
refreshIndex EsEnv
env (Text -> IO ()) -> IO Text -> IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IORef Text -> IO Text
forall a. IORef a -> IO a
readIORef IORef Text
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 :: Vector a -> Value -> Maybe (Bool, Vector Object)
checkForBulkErrors Vector a
jsonMsgs Value
replyBody = do
      Object Object
response <- Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
replyBody
      Bool Bool
hasErrors  <- Key
"errors" Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
`AC.lookup` Object
response
      Array Array
jsonItems <- Key
"items"  Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
`AC.lookup` Object
response
      Vector Object
items <- Array -> (Value -> Maybe Object) -> Maybe (Vector Object)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
F.forM Array
jsonItems ((Value -> Maybe Object) -> Maybe (Vector Object))
-> (Value -> Maybe Object) -> Maybe (Vector Object)
forall a b. (a -> b) -> a -> b
$ \Value
v -> do
        Object Object
item   <- Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
        Object Object
index_ <- Key
"index" Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
`AC.lookup` Object
item
          -- ES <= 2.x returns 'create' for some reason, so consider both.
          Maybe Value -> Maybe Value -> Maybe Value
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Key
"create" Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
`AC.lookup` Object
item
        Object -> Maybe Object
forall (f :: * -> *) a. Applicative f => a -> f a
pure Object
index_
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Vector Object -> Int
forall a. Vector a -> Int
V.length Vector Object
items Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Vector a -> Int
forall a. Vector a -> Int
V.length Vector a
jsonMsgs
      (Bool, Vector Object) -> Maybe (Bool, Vector Object)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
hasErrors, Vector Object
items)

    adjustFailedMessagesWith
      :: (Maybe err -> obj -> obj)
      -> V.Vector (AC.KeyMap obj)
      -> V.Vector (AC.KeyMap err)
      -> V.Vector (AC.KeyMap obj)
    adjustFailedMessagesWith :: (Maybe err -> obj -> obj)
-> Vector (KeyMap obj)
-> Vector (KeyMap err)
-> Vector (KeyMap obj)
adjustFailedMessagesWith Maybe err -> obj -> obj
f Vector (KeyMap obj)
jsonMsgs Vector (KeyMap err)
responses =
      let failed :: Vector (Int, err)
failed = (Int -> KeyMap err -> Maybe (Int, err))
-> Vector (KeyMap err) -> Vector (Int, err)
forall a b. (Int -> a -> Maybe b) -> Vector a -> Vector b
V.imapMaybe (\Int
n KeyMap err
item -> (Int
n, ) (err -> (Int, err)) -> Maybe err -> Maybe (Int, err)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Key
"error" Key -> KeyMap err -> Maybe err
forall v. Key -> KeyMap v -> Maybe v
`AC.lookup` KeyMap err
item) Vector (KeyMap err)
responses
          adjust :: (v -> v) -> Key -> KeyMap v -> KeyMap v
adjust v -> v
act Key
key KeyMap v
m = case Key -> KeyMap v -> Maybe v
forall v. Key -> KeyMap v -> Maybe v
AC.lookup Key
key KeyMap v
m of
            Maybe v
Nothing -> KeyMap v
m
            Just v
v -> Key -> v -> KeyMap v -> KeyMap v
forall v. Key -> v -> KeyMap v -> KeyMap v
AC.insert Key
key (v -> v
act v
v) KeyMap v
m
      in (((Int, err) -> KeyMap obj)
-> Vector (Int, err) -> Vector (KeyMap obj)
forall a b. (a -> b) -> Vector a -> Vector b
`V.map` Vector (Int, err)
failed) (((Int, err) -> KeyMap obj) -> Vector (KeyMap obj))
-> ((Int, err) -> KeyMap obj) -> Vector (KeyMap obj)
forall a b. (a -> b) -> a -> b
$ \(Int
n, err
err) -> (obj -> obj) -> Key -> KeyMap obj -> KeyMap obj
forall v. (v -> v) -> Key -> KeyMap v -> KeyMap v
adjust (Maybe err -> obj -> obj
f (Maybe err -> obj -> obj) -> Maybe err -> obj -> obj
forall a b. (a -> b) -> a -> b
$ err -> Maybe err
forall a. a -> Maybe a
Just err
err) Key
"data" (KeyMap obj -> KeyMap obj) -> KeyMap obj -> KeyMap obj
forall a b. (a -> b) -> a -> b
$ Vector (KeyMap obj)
jsonMsgs Vector (KeyMap obj) -> Int -> KeyMap obj
forall a. Vector a -> Int -> a
V.! Int
n

    printEsError :: Text -> Value -> IO ()
printEsError Text
msg Value
body =
      Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"elasticSearchLogger: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Value -> Text
prettyJson Value
body

    retryOnException :: forall r. IORef (Maybe EsVersion) -> IO r -> IO r
    retryOnException :: IORef (Maybe EsVersion) -> IO r -> IO r
retryOnException IORef (Maybe EsVersion)
versionRef IO r
m = IO r -> IO (Either SomeException r)
forall e a. Exception e => IO a -> IO (Either e a)
try IO r
m IO (Either SomeException r)
-> (Either SomeException r -> IO r) -> IO r
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left (SomeException
ex::SomeException) -> do
        [Char] -> IO ()
putStrLn ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"ElasticSearch: unexpected error: "
          [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> SomeException -> [Char]
forall a. Show a => a -> [Char]
show SomeException
ex [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
", retrying in 10 seconds"
        -- If there was an exception, ElasticSearch version might've changed, so
        -- reset it.
        IORef (Maybe EsVersion) -> Maybe EsVersion -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef (Maybe EsVersion)
versionRef Maybe EsVersion
forall a. Maybe a
Nothing
        Int -> IO ()
threadDelay (Int -> IO ()) -> Int -> IO ()
forall a b. (a -> b) -> a -> b
$ Int
10 Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
1000000
        IORef (Maybe EsVersion) -> IO r -> IO r
forall r. IORef (Maybe EsVersion) -> IO r -> IO r
retryOnException IORef (Maybe EsVersion)
versionRef IO r
m
      Right r
result -> r -> IO r
forall (m :: * -> *) a. Monad m => a -> m a
return r
result

    prettyJson :: Value -> T.Text
    prettyJson :: Value -> Text
prettyJson = Text -> Text
TL.toStrict
               (Text -> Text) -> (Value -> Text) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> Text
T.toLazyText
               (Builder -> Text) -> (Value -> Builder) -> Value -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Config -> Value -> Builder
forall a. ToJSON a => Config -> a -> Builder
encodePrettyToTextBuilder' Config
defConfig { confIndent :: Indent
confIndent = Int -> Indent
Spaces Int
2 }

    toJsonMsg :: LogMessage -> Object
    toJsonMsg :: LogMessage -> Object
toJsonMsg LogMessage
msg = let Object Object
jMsg = LogMessage -> Value
forall a. ToJSON a => a -> Value
toJSON LogMessage
msg in Object
jMsg

----------------------------------------

-- | Check that login credentials are specified properly.
--
-- @since 0.10.0.0
checkElasticSearchLogin :: ElasticSearchConfig -> IO ()
checkElasticSearchLogin :: ElasticSearchConfig -> IO ()
checkElasticSearchLogin ElasticSearchConfig{Bool
Int
Maybe (Text, Text)
Text
esLoginInsecure :: Bool
esLogin :: Maybe (Text, Text)
esMapping :: Text
esReplicaCount :: Int
esShardCount :: Int
esIndex :: Text
esServer :: Text
esLoginInsecure :: ElasticSearchConfig -> Bool
esLogin :: ElasticSearchConfig -> Maybe (Text, Text)
esMapping :: ElasticSearchConfig -> Text
esReplicaCount :: ElasticSearchConfig -> Int
esShardCount :: ElasticSearchConfig -> Int
esIndex :: ElasticSearchConfig -> Text
esServer :: ElasticSearchConfig -> Text
..} =
    Bool -> IO () -> IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe (Text, Text) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Text, Text)
esLogin
          Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
esLoginInsecure
          Bool -> Bool -> Bool
&& Bool -> Bool
not (Text
"https:" Text -> Text -> Bool
`T.isPrefixOf` Text
esServer)) (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$
      [Char] -> IO ()
forall a. HasCallStack => [Char] -> a
error ([Char] -> IO ()) -> [Char] -> IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"ElasticSearch: insecure login: "
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"Attempting to send login credentials over an insecure connection. "
        [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> [Char]
"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 :: ElasticSearchConfig -> IO (Either HttpException ())
checkElasticSearchConnection ElasticSearchConfig
esConf =
  (Response Value -> ())
-> Either HttpException (Response Value) -> Either HttpException ()
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (() -> Response Value -> ()
forall a b. a -> b -> a
const ()) (Either HttpException (Response Value) -> Either HttpException ())
-> IO (Either HttpException (Response Value))
-> IO (Either HttpException ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (EsEnv -> IO (Either HttpException (Response Value))
serverInfo (EsEnv -> IO (Either HttpException (Response Value)))
-> IO EsEnv -> IO (Either HttpException (Response Value))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ElasticSearchConfig -> IO EsEnv
mkEsEnv ElasticSearchConfig
esConf)