-- | 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.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 :: 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 (HashMap Text Value)
jsonMsgs = [HashMap Text Value] -> Vector (HashMap Text Value)
forall a. [a] -> Vector a
V.fromList ([HashMap Text Value] -> Vector (HashMap Text Value))
-> [HashMap Text Value] -> Vector (HashMap Text Value)
forall a b. (a -> b) -> a -> b
$ (LogMessage -> HashMap Text Value)
-> [LogMessage] -> [HashMap Text Value]
forall a b. (a -> b) -> [a] -> [b]
map LogMessage -> HashMap Text Value
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 (HashMap Text Value)
-> IO (Response Value)
bulkIndex EsVersion
version EsEnv
env ElasticSearchConfig
esConf Text
index Vector (HashMap Text Value)
jsonMsgs
      -- Try to parse parts of reply to get information about log messages that
      -- failed to be inserted for some reason.
      case Vector (HashMap Text Value)
-> Value -> Maybe (Bool, Vector (HashMap Text Value))
forall a.
Vector a -> Value -> Maybe (Bool, Vector (HashMap Text Value))
checkForBulkErrors Vector (HashMap Text Value)
jsonMsgs Value
reply of
        Maybe (Bool, Vector (HashMap Text Value))
Nothing -> Text -> Value -> IO ()
printEsError Text
"unexpected response" Value
reply
        Just (Bool
hasErrors, Vector (HashMap Text Value)
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 (HashMap Text Value)
newMsgs =
                let modifyData :: Maybe Value -> Value -> Value
                    modifyData :: Maybe Value -> Value -> Value
modifyData Maybe Value
merr (Object HashMap Text Value
hm) = HashMap Text Value -> Value
Object (HashMap Text Value -> Value) -> HashMap Text Value -> Value
forall a b. (a -> b) -> a -> b
$
                      let newData :: HashMap Text Value
newData = (HashMap Text Value -> Text -> Value -> HashMap Text Value)
-> HashMap Text Value -> HashMap Text Value -> HashMap Text Value
forall a k v. (a -> k -> v -> a) -> a -> HashMap k v -> a
H.foldlWithKey' HashMap Text Value -> Text -> Value -> HashMap Text Value
forall a.
(Eq a, Hashable a, Semigroup a, IsString a) =>
HashMap a Value -> a -> Value -> HashMap a Value
keyAddValueTypeSuffix HashMap Text Value
forall k v. HashMap k v
H.empty HashMap Text Value
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 -> HashMap Text Value
newData HashMap Text Value -> HashMap Text Value -> HashMap Text Value
forall k v.
(Eq k, Hashable k) =>
HashMap k v -> HashMap k v -> HashMap k v
`H.union` Text -> Value -> HashMap Text Value
forall k v. Hashable k => k -> v -> HashMap k v
H.singleton Text
"__es_error" Value
err
                        Maybe Value
Nothing  -> HashMap Text Value
newData
                    modifyData Maybe Value
_ Value
v = Value
v

                    keyAddValueTypeSuffix :: HashMap a Value -> a -> Value -> HashMap a Value
keyAddValueTypeSuffix HashMap a Value
acc a
k Value
v = a -> Value -> HashMap a Value -> HashMap a Value
forall k v.
(Eq k, Hashable k) =>
k -> v -> HashMap k v -> HashMap k v
H.insert
                      (case Value
v of
                          Object{} -> a
k a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"_object"
                          Array{}  -> a
k a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"_array"
                          String{} -> a
k a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"_string"
                          Number{} -> a
k a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"_number"
                          Bool{}   -> a
k a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"_bool"
                          Null{}   -> a
k a -> a -> a
forall a. Semigroup a => a -> a -> a
<> a
"_null"
                      ) (Maybe Value -> Value -> Value
modifyData Maybe Value
forall a. Maybe a
Nothing Value
v) HashMap a Value
acc
                in (Maybe Value -> Value -> Value)
-> Vector (HashMap Text Value)
-> Vector (HashMap Text Value)
-> Vector (HashMap Text Value)
forall err obj.
(Maybe err -> obj -> obj)
-> Vector (HashMap Text obj)
-> Vector (HashMap Text err)
-> Vector (HashMap Text obj)
adjustFailedMessagesWith Maybe Value -> Value -> Value
modifyData Vector (HashMap Text Value)
jsonMsgs Vector (HashMap Text Value)
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 (HashMap Text Value)
-> IO (Response Value)
bulkIndex EsVersion
version EsEnv
env ElasticSearchConfig
esConf Text
index Vector (HashMap Text Value)
newMsgs
          case Vector (HashMap Text Value)
-> Value -> Maybe (Bool, Vector (HashMap Text Value))
forall a.
Vector a -> Value -> Maybe (Bool, Vector (HashMap Text Value))
checkForBulkErrors Vector (HashMap Text Value)
newMsgs Value
newReply of
            Maybe (Bool, Vector (HashMap Text Value))
Nothing -> Text -> Value -> IO ()
printEsError Text
"unexpected response" Value
newReply
            Just (Bool
newHasErrors, Vector (HashMap Text Value)
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 (HashMap Text Value)
newerMsgs =
                    let modifyData :: Maybe Value -> Value -> Value
                        modifyData :: Maybe Value -> Value -> Value
modifyData (Just Value
err) Object{} = [Pair] -> Value
object [ Text
"__es_error" Text -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Value
err ]
                        modifyData Maybe Value
_ Value
v = Value
v
                    in (Maybe Value -> Value -> Value)
-> Vector (HashMap Text Value)
-> Vector (HashMap Text Value)
-> Vector (HashMap Text Value)
forall err obj.
(Maybe err -> obj -> obj)
-> Vector (HashMap Text obj)
-> Vector (HashMap Text err)
-> Vector (HashMap Text obj)
adjustFailedMessagesWith Maybe Value -> Value -> Value
modifyData Vector (HashMap Text Value)
newMsgs Vector (HashMap Text Value)
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 (HashMap Text Value)
-> IO (Response Value)
bulkIndex EsVersion
version EsEnv
env ElasticSearchConfig
esConf Text
index Vector (HashMap Text Value)
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 (HashMap Text Value))
checkForBulkErrors Vector a
jsonMsgs Value
replyBody = do
      Object HashMap Text Value
response <- Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
replyBody
      Bool Bool
hasErrors  <- Text
"errors" Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`H.lookup` HashMap Text Value
response
      Array Array
jsonItems <- Text
"items"  Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`H.lookup` HashMap Text Value
response
      Vector (HashMap Text Value)
items <- Array
-> (Value -> Maybe (HashMap Text Value))
-> Maybe (Vector (HashMap Text Value))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
F.forM Array
jsonItems ((Value -> Maybe (HashMap Text Value))
 -> Maybe (Vector (HashMap Text Value)))
-> (Value -> Maybe (HashMap Text Value))
-> Maybe (Vector (HashMap Text Value))
forall a b. (a -> b) -> a -> b
$ \Value
v -> do
        Object HashMap Text Value
item   <- Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
v
        Object HashMap Text Value
index_ <- Text
"index" Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`H.lookup` HashMap Text Value
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
<|> Text
"create" Text -> HashMap Text Value -> Maybe Value
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`H.lookup` HashMap Text Value
item
        HashMap Text Value -> Maybe (HashMap Text Value)
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap Text Value
index_
      Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Vector (HashMap Text Value) -> Int
forall a. Vector a -> Int
V.length Vector (HashMap Text Value)
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 (HashMap Text Value))
-> Maybe (Bool, Vector (HashMap Text Value))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Bool
hasErrors, Vector (HashMap Text Value)
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 :: (Maybe err -> obj -> obj)
-> Vector (HashMap Text obj)
-> Vector (HashMap Text err)
-> Vector (HashMap Text obj)
adjustFailedMessagesWith Maybe err -> obj -> obj
f Vector (HashMap Text obj)
jsonMsgs Vector (HashMap Text err)
responses =
      let failed :: Vector (Int, err)
failed = (Int -> HashMap Text err -> Maybe (Int, err))
-> Vector (HashMap Text err) -> Vector (Int, err)
forall a b. (Int -> a -> Maybe b) -> Vector a -> Vector b
V.imapMaybe (\Int
n HashMap Text err
item -> (Int
n, ) (err -> (Int, err)) -> Maybe err -> Maybe (Int, err)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text
"error" Text -> HashMap Text err -> Maybe err
forall k v. (Eq k, Hashable k) => k -> HashMap k v -> Maybe v
`H.lookup` HashMap Text err
item) Vector (HashMap Text err)
responses
      in (((Int, err) -> HashMap Text obj)
-> Vector (Int, err) -> Vector (HashMap Text obj)
forall a b. (a -> b) -> Vector a -> Vector b
`V.map` Vector (Int, err)
failed) (((Int, err) -> HashMap Text obj) -> Vector (HashMap Text obj))
-> ((Int, err) -> HashMap Text obj) -> Vector (HashMap Text obj)
forall a b. (a -> b) -> a -> b
$ \(Int
n, err
err) -> (obj -> obj) -> Text -> HashMap Text obj -> HashMap Text obj
forall k v.
(Eq k, Hashable k) =>
(v -> v) -> k -> HashMap k v -> HashMap k v
H.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) Text
"data" (HashMap Text obj -> HashMap Text obj)
-> HashMap Text obj -> HashMap Text obj
forall a b. (a -> b) -> a -> b
$ Vector (HashMap Text obj)
jsonMsgs Vector (HashMap Text obj) -> Int -> HashMap Text 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 -> H.HashMap T.Text Value
    toJsonMsg :: LogMessage -> HashMap Text Value
toJsonMsg LogMessage
msg = let Object HashMap Text Value
jMsg = LogMessage -> Value
forall a. ToJSON a => a -> Value
toJSON LogMessage
msg in HashMap Text Value
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)