{-# 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.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.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
(ElasticSearchConfig -> ElasticSearchConfig -> Bool)
-> (ElasticSearchConfig -> ElasticSearchConfig -> Bool)
-> Eq ElasticSearchConfig
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
(Int -> ElasticSearchConfig -> ShowS)
-> (ElasticSearchConfig -> String)
-> ([ElasticSearchConfig] -> ShowS)
-> Show ElasticSearchConfig
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. ElasticSearchConfig -> Rep ElasticSearchConfig x)
-> (forall x. Rep ElasticSearchConfig x -> ElasticSearchConfig)
-> Generic ElasticSearchConfig
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 :: Text
-> Text
-> Int
-> Int
-> Text
-> Maybe (Text, Text)
-> Bool
-> ElasticSearchConfig
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         = Maybe (Text, Text)
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
(EsVersion -> EsVersion -> Bool)
-> (EsVersion -> EsVersion -> Bool) -> Eq EsVersion
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
Eq EsVersion
-> (EsVersion -> EsVersion -> Ordering)
-> (EsVersion -> EsVersion -> Bool)
-> (EsVersion -> EsVersion -> Bool)
-> (EsVersion -> EsVersion -> Bool)
-> (EsVersion -> EsVersion -> Bool)
-> (EsVersion -> EsVersion -> EsVersion)
-> (EsVersion -> EsVersion -> EsVersion)
-> Ord 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
$cp1Ord :: Eq EsVersion
Ord)

parseEsVersion :: Value -> Maybe EsVersion
parseEsVersion :: Value -> Maybe EsVersion
parseEsVersion Value
js = do
  Object Object
props <- Value -> Maybe Value
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
js
  Object Object
version <- Key
"version" Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
`AC.lookup` Object
props
  String Text
number <- Key
"number" Key -> Object -> Maybe Value
forall v. Key -> KeyMap v -> Maybe v
`AC.lookup` Object
version
  [Int
v1, Int
v2, Int
v3] <- (Text -> Maybe Int) -> [Text] -> Maybe [Int]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (String -> Maybe Int
forall (m :: * -> *) b. (Read b, MonadFail m) => String -> m b
maybeRead (String -> Maybe Int) -> (Text -> String) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack) ([Text] -> Maybe [Int]) -> [Text] -> Maybe [Int]
forall a b. (a -> b) -> a -> b
$ Text -> Text -> [Text]
T.splitOn Text
"." Text
number
  EsVersion -> Maybe EsVersion
forall (f :: * -> *) a. Applicative f => a -> f a
pure (EsVersion -> Maybe EsVersion) -> EsVersion -> Maybe EsVersion
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
"")] <- [(b, String)] -> m [(b, String)]
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([(b, String)] -> m [(b, String)])
-> [(b, String)] -> m [(b, String)]
forall a b. (a -> b) -> a -> b
$ ReadS b
forall a. Read a => ReadS a
reads String
s
      b -> m b
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 = IO (Response Value) -> IO (Either HttpException (Response Value))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Response Value) -> IO (Either HttpException (Response Value)))
-> IO (Response Value)
-> IO (Either HttpException (Response Value))
forall a b. (a -> b) -> a -> b
$ EsEnv
-> Method -> [Text] -> Maybe ByteString -> IO (Response Value)
dispatch EsEnv
env Method
methodGet [] Maybe ByteString
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 =
  Response Value -> Bool
forall a. Response a -> Bool
isSuccess (Response Value -> Bool) -> IO (Response Value) -> IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> EsEnv
-> Method -> [Text] -> Maybe ByteString -> IO (Response Value)
dispatch EsEnv
env Method
methodHead [Text
index] Maybe ByteString
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
-> Method -> [Text] -> Maybe ByteString -> IO (Response Value)
dispatch EsEnv
env Method
methodPut [Text
index] (Maybe ByteString -> IO (Response Value))
-> (Value -> Maybe ByteString) -> Value -> IO (Response Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (Value -> ByteString) -> Value -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> IO (Response Value)) -> Value -> IO (Response Value)
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
    [ Key
"settings" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
      [ Key
"number_of_shards" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
esShardCount
      , Key
"number_of_replicas" Key -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Int
esReplicaCount
      ]
    , Key
"mappings" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= if EsVersion
version EsVersion -> EsVersion -> Bool
forall a. Ord a => a -> a -> Bool
>= EsVersion
esV7
                    then Value
logsMapping
                    else [Pair] -> Value
object [ Text -> Key
AC.fromText Text
esMapping Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Value
logsMapping ]
    ]
  where
    logsMapping :: Value
logsMapping = [Pair] -> Value
object
      [ Key
"properties" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
        [ Key
"time" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
          [ Key
"type"   Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
timeTy
          , Key
"format" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= (Text
"date_time"::T.Text)
          ]
        , Key
"domain" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
          [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
textTy
          ]
        , Key
"level" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
          [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
textTy
          ]
        , Key
"component" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
          [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
textTy
          ]
        , Key
"message" Key -> Value -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= [Pair] -> Value
object
          [ Key
"type" Key -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Key -> v -> kv
.= Text
textTy
          ]
        ]
      ]
      where
        timeTy :: T.Text
        timeTy :: Text
timeTy = if EsVersion
version EsVersion -> EsVersion -> Bool
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 EsVersion -> EsVersion -> Bool
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
-> Method -> [Text] -> Maybe ByteString -> IO (Response Value)
dispatch EsEnv
env Method
methodPost [Text]
route (Maybe ByteString -> IO (Response Value))
-> (Builder -> Maybe ByteString) -> Builder -> IO (Response Value)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (ByteString -> Maybe ByteString)
-> (Builder -> ByteString) -> Builder -> Maybe ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BSB.toLazyByteString (Builder -> IO (Response Value)) -> Builder -> IO (Response Value)
forall a b. (a -> b) -> a -> b
$ (Object -> Builder) -> Vector Object -> Builder
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 EsVersion -> EsVersion -> Bool
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
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BSB.char8 Char
'\n'
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
BSB.lazyByteString (Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> ByteString) -> Value -> ByteString
forall a b. (a -> b) -> a -> b
$ Object -> Value
Object Object
obj)
            Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Char -> Builder
BSB.char8 Char
'\n'
      where
        ixCmd :: Builder
ixCmd = ByteString -> Builder
BSB.lazyByteString (ByteString -> Builder)
-> (Value -> ByteString) -> Value -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Value -> ByteString
forall a. ToJSON a => a -> ByteString
encode (Value -> Builder) -> Value -> Builder
forall a b. (a -> b) -> a -> b
$ [Pair] -> Value
object
          [ Key
"index" Key -> Value -> Pair
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 =
  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
$ EsEnv
-> Method -> [Text] -> Maybe ByteString -> IO (Response Value)
dispatch EsEnv
env Method
methodPost [Text
index, Text
"_refresh"] Maybe ByteString
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
  Manager
envManager <- ManagerSettings -> IO Manager
newManager ManagerSettings
tlsManagerSettings
  let envServer :: Text
envServer = Text
esServer
      envRequestHook :: Request -> Request
envRequestHook = (Request -> Request)
-> ((Text, Text) -> Request -> Request)
-> Maybe (Text, Text)
-> Request
-> Request
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Request -> Request
forall a. a -> a
id (Text, Text) -> Request -> Request
mkAuthHook Maybe (Text, Text)
esLogin
  EsEnv -> IO EsEnv
forall (f :: * -> *) a. Applicative f => a -> f a
pure EsEnv :: Text -> Manager -> (Request -> Request) -> EsEnv
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) = Method -> Method -> Request -> Request
applyBasicAuth (Text -> Method
T.encodeUtf8 Text
u) (Text -> Method
T.encodeUtf8 Text
p)

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

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

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