{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveGeneric #-}
module Log.Backend.ElasticSearch.Internal
  ( 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 Control.Exception
import Control.Monad
import Data.Aeson
import Data.Ix (inRange)
import Data.Maybe
import GHC.Generics (Generic)
import Network.HTTP.Client
import Network.HTTP.Types
#if OPENSSL
import Network.HTTP.Client.OpenSSL (newOpenSSLManager, withOpenSSL)
#else
import Network.HTTP.Client.TLS (tlsManagerSettings)
#endif
import qualified Data.ByteString.Builder as BSB
import qualified Data.ByteString.Lazy.Char8 as BSL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Vector as V

import qualified Log.Internal.Aeson.Compat as AC

-- | Configuration for the Elasticsearch 'Logger'. See
-- <https://www.elastic.co/guide/en/elasticsearch/reference/current/glossary.html>
-- for the explanation of terms.
data ElasticSearchConfig = ElasticSearchConfig
  { ElasticSearchConfig -> Text
esServer        :: !T.Text -- ^ Elasticsearch server address.
  , ElasticSearchConfig -> Text
esIndex         :: !T.Text -- ^ Elasticsearch index name.
  , ElasticSearchConfig -> Int
esShardCount    :: !Int
    -- ^ Elasticsearch shard count for the named index.
    --
    -- @since 0.10.0.0
  , ElasticSearchConfig -> Int
esReplicaCount  :: !Int
    -- ^ Elasticsearch replica count for the named index.
    --
    -- @since 0.10.0.0
  , ElasticSearchConfig -> Text
esMapping       :: !T.Text
    -- ^ Elasticsearch mapping name (unused with ES >= 7.0.0)
  , ElasticSearchConfig -> Maybe (Text, Text)
esLogin         :: Maybe (T.Text, T.Text)
    -- ^ Elasticsearch basic authentication username and password.
  , ElasticSearchConfig -> Bool
esLoginInsecure :: !Bool
    -- ^ Allow basic authentication over non-TLS connections.
  } deriving (ElasticSearchConfig -> ElasticSearchConfig -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ElasticSearchConfig -> ElasticSearchConfig -> Bool
$c/= :: ElasticSearchConfig -> ElasticSearchConfig -> Bool
== :: ElasticSearchConfig -> ElasticSearchConfig -> Bool
$c== :: ElasticSearchConfig -> ElasticSearchConfig -> Bool
Eq, Int -> ElasticSearchConfig -> ShowS
[ElasticSearchConfig] -> ShowS
ElasticSearchConfig -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ElasticSearchConfig] -> ShowS
$cshowList :: [ElasticSearchConfig] -> ShowS
show :: ElasticSearchConfig -> String
$cshow :: ElasticSearchConfig -> String
showsPrec :: Int -> ElasticSearchConfig -> ShowS
$cshowsPrec :: Int -> ElasticSearchConfig -> ShowS
Show, forall x. Rep ElasticSearchConfig x -> ElasticSearchConfig
forall x. ElasticSearchConfig -> Rep ElasticSearchConfig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ElasticSearchConfig x -> ElasticSearchConfig
$cfrom :: forall x. ElasticSearchConfig -> Rep ElasticSearchConfig x
Generic)

-- | Sensible defaults for 'ElasticSearchConfig'.
defaultElasticSearchConfig :: ElasticSearchConfig
defaultElasticSearchConfig :: ElasticSearchConfig
defaultElasticSearchConfig = ElasticSearchConfig
  { esServer :: Text
esServer        = Text
"http://localhost:9200"
  , esIndex :: Text
esIndex         = Text
"logs"
  , esShardCount :: Int
esShardCount    = Int
4
  , esReplicaCount :: Int
esReplicaCount  = Int
1
  , esMapping :: Text
esMapping       = Text
"log"
  , esLogin :: Maybe (Text, Text)
esLogin         = forall a. Maybe a
Nothing
  , esLoginInsecure :: Bool
esLoginInsecure = Bool
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 (EsVersion -> EsVersion -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: EsVersion -> EsVersion -> Bool
$c/= :: EsVersion -> EsVersion -> Bool
== :: EsVersion -> EsVersion -> Bool
$c== :: EsVersion -> EsVersion -> Bool
Eq, Eq EsVersion
EsVersion -> EsVersion -> Bool
EsVersion -> EsVersion -> Ordering
EsVersion -> EsVersion -> EsVersion
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: EsVersion -> EsVersion -> EsVersion
$cmin :: EsVersion -> EsVersion -> EsVersion
max :: EsVersion -> EsVersion -> EsVersion
$cmax :: EsVersion -> EsVersion -> EsVersion
>= :: EsVersion -> EsVersion -> Bool
$c>= :: EsVersion -> EsVersion -> Bool
> :: EsVersion -> EsVersion -> Bool
$c> :: EsVersion -> EsVersion -> Bool
<= :: EsVersion -> EsVersion -> Bool
$c<= :: EsVersion -> EsVersion -> Bool
< :: EsVersion -> EsVersion -> Bool
$c< :: EsVersion -> EsVersion -> Bool
compare :: EsVersion -> EsVersion -> Ordering
$ccompare :: EsVersion -> EsVersion -> Ordering
Ord)

parseEsVersion :: Value -> Maybe EsVersion
parseEsVersion :: Value -> Maybe EsVersion
parseEsVersion Value
js = do
  Object Object
props <- forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
js
  Object Object
version <- Key
"version" forall v. Key -> KeyMap v -> Maybe v
`AC.lookup` Object
props
  case Key
"distribution" forall v. Key -> KeyMap v -> Maybe v
`AC.lookup` Object
version of
    Just Value
"opensearch" -> do
      -- OpenSearch is compatible (so far) with esV7 mappings.
      forall (f :: * -> *) a. Applicative f => a -> f a
pure EsVersion
esV7
    Maybe Value
_ -> do
      String Text
number <- Key
"number" forall v. Key -> KeyMap v -> Maybe v
`AC.lookup` Object
version
      [Int
v1, Int
v2, Int
v3] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {m :: * -> *} {b}. (Read b, MonadFail m) => String -> m b
maybeRead forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"." Text
number
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Int -> Int -> Int -> EsVersion
EsVersion Int
v1 Int
v2 Int
v3
  where
    maybeRead :: String -> m b
maybeRead String
s = do
      [(b
v, String
"")] <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Read a => ReadS a
reads String
s
      forall (f :: * -> *) a. Applicative f => a -> f a
pure b
v

-- | Minimum version with split 'string' type.
esV5 :: EsVersion
esV5 :: EsVersion
esV5 = Int -> Int -> Int -> EsVersion
EsVersion Int
5 Int
0 Int
0

-- | Minimum version without mapping types.
esV7 :: EsVersion
esV7 :: EsVersion
esV7 = Int -> Int -> Int -> EsVersion
EsVersion Int
7 Int
0 Int
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 :: EsEnv -> IO (Either HttpException (Response Value))
serverInfo EsEnv
env = forall e a. Exception e => IO a -> IO (Either e a)
try forall a b. (a -> b) -> a -> b
$ EsEnv
-> ByteString -> [Text] -> Maybe ByteString -> IO (Response Value)
dispatch EsEnv
env ByteString
methodGet [] forall a. Maybe a
Nothing

-- | Check that given index exists.
indexExists :: EsEnv -> T.Text -> IO Bool
indexExists :: EsEnv -> Text -> IO Bool
indexExists EsEnv
env Text
index =
  forall a. Response a -> Bool
isSuccess forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EsEnv
-> ByteString -> [Text] -> Maybe ByteString -> IO (Response Value)
dispatch EsEnv
env ByteString
methodHead [Text
index] forall a. Maybe a
Nothing

-- | Create an index with given mapping.
createIndexWithMapping
  :: EsVersion
  -> EsEnv
  -> ElasticSearchConfig
  -> T.Text
  -> IO (Response Value)
createIndexWithMapping :: EsVersion
-> EsEnv -> ElasticSearchConfig -> Text -> IO (Response Value)
createIndexWithMapping EsVersion
version EsEnv
env 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
..} Text
index = do
  EsEnv
-> ByteString -> [Text] -> Maybe ByteString -> IO (Response Value)
dispatch EsEnv
env ByteString
methodPut [Text
index] forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
    [ Key
"settings" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
      [ Key
"number_of_shards" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
esShardCount
      , Key
"number_of_replicas" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
esReplicaCount
      ]
    , Key
"mappings" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= if EsVersion
version forall a. Ord a => a -> a -> Bool
>= EsVersion
esV7
                    then Value
logsMapping
                    else [Pair] -> Value
object [ Text -> Key
AC.fromText Text
esMapping forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
logsMapping ]
    ]
  where
    logsMapping :: Value
logsMapping = [Pair] -> Value
object
      [ Key
"properties" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
        [ Key
"time" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
          [ Key
"type"   forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
timeTy
          , Key
"format" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"date_time"::T.Text)
          ]
        , Key
"domain" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
          [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
textTy
          ]
        , Key
"level" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
          [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
textTy
          ]
        , Key
"component" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
          [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
textTy
          ]
        , Key
"message" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
          [ Key
"type" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
textTy
          ]
        ]
      ]
      where
        timeTy :: T.Text
        timeTy :: Text
timeTy = if EsVersion
version forall a. Ord a => a -> a -> Bool
>= EsVersion
esV7
                 then Text
"date_nanos"
                 else Text
"date"

        textTy :: T.Text
        textTy :: Text
textTy = if EsVersion
version forall a. Ord a => a -> a -> Bool
>= EsVersion
esV5
                 then Text
"text"
                 else Text
"string"

-- Index multiple log messages.
bulkIndex
  :: EsVersion
  -> EsEnv
  -> ElasticSearchConfig
  -> T.Text
  -> V.Vector Object
  -> IO (Response Value)
bulkIndex :: EsVersion
-> EsEnv
-> ElasticSearchConfig
-> Text
-> Vector Object
-> IO (Response Value)
bulkIndex EsVersion
version EsEnv
env ElasticSearchConfig
conf Text
index Vector Object
objs = do
  EsEnv
-> ByteString -> [Text] -> Maybe ByteString -> IO (Response Value)
dispatch EsEnv
env ByteString
methodPost [Text]
route forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BSB.toLazyByteString forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Object -> Builder
ixOp Vector Object
objs
  where
    route :: [Text]
route = if EsVersion
version forall a. Ord a => a -> a -> Bool
>= EsVersion
esV7
            then [Text
index, Text
"_bulk"]
            else [Text
index, ElasticSearchConfig -> Text
esMapping ElasticSearchConfig
conf, Text
"_bulk"]

    ixOp :: Object -> Builder
ixOp Object
obj = Builder
ixCmd
            forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BSB.char8 Char
'\n'
            forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BSB.lazyByteString (forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ Object -> Value
Object Object
obj)
            forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BSB.char8 Char
'\n'
      where
        ixCmd :: Builder
ixCmd = ByteString -> Builder
BSB.lazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToJSON a => a -> ByteString
encode forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
          [ Key
"index" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object []
          ]

-- Refresh given index.
refreshIndex :: EsEnv -> T.Text -> IO ()
refreshIndex :: EsEnv -> Text -> IO ()
refreshIndex EsEnv
env Text
index =
  forall (f :: * -> *) a. Functor f => f a -> f ()
void forall a b. (a -> b) -> a -> b
$ EsEnv
-> ByteString -> [Text] -> Maybe ByteString -> IO (Response Value)
dispatch EsEnv
env ByteString
methodPost [Text
index, Text
"_refresh"] forall a. Maybe a
Nothing

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

data EsEnv = EsEnv
  { EsEnv -> Text
envServer      :: !T.Text
  , EsEnv -> Manager
envManager     :: !Manager
  , EsEnv -> Request -> Request
envRequestHook :: !(Request -> Request)
  }

mkEsEnv :: ElasticSearchConfig -> IO EsEnv
mkEsEnv :: ElasticSearchConfig -> IO EsEnv
mkEsEnv 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
#if OPENSSL
  Manager
envManager <- forall a. IO a -> IO a
withOpenSSL forall (m :: * -> *). MonadIO m => m Manager
newOpenSSLManager
#else
  envManager <- newManager tlsManagerSettings
#endif
  let envServer :: Text
envServer = Text
esServer
      envRequestHook :: Request -> Request
envRequestHook = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (Text, Text) -> Request -> Request
mkAuthHook Maybe (Text, Text)
esLogin
  forall (f :: * -> *) a. Applicative f => a -> f a
pure EsEnv{Text
Manager
Request -> Request
envRequestHook :: Request -> Request
envServer :: Text
envManager :: Manager
envRequestHook :: Request -> Request
envManager :: Manager
envServer :: Text
..}
  where
    mkAuthHook :: (Text, Text) -> Request -> Request
mkAuthHook (Text
u, Text
p) = ByteString -> ByteString -> Request -> Request
applyBasicAuth (Text -> ByteString
T.encodeUtf8 Text
u) (Text -> ByteString
T.encodeUtf8 Text
p)

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

dispatch :: EsEnv
         -> Method
         -> [T.Text]
         -> Maybe BSL.ByteString
         -> IO (Response Value)
dispatch :: EsEnv
-> ByteString -> [Text] -> Maybe ByteString -> IO (Response Value)
dispatch EsEnv{Text
Manager
Request -> Request
envRequestHook :: Request -> Request
envManager :: Manager
envServer :: Text
envRequestHook :: EsEnv -> Request -> Request
envManager :: EsEnv -> Manager
envServer :: EsEnv -> Text
..} ByteString
dMethod [Text]
url Maybe ByteString
body = do
  Request
initReq <- forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Text
T.intercalate Text
"/" forall a b. (a -> b) -> a -> b
$ Text
envServer forall a. a -> [a] -> [a]
: [Text]
url
  let req :: Request
req = Request -> Request
envRequestHook forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Request
setRequestIgnoreStatus forall a b. (a -> b) -> a -> b
$ Request
initReq
        { method :: ByteString
method = ByteString
dMethod
        , requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe ByteString
BSL.empty Maybe ByteString
body
        , requestHeaders :: RequestHeaders
requestHeaders = (HeaderName
"Content-Type", ByteString
"application/json") forall a. a -> [a] -> [a]
: Request -> RequestHeaders
requestHeaders Request
initReq
        }
  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Value
decodeReply forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
envManager

decodeReply :: BSL.ByteString -> Value
decodeReply :: ByteString -> Value
decodeReply ByteString
bs = case forall a. FromJSON a => ByteString -> Either String a
eitherDecode' ByteString
bs of
  Right Value
js  -> Value
js
  Left  String
err -> [Pair] -> Value
object [Key
"decoding_error" forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= String
err]

isSuccess :: Response a -> Bool
isSuccess :: forall a. Response a -> Bool
isSuccess = forall a. (Int -> Bool) -> Response a -> Bool
statusCheck (forall a. Ix a => (a, a) -> a -> Bool
inRange (Int
200, Int
299))
  where
    statusCheck :: (Int -> Bool) -> Response a -> Bool
    statusCheck :: forall a. (Int -> Bool) -> Response a -> Bool
statusCheck Int -> Bool
p = Int -> Bool
p forall b c a. (b -> c) -> (a -> b) -> a -> c
. Status -> Int
statusCode forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall body. Response body -> Status
responseStatus