-- Copyright (c) 2020-present, EMQX, Inc.
-- All rights reserved.
--
-- This source code is distributed under the terms of a MIT license,
-- found in the LICENSE file.
{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeFamilies #-}

-- | This module provides implementation of user's API
module Database.ClickHouseDriver.HTTP.Client
  ( -- * Setting
    setupEnv,
    runQuery,

    -- * Query
    getByteString,
    getJSON,
    getText,
    getTextM,
    getJsonM,
    insertOneRow,
    insertMany,
    ping,
    exec,
    insertFromFile,

    -- * Connection
    defaultHttpClient,
    httpClient,
    defaultHttpPool,
  )
where

import Control.Concurrent.Async (mapConcurrently)
import Control.Exception (SomeException, try)
import Control.Monad.State.Lazy (MonadIO (..))
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as LBS
import Data.ByteString.Lazy.Builder
  ( char8,
    lazyByteString,
    toLazyByteString,
  )
import qualified Data.ByteString.Lazy.Char8 as C8
import Data.Default.Class (def)
import Data.Hashable (Hashable (hashWithSalt))
import Data.Pool (Pool, withResource)
import qualified Data.Text as T
import Data.Text.Encoding (decodeUtf8)
import Data.Time.Clock (NominalDiffTime)
import Data.Typeable (Typeable)
import Database.ClickHouseDriver.Defines as Defines
  ( _DEFAULT_HOST,
    _DEFAULT_HTTP_PORT,
  )
import Database.ClickHouseDriver.HTTP.Connection
  ( createHttpPool,
    defaultHttpConnection,
    httpConnectDb,
  )
import Database.ClickHouseDriver.HTTP.Helpers
  ( extract,
    genURL,
    toString,
  )
import Database.ClickHouseDriver.HTTP.Types (Format (..), HttpConnection (..), JSONResult)
import Database.ClickHouseDriver.Types (ClickhouseType)
import Haxl.Core
  ( BlockedFetch (..),
    DataSource (fetch),
    DataSourceName (..),
    Env (userEnv),
    GenHaxl,
    PerformFetch (SyncFetch),
    ShowP (..),
    StateKey (State),
    dataFetch,
    initEnv,
    putFailure,
    putSuccess,
    runHaxl,
    stateEmpty,
    stateSet,
  )
import Network.HTTP.Client
  ( RequestBody (..),
    httpLbs,
    method,
    parseRequest,
    requestBody,
    responseBody,
    streamFile,
  )
import Text.Printf (printf)

{-Implementation in Haxl-}
--
data HttpClient a where
  FetchByteString :: String -> HttpClient BS.ByteString
  FetchJSON :: String -> HttpClient BS.ByteString
  FetchCSV :: String -> HttpClient BS.ByteString
  FetchText :: String -> HttpClient BS.ByteString
  Ping :: HttpClient BS.ByteString

deriving instance Show (HttpClient a)

deriving instance Typeable HttpClient

deriving instance Eq (HttpClient a)

instance ShowP HttpClient where showp :: HttpClient a -> String
showp = HttpClient a -> String
forall a. Show a => a -> String
show

instance Hashable (HttpClient a) where
  hashWithSalt :: Int -> HttpClient a -> Int
hashWithSalt Int
salt (FetchByteString String
cmd) = Int -> String -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt String
cmd
  hashWithSalt Int
salt (FetchJSON String
cmd) = Int -> String -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt String
cmd
  hashWithSalt Int
salt (FetchCSV String
cmd) = Int -> String -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt String
cmd
  hashWithSalt Int
salt HttpClient a
Ping = Int -> ByteString -> Int
forall a. Hashable a => Int -> a -> Int
hashWithSalt Int
salt (ByteString
"ok" :: BS.ByteString)

instance DataSourceName HttpClient where
  dataSourceName :: Proxy HttpClient -> Text
dataSourceName Proxy HttpClient
_ = Text
"ClickhouseDataSource"

instance DataSource u HttpClient where
  fetch :: State HttpClient -> Flags -> u -> PerformFetch HttpClient
fetch (State HttpClient
settings) Flags
_flags u
_usrenv = ([BlockedFetch HttpClient] -> IO ()) -> PerformFetch HttpClient
forall (req :: * -> *).
([BlockedFetch req] -> IO ()) -> PerformFetch req
SyncFetch (([BlockedFetch HttpClient] -> IO ()) -> PerformFetch HttpClient)
-> ([BlockedFetch HttpClient] -> IO ()) -> PerformFetch HttpClient
forall a b. (a -> b) -> a -> b
$ \[BlockedFetch HttpClient]
blockedFetches -> do
    String -> Int -> IO ()
forall r. PrintfType r => String -> r
printf String
"Fetching %d queries.\n" ([BlockedFetch HttpClient] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockedFetch HttpClient]
blockedFetches)
    [()]
res <- (BlockedFetch HttpClient -> IO ())
-> [BlockedFetch HttpClient] -> IO [()]
forall (t :: * -> *) a b.
Traversable t =>
(a -> IO b) -> t a -> IO (t b)
mapConcurrently (State HttpClient -> BlockedFetch HttpClient -> IO ()
fetchData State HttpClient
settings) [BlockedFetch HttpClient]
blockedFetches
    case [()]
res of
      [()] -> () -> IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance StateKey HttpClient where
  data State HttpClient
    = SingleHttp HttpConnection
    | HttpPool (Pool HttpConnection)

class HttpEnvironment a where
  toEnv :: a -> State HttpClient
  pick :: a -> IO HttpConnection

instance HttpEnvironment HttpConnection where
  toEnv :: HttpConnection -> State HttpClient
toEnv = HttpConnection -> State HttpClient
SingleHttp
  pick :: HttpConnection -> IO HttpConnection
pick = HttpConnection -> IO HttpConnection
forall (m :: * -> *) a. Monad m => a -> m a
return

instance HttpEnvironment (Pool HttpConnection) where
  toEnv :: Pool HttpConnection -> State HttpClient
toEnv = Pool HttpConnection -> State HttpClient
HttpPool
  pick :: Pool HttpConnection -> IO HttpConnection
pick Pool HttpConnection
pool = Pool HttpConnection
-> (HttpConnection -> IO HttpConnection) -> IO HttpConnection
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
withResource Pool HttpConnection
pool ((HttpConnection -> IO HttpConnection) -> IO HttpConnection)
-> (HttpConnection -> IO HttpConnection) -> IO HttpConnection
forall a b. (a -> b) -> a -> b
$ HttpConnection -> IO HttpConnection
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | fetch function
fetchData ::
  State HttpClient -> --Connection configuration
  BlockedFetch HttpClient -> --fetched data
  IO ()
fetchData :: State HttpClient -> BlockedFetch HttpClient -> IO ()
fetchData (State HttpClient
settings) BlockedFetch HttpClient
fetches = do
  let (String
queryWithType, ResultVar ByteString
var) = case BlockedFetch HttpClient
fetches of
        BlockedFetch (FetchJSON String
query) ResultVar a
var' -> (String
query String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" FORMAT JSON", ResultVar a
ResultVar ByteString
var')
        BlockedFetch (FetchCSV String
query) ResultVar a
var' -> (String
query String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" FORMAT CSV", ResultVar a
ResultVar ByteString
var')
        BlockedFetch (FetchByteString String
query) ResultVar a
var' -> (String
query, ResultVar a
ResultVar ByteString
var')
        BlockedFetch HttpClient a
Ping ResultVar a
var' -> (String
"ping", ResultVar a
ResultVar ByteString
var')
  Either SomeException ByteString
e <- IO ByteString -> IO (Either SomeException ByteString)
forall e a. Exception e => IO a -> IO (Either e a)
Control.Exception.try (IO ByteString -> IO (Either SomeException ByteString))
-> IO ByteString -> IO (Either SomeException ByteString)
forall a b. (a -> b) -> a -> b
$ do
    case State HttpClient
settings of
      SingleHttp http@(HttpConnection _ mng) -> do
        String
url <- HttpConnection -> String -> IO String
genURL HttpConnection
http String
queryWithType
        Request
req <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
        ByteString
ans <- Response ByteString -> ByteString
forall body. Response body -> body
responseBody (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
mng
        return $ ByteString -> ByteString
LBS.toStrict ByteString
ans
      HttpPool pool ->
        Pool HttpConnection
-> (HttpConnection -> IO ByteString) -> IO ByteString
forall (m :: * -> *) a b.
MonadBaseControl IO m =>
Pool a -> (a -> m b) -> m b
withResource Pool HttpConnection
pool ((HttpConnection -> IO ByteString) -> IO ByteString)
-> (HttpConnection -> IO ByteString) -> IO ByteString
forall a b. (a -> b) -> a -> b
$ \conn :: HttpConnection
conn@(HttpConnection HttpParams
_ Manager
mng) -> do
          String
url <- HttpConnection -> String -> IO String
genURL HttpConnection
conn String
queryWithType
          Request
req <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
          ByteString
ans <- Response ByteString -> ByteString
forall body. Response body -> body
responseBody (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
httpLbs Request
req Manager
mng
          return $ ByteString -> ByteString
LBS.toStrict ByteString
ans
  (SomeException -> IO ())
-> (ByteString -> IO ())
-> Either SomeException ByteString
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
    (ResultVar ByteString -> SomeException -> IO ()
forall e a. Exception e => ResultVar a -> e -> IO ()
putFailure ResultVar ByteString
var)
    (ResultVar ByteString -> ByteString -> IO ()
forall a. ResultVar a -> a -> IO ()
putSuccess ResultVar ByteString
var)
    (Either SomeException ByteString
e :: Either SomeException (BS.ByteString))

-- | Fetch data from ClickHouse client in the text format.
getByteString :: String -> GenHaxl u w BS.ByteString
getByteString :: String -> GenHaxl u w ByteString
getByteString = HttpClient ByteString -> GenHaxl u w ByteString
forall u (r :: * -> *) a w.
(DataSource u r, Request r a) =>
r a -> GenHaxl u w a
dataFetch (HttpClient ByteString -> GenHaxl u w ByteString)
-> (String -> HttpClient ByteString)
-> String
-> GenHaxl u w ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> HttpClient ByteString
FetchByteString

getText :: String -> GenHaxl u w T.Text
getText :: String -> GenHaxl u w Text
getText String
cmd = (ByteString -> Text) -> GenHaxl u w ByteString -> GenHaxl u w Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> Text
decodeUtf8 (String -> GenHaxl u w ByteString
forall u w. String -> GenHaxl u w ByteString
getByteString String
cmd)

-- | Fetch data from ClickHouse client in the JSON format.
getJSON :: String -> GenHaxl u w JSONResult
getJSON :: String -> GenHaxl u w JSONResult
getJSON String
cmd = (ByteString -> JSONResult)
-> GenHaxl u w ByteString -> GenHaxl u w JSONResult
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ByteString -> JSONResult
extract (HttpClient ByteString -> GenHaxl u w ByteString
forall u (r :: * -> *) a w.
(DataSource u r, Request r a) =>
r a -> GenHaxl u w a
dataFetch (HttpClient ByteString -> GenHaxl u w ByteString)
-> HttpClient ByteString -> GenHaxl u w ByteString
forall a b. (a -> b) -> a -> b
$ String -> HttpClient ByteString
FetchJSON String
cmd)

-- | Fetch data from Clickhouse client with commands warped in a Traversable monad.
getTextM :: (Monad m, Traversable m) => m String -> GenHaxl u w (m T.Text)
getTextM :: m String -> GenHaxl u w (m Text)
getTextM = (String -> GenHaxl u w Text) -> m String -> GenHaxl u w (m Text)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> GenHaxl u w Text
forall u w. String -> GenHaxl u w Text
getText

-- | Fetch data from Clickhouse client in the format of JSON
getJsonM :: (Monad m, Traversable m) => m String -> GenHaxl u w (m JSONResult)
getJsonM :: m String -> GenHaxl u w (m JSONResult)
getJsonM = (String -> GenHaxl u w JSONResult)
-> m String -> GenHaxl u w (m JSONResult)
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM String -> GenHaxl u w JSONResult
forall u w. String -> GenHaxl u w JSONResult
getJSON

-- | actual function used by user to perform fetching command
exec :: (HttpEnvironment a) => String -> Env a w -> IO (Either C8.ByteString String)
exec :: String -> Env a w -> IO (Either ByteString String)
exec String
cmd' Env a w
env = do
  let cmd :: ByteString
cmd = String -> ByteString
C8.pack String
cmd'
  conn :: HttpConnection
conn@HttpConnection {httpManager :: HttpConnection -> Manager
httpManager = Manager
mng} <- a -> IO HttpConnection
forall a. HttpEnvironment a => a -> IO HttpConnection
pick (a -> IO HttpConnection) -> a -> IO HttpConnection
forall a b. (a -> b) -> a -> b
$ Env a w -> a
forall u w. Env u w -> u
userEnv Env a w
env
  String
url <- HttpConnection -> String -> IO String
genURL HttpConnection
conn String
""
  Request
req <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
  ByteString
ans <-
    Response ByteString -> ByteString
forall body. Response body -> body
responseBody
      (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
httpLbs
        Request
req
          { method :: ByteString
method = ByteString
"POST",
            requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS ByteString
cmd
          }
        Manager
mng
  if ByteString
ans ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
""
    then Either ByteString String -> IO (Either ByteString String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString String -> IO (Either ByteString String))
-> Either ByteString String -> IO (Either ByteString String)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString String
forall a b. a -> Either a b
Left ByteString
ans -- error message
    else Either ByteString String -> IO (Either ByteString String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString String -> IO (Either ByteString String))
-> Either ByteString String -> IO (Either ByteString String)
forall a b. (a -> b) -> a -> b
$ String -> Either ByteString String
forall a b. b -> Either a b
Right String
"Created successfully"

-- | insert one row
insertOneRow ::
  (HttpEnvironment a) =>
  String ->
  [ClickhouseType] ->
  Env a w ->
  IO (Either C8.ByteString String)
insertOneRow :: String
-> [ClickhouseType] -> Env a w -> IO (Either ByteString String)
insertOneRow String
table_name [ClickhouseType]
arr Env a w
environment = do
  let row :: String
row = [ClickhouseType] -> String
toString [ClickhouseType]
arr
  let cmd :: ByteString
cmd = String -> ByteString
C8.pack (String
"INSERT INTO " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
table_name String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
" VALUES " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
row)
  settings :: HttpConnection
settings@HttpConnection {httpManager :: HttpConnection -> Manager
httpManager = Manager
mng} <- a -> IO HttpConnection
forall a. HttpEnvironment a => a -> IO HttpConnection
pick (a -> IO HttpConnection) -> a -> IO HttpConnection
forall a b. (a -> b) -> a -> b
$ Env a w -> a
forall u w. Env u w -> u
userEnv Env a w
environment
  String
url <- HttpConnection -> String -> IO String
genURL HttpConnection
settings String
""
  Request
req <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
  ByteString
ans <-
    Response ByteString -> ByteString
forall body. Response body -> body
responseBody
      (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
httpLbs
        Request
req
          { method :: ByteString
method = ByteString
"POST",
            requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS ByteString
cmd
          }
        Manager
mng
  if ByteString
ans ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
""
    then Either ByteString String -> IO (Either ByteString String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString String -> IO (Either ByteString String))
-> Either ByteString String -> IO (Either ByteString String)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString String
forall a b. a -> Either a b
Left ByteString
ans -- error messagethe hellenic republic
    else Either ByteString String -> IO (Either ByteString String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString String -> IO (Either ByteString String))
-> Either ByteString String -> IO (Either ByteString String)
forall a b. (a -> b) -> a -> b
$ String -> Either ByteString String
forall a b. b -> Either a b
Right String
"Inserted successfully"

-- | insert one or more rows
insertMany ::
  (HttpEnvironment a) =>
  String ->
  [[ClickhouseType]] ->
  Env a w ->
  IO (Either C8.ByteString String)
insertMany :: String
-> [[ClickhouseType]] -> Env a w -> IO (Either ByteString String)
insertMany String
table_name [[ClickhouseType]]
rows Env a w
environment = do
  let rowsString :: [Builder]
rowsString = ([ClickhouseType] -> Builder) -> [[ClickhouseType]] -> [Builder]
forall a b. (a -> b) -> [a] -> [b]
map (ByteString -> Builder
lazyByteString (ByteString -> Builder)
-> ([ClickhouseType] -> ByteString) -> [ClickhouseType] -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ByteString
C8.pack (String -> ByteString)
-> ([ClickhouseType] -> String) -> [ClickhouseType] -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ClickhouseType] -> String
toString) [[ClickhouseType]]
rows
      comma :: Builder
comma = Char -> Builder
char8 Char
','
      preset :: Builder
preset = ByteString -> Builder
lazyByteString (ByteString -> Builder) -> ByteString -> Builder
forall a b. (a -> b) -> a -> b
$ String -> ByteString
C8.pack (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ String
"INSERT INTO " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
table_name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" VALUES "
      togo :: Builder
togo = Builder
preset Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> ((Builder -> Builder -> Builder) -> [Builder] -> Builder
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 (\Builder
x Builder
y -> Builder
x Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
comma Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
y) [Builder]
rowsString)
  settings :: HttpConnection
settings@HttpConnection {httpManager :: HttpConnection -> Manager
httpManager = Manager
mng} <- a -> IO HttpConnection
forall a. HttpEnvironment a => a -> IO HttpConnection
pick (a -> IO HttpConnection) -> a -> IO HttpConnection
forall a b. (a -> b) -> a -> b
$ Env a w -> a
forall u w. Env u w -> u
userEnv Env a w
environment
  String
url <- HttpConnection -> String -> IO String
genURL HttpConnection
settings String
""
  Request
req <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
  ByteString
ans <-
    Response ByteString -> ByteString
forall body. Response body -> body
responseBody
      (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
httpLbs
        Request
req
          { method :: ByteString
method = ByteString
"POST",
            requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ Builder -> ByteString
toLazyByteString Builder
togo
          }
        Manager
mng
  String -> IO ()
forall a. Show a => a -> IO ()
print String
"inserted successfully"
  if ByteString
ans ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
""
    then Either ByteString String -> IO (Either ByteString String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString String -> IO (Either ByteString String))
-> Either ByteString String -> IO (Either ByteString String)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString String
forall a b. a -> Either a b
Left ByteString
ans
    else Either ByteString String -> IO (Either ByteString String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString String -> IO (Either ByteString String))
-> Either ByteString String -> IO (Either ByteString String)
forall a b. (a -> b) -> a -> b
$ String -> Either ByteString String
forall a b. b -> Either a b
Right String
"Successful insertion"

-- | insert data from
insertFromFile ::
  (HttpEnvironment a) =>
  String ->
  Format ->
  FilePath ->
  Env a w ->
  IO (Either C8.ByteString String)
insertFromFile :: String
-> Format -> String -> Env a w -> IO (Either ByteString String)
insertFromFile String
table_name Format
format String
file Env a w
environment = do
  RequestBody
fileReqBody <- String -> IO RequestBody
streamFile String
file
  settings :: HttpConnection
settings@HttpConnection {httpManager :: HttpConnection -> Manager
httpManager = Manager
mng} <- a -> IO HttpConnection
forall a. HttpEnvironment a => a -> IO HttpConnection
pick (a -> IO HttpConnection) -> a -> IO HttpConnection
forall a b. (a -> b) -> a -> b
$ Env a w -> a
forall u w. Env u w -> u
userEnv Env a w
environment
  String
url <-
    HttpConnection -> String -> IO String
genURL
      HttpConnection
settings
      ( String
"INSERT INTO " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
table_name
          String -> ShowS
forall a. Semigroup a => a -> a -> a
<> case Format
format of
            Format
CSV -> String
" FORMAT CSV"
            Format
JSON -> String
" FORMAT JSON"
            Format
TUPLE -> String
" VALUES"
      )
  Request
req <- String -> IO Request
forall (m :: * -> *). MonadThrow m => String -> m Request
parseRequest String
url
  ByteString
ans <-
    Response ByteString -> ByteString
forall body. Response body -> body
responseBody
      (Response ByteString -> ByteString)
-> IO (Response ByteString) -> IO ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Request -> Manager -> IO (Response ByteString)
httpLbs
        Request
req
          { method :: ByteString
method = ByteString
"POST",
            requestBody :: RequestBody
requestBody = RequestBody
fileReqBody
          }
        Manager
mng
  if ByteString
ans ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
""
    then Either ByteString String -> IO (Either ByteString String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString String -> IO (Either ByteString String))
-> Either ByteString String -> IO (Either ByteString String)
forall a b. (a -> b) -> a -> b
$ ByteString -> Either ByteString String
forall a b. a -> Either a b
Left ByteString
ans -- error message
    else Either ByteString String -> IO (Either ByteString String)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either ByteString String -> IO (Either ByteString String))
-> Either ByteString String -> IO (Either ByteString String)
forall a b. (a -> b) -> a -> b
$ String -> Either ByteString String
forall a b. b -> Either a b
Right String
"Inserted successfully"

ping :: GenHaxl u w BS.ByteString
ping :: GenHaxl u w ByteString
ping = HttpClient ByteString -> GenHaxl u w ByteString
forall u (r :: * -> *) a w.
(DataSource u r, Request r a) =>
r a -> GenHaxl u w a
dataFetch (HttpClient ByteString -> GenHaxl u w ByteString)
-> HttpClient ByteString -> GenHaxl u w ByteString
forall a b. (a -> b) -> a -> b
$ HttpClient ByteString
Ping

-- | Default environment
setupEnv :: (MonadIO m, HttpEnvironment a) => a -> m (Env a w)
setupEnv :: a -> m (Env a w)
setupEnv a
csetting = IO (Env a w) -> m (Env a w)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Env a w) -> m (Env a w)) -> IO (Env a w) -> m (Env a w)
forall a b. (a -> b) -> a -> b
$ StateStore -> a -> IO (Env a w)
forall u w. StateStore -> u -> IO (Env u w)
initEnv (State HttpClient -> StateStore -> StateStore
forall (f :: * -> *).
StateKey f =>
State f -> StateStore -> StateStore
stateSet (a -> State HttpClient
forall a. HttpEnvironment a => a -> State HttpClient
toEnv a
csetting) StateStore
stateEmpty) a
csetting

defaultHttpClient :: (MonadIO m) => m (Env HttpConnection w)
defaultHttpClient :: m (Env HttpConnection w)
defaultHttpClient = IO (Env HttpConnection w) -> m (Env HttpConnection w)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Env HttpConnection w) -> m (Env HttpConnection w))
-> IO (Env HttpConnection w) -> m (Env HttpConnection w)
forall a b. (a -> b) -> a -> b
$ IO HttpConnection
defaultHttpConnection IO HttpConnection
-> (HttpConnection -> IO (Env HttpConnection w))
-> IO (Env HttpConnection w)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HttpConnection -> IO (Env HttpConnection w)
forall (m :: * -> *) a w.
(MonadIO m, HttpEnvironment a) =>
a -> m (Env a w)
setupEnv

defaultHttpPool :: (MonadIO m) => Int -> NominalDiffTime -> Int -> m (Env (Pool HttpConnection) w)
defaultHttpPool :: Int -> NominalDiffTime -> Int -> m (Env (Pool HttpConnection) w)
defaultHttpPool Int
numStripes NominalDiffTime
idleTime Int
maxResources =
  IO (Env (Pool HttpConnection) w) -> m (Env (Pool HttpConnection) w)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Env (Pool HttpConnection) w)
 -> m (Env (Pool HttpConnection) w))
-> IO (Env (Pool HttpConnection) w)
-> m (Env (Pool HttpConnection) w)
forall a b. (a -> b) -> a -> b
$ HttpParams
-> Int -> NominalDiffTime -> Int -> IO (Pool HttpConnection)
createHttpPool HttpParams
forall a. Default a => a
def Int
numStripes NominalDiffTime
idleTime Int
maxResources IO (Pool HttpConnection)
-> (Pool HttpConnection -> IO (Env (Pool HttpConnection) w))
-> IO (Env (Pool HttpConnection) w)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Pool HttpConnection -> IO (Env (Pool HttpConnection) w)
forall (m :: * -> *) a w.
(MonadIO m, HttpEnvironment a) =>
a -> m (Env a w)
setupEnv

httpClient :: (MonadIO m) => String -> String -> m (Env HttpConnection w)
httpClient :: String -> String -> m (Env HttpConnection w)
httpClient String
user String
password = IO (Env HttpConnection w) -> m (Env HttpConnection w)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Env HttpConnection w) -> m (Env HttpConnection w))
-> IO (Env HttpConnection w) -> m (Env HttpConnection w)
forall a b. (a -> b) -> a -> b
$ String
-> String -> Int -> String -> Maybe String -> IO HttpConnection
httpConnectDb String
user String
password Int
Defines._DEFAULT_HTTP_PORT String
Defines._DEFAULT_HOST Maybe String
forall a. Maybe a
Nothing IO HttpConnection
-> (HttpConnection -> IO (Env HttpConnection w))
-> IO (Env HttpConnection w)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= HttpConnection -> IO (Env HttpConnection w)
forall (m :: * -> *) a w.
(MonadIO m, HttpEnvironment a) =>
a -> m (Env a w)
setupEnv

-- | rename runHaxl function.
{-# INLINE runQuery #-}
runQuery :: (MonadIO m) => Env u w -> GenHaxl u w a -> m a
runQuery :: Env u w -> GenHaxl u w a -> m a
runQuery Env u w
env GenHaxl u w a
haxl = IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ Env u w -> GenHaxl u w a -> IO a
forall u w a. Env u w -> GenHaxl u w a -> IO a
runHaxl Env u w
env GenHaxl u w a
haxl