{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE NoFieldSelectors #-}

module Haskoin.Store.WebClient
  ( ApiConfig (..),
    apiCall,
    apiBatch,
    -- Blocks
    GetBlock (..),
    GetBlocks (..),
    GetBlockRaw (..),
    GetBlockBest (..),
    GetBlockBestRaw (..),
    GetBlockLatest (..),
    GetBlockHeight (..),
    GetBlockHeights (..),
    GetBlockHeightRaw (..),
    GetBlockTime (..),
    GetBlockTimeRaw (..),
    -- Transactions
    GetTx (..),
    GetTxs (..),
    GetTxRaw (..),
    GetTxsRaw (..),
    GetTxsBlock (..),
    GetTxsBlockRaw (..),
    GetTxAfter (..),
    PostTx (..),
    GetMempool (..),
    GetEvents (..),
    -- Address
    GetAddrTxs (..),
    GetAddrsTxs (..),
    GetAddrTxsFull (..),
    GetAddrsTxsFull (..),
    GetAddrBalance (..),
    GetAddrsBalance (..),
    GetAddrUnspent (..),
    GetAddrsUnspent (..),
    -- XPubs
    GetXPub (..),
    GetXPubTxs (..),
    GetXPubTxsFull (..),
    GetXPubBalances (..),
    GetXPubUnspent (..),
    DelCachedXPub (..),
    -- Network
    GetPeers (..),
    GetHealth (..),
    -- Params
    StartParam (..),
    OffsetParam (..),
    LimitParam (..),
    LimitsParam (..),
    HeightParam (..),
    HeightsParam (..),
    Store.DeriveType (..),
    NoCache (..),
    NoTx (..),
  )
where

import Control.Arrow (second)
import Control.Exception
import Control.Lens ((.~), (?~), (^.))
import Control.Monad.Except
import Control.Monad.IO.Class (MonadIO, liftIO)
import Data.Aeson qualified as A
import Data.ByteString.Lazy qualified as BL
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Default (Default, def)
import Data.Monoid (Endo (..), appEndo)
import Data.String.Conversions (cs)
import Data.Text (Text)
import Data.Text qualified as Text
import Haskoin.Crypto (Ctx)
import Haskoin.Network
import Haskoin.Store.Data qualified as Store
import Haskoin.Store.WebCommon
import Haskoin.Transaction
import Haskoin.Util
import Network.HTTP.Client (Request (..))
import Network.HTTP.Types (StdMethod (..))
import Network.HTTP.Types.Status
import Network.Wreq qualified as HTTP
import Network.Wreq.Types (ResponseChecker)
import Numeric.Natural (Natural)

-- | Configuration specifying the Network and the Host for API calls.
-- Default instance:
--
-- @
-- ApiConfig
-- { net = bch
-- , host = "https://api.haskoin.com/"
-- }
-- @
data ApiConfig = ApiConfig
  { ApiConfig -> Network
net :: !Network,
    ApiConfig -> String
host :: !String
  }
  deriving (ApiConfig -> ApiConfig -> Bool
(ApiConfig -> ApiConfig -> Bool)
-> (ApiConfig -> ApiConfig -> Bool) -> Eq ApiConfig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ApiConfig -> ApiConfig -> Bool
== :: ApiConfig -> ApiConfig -> Bool
$c/= :: ApiConfig -> ApiConfig -> Bool
/= :: ApiConfig -> ApiConfig -> Bool
Eq, Int -> ApiConfig -> ShowS
[ApiConfig] -> ShowS
ApiConfig -> String
(Int -> ApiConfig -> ShowS)
-> (ApiConfig -> String)
-> ([ApiConfig] -> ShowS)
-> Show ApiConfig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ApiConfig -> ShowS
showsPrec :: Int -> ApiConfig -> ShowS
$cshow :: ApiConfig -> String
show :: ApiConfig -> String
$cshowList :: [ApiConfig] -> ShowS
showList :: [ApiConfig] -> ShowS
Show)

instance Default ApiConfig where
  def :: ApiConfig
def =
    ApiConfig
      { $sel:net:ApiConfig :: Network
net = Network
bch,
        $sel:host:ApiConfig :: String
host = String
"https://api.haskoin.com/"
      }

-- | Make a call to the haskoin-store API.
--
-- Usage (default options):
--
-- > apiCall ctx def $ GetAddrsTxs addrs def
--
-- With options:
--
-- > apiCall ctx def $ GetAddrsUnspent addrs def{ paramLimit = Just 10 }
apiCall ::
  (ApiResource a b, MonadIO m, MonadError Store.Except m) =>
  Ctx ->
  ApiConfig ->
  a ->
  m b
apiCall :: forall a b (m :: * -> *).
(ApiResource a b, MonadIO m, MonadError Except m) =>
Ctx -> ApiConfig -> a -> m b
apiCall Ctx
ctx (ApiConfig Network
net String
apiHost) a
res = do
  Endo Options
args <- Either Except (Endo Options) -> m (Endo Options)
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Except (Endo Options) -> m (Endo Options))
-> Either Except (Endo Options) -> m (Endo Options)
forall a b. (a -> b) -> a -> b
$ Network -> Ctx -> a -> Either Except (Endo Options)
forall a b.
ApiResource a b =>
Network -> Ctx -> a -> Either Except (Endo Options)
toOptions Network
net Ctx
ctx a
res
  let url :: String
url = String
apiHost String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Network
net.name String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Network -> Ctx -> a -> Text
forall a b. ApiResource a b => Network -> Ctx -> a -> Text
queryPath Network
net Ctx
ctx a
res)
  case Proxy a -> StdMethod
forall a b. ApiResource a b => Proxy a -> StdMethod
resourceMethod (Proxy a -> StdMethod) -> Proxy a -> StdMethod
forall a b. (a -> b) -> a -> b
$ a -> Proxy a
forall a. a -> Proxy a
asProxy a
res of
    StdMethod
GET -> Either Except b -> m b
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Except b -> m b) -> m (Either Except b) -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either Except b) -> m (Either Except b)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Endo Options -> String -> IO (Either Except b)
forall a.
Serial a =>
Endo Options -> String -> IO (Either Except a)
getBinary Endo Options
args String
url)
    StdMethod
POST ->
      case a -> Maybe PostBox
forall a b. ApiResource a b => a -> Maybe PostBox
resourceBody a
res of
        Just (PostBox s
val) ->
          Either Except b -> m b
forall e (m :: * -> *) a. MonadError e m => Either e a -> m a
liftEither (Either Except b -> m b) -> m (Either Except b) -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< IO (Either Except b) -> m (Either Except b)
forall a. IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Endo Options -> String -> s -> IO (Either Except b)
forall a r.
(Serial a, Serial r) =>
Endo Options -> String -> a -> IO (Either Except r)
postBinary Endo Options
args String
url s
val)
        Maybe PostBox
_ -> Except -> m b
forall a. Except -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Except -> m b) -> Except -> m b
forall a b. (a -> b) -> a -> b
$ String -> Except
Store.StringError String
"Could not post resource"
    StdMethod
_ -> Except -> m b
forall a. Except -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Except -> m b) -> Except -> m b
forall a b. (a -> b) -> a -> b
$ String -> Except
Store.StringError String
"Unsupported HTTP method"

-- | Batch commands that have a large list of arguments:
--
-- > apiBatch 20 def (GetAddrsTxs addrs def)
apiBatch ::
  (Batchable a b, MonadIO m, MonadError Store.Except m) =>
  Ctx ->
  Natural ->
  ApiConfig ->
  a ->
  m b
apiBatch :: forall a b (m :: * -> *).
(Batchable a b, MonadIO m, MonadError Except m) =>
Ctx -> Natural -> ApiConfig -> a -> m b
apiBatch Ctx
ctx Natural
i ApiConfig
conf a
res =
  [b] -> b
forall a. Monoid a => [a] -> a
mconcat ([b] -> b) -> m [b] -> m b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> m b) -> [a] -> m [b]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Ctx -> ApiConfig -> a -> m b
forall a b (m :: * -> *).
(ApiResource a b, MonadIO m, MonadError Except m) =>
Ctx -> ApiConfig -> a -> m b
apiCall Ctx
ctx ApiConfig
conf) (Natural -> a -> [a]
forall a b. Batchable a b => Natural -> a -> [a]
resourceBatch Natural
i a
res)

class (ApiResource a b, Monoid b) => Batchable a b where
  resourceBatch :: Natural -> a -> [a]

instance Batchable GetBlocks (Store.SerialList Store.BlockData) where
  resourceBatch :: Natural -> GetBlocks -> [GetBlocks]
resourceBatch Natural
i (GetBlocks [BlockHash]
hs NoTx
t) =
    ([BlockHash] -> NoTx -> GetBlocks
`GetBlocks` NoTx
t) ([BlockHash] -> GetBlocks) -> [[BlockHash]] -> [GetBlocks]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> [BlockHash] -> [[BlockHash]]
forall a. Natural -> [a] -> [[a]]
chunksOf Natural
i [BlockHash]
hs

instance Batchable GetBlockHeights (Store.SerialList Store.BlockData) where
  resourceBatch :: Natural -> GetBlockHeights -> [GetBlockHeights]
resourceBatch Natural
i (GetBlockHeights (HeightsParam [Natural]
hs) NoTx
n) =
    (HeightsParam -> NoTx -> GetBlockHeights
`GetBlockHeights` NoTx
n)
      (HeightsParam -> GetBlockHeights)
-> [HeightsParam] -> [GetBlockHeights]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Natural] -> HeightsParam
HeightsParam ([Natural] -> HeightsParam) -> [[Natural]] -> [HeightsParam]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> [Natural] -> [[Natural]]
forall a. Natural -> [a] -> [[a]]
chunksOf Natural
i [Natural]
hs)

instance Batchable GetTxs (Store.SerialList Store.Transaction) where
  resourceBatch :: Natural -> GetTxs -> [GetTxs]
resourceBatch Natural
i (GetTxs [TxHash]
ts) =
    [TxHash] -> GetTxs
GetTxs ([TxHash] -> GetTxs) -> [[TxHash]] -> [GetTxs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> [TxHash] -> [[TxHash]]
forall a. Natural -> [a] -> [[a]]
chunksOf Natural
i [TxHash]
ts

instance Batchable GetTxsRaw (Store.RawResultList Tx) where
  resourceBatch :: Natural -> GetTxsRaw -> [GetTxsRaw]
resourceBatch Natural
i (GetTxsRaw [TxHash]
ts) =
    [TxHash] -> GetTxsRaw
GetTxsRaw ([TxHash] -> GetTxsRaw) -> [[TxHash]] -> [GetTxsRaw]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> [TxHash] -> [[TxHash]]
forall a. Natural -> [a] -> [[a]]
chunksOf Natural
i [TxHash]
ts

instance Batchable GetAddrsTxs (Store.SerialList Store.TxRef) where
  resourceBatch :: Natural -> GetAddrsTxs -> [GetAddrsTxs]
resourceBatch Natural
i (GetAddrsTxs [Address]
as LimitsParam
l) =
    ([Address] -> LimitsParam -> GetAddrsTxs
`GetAddrsTxs` LimitsParam
l) ([Address] -> GetAddrsTxs) -> [[Address]] -> [GetAddrsTxs]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> [Address] -> [[Address]]
forall a. Natural -> [a] -> [[a]]
chunksOf Natural
i [Address]
as

instance Batchable GetAddrsTxsFull (Store.SerialList Store.Transaction) where
  resourceBatch :: Natural -> GetAddrsTxsFull -> [GetAddrsTxsFull]
resourceBatch Natural
i (GetAddrsTxsFull [Address]
as LimitsParam
l) =
    ([Address] -> LimitsParam -> GetAddrsTxsFull
`GetAddrsTxsFull` LimitsParam
l) ([Address] -> GetAddrsTxsFull) -> [[Address]] -> [GetAddrsTxsFull]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> [Address] -> [[Address]]
forall a. Natural -> [a] -> [[a]]
chunksOf Natural
i [Address]
as

instance Batchable GetAddrsBalance (Store.SerialList Store.Balance) where
  resourceBatch :: Natural -> GetAddrsBalance -> [GetAddrsBalance]
resourceBatch Natural
i (GetAddrsBalance [Address]
as) =
    [Address] -> GetAddrsBalance
GetAddrsBalance ([Address] -> GetAddrsBalance) -> [[Address]] -> [GetAddrsBalance]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> [Address] -> [[Address]]
forall a. Natural -> [a] -> [[a]]
chunksOf Natural
i [Address]
as

instance Batchable GetAddrsUnspent (Store.SerialList Store.Unspent) where
  resourceBatch :: Natural -> GetAddrsUnspent -> [GetAddrsUnspent]
resourceBatch Natural
i (GetAddrsUnspent [Address]
as LimitsParam
l) =
    ([Address] -> LimitsParam -> GetAddrsUnspent
`GetAddrsUnspent` LimitsParam
l) ([Address] -> GetAddrsUnspent) -> [[Address]] -> [GetAddrsUnspent]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Natural -> [Address] -> [[Address]]
forall a. Natural -> [a] -> [[a]]
chunksOf Natural
i [Address]
as

------------------
-- API Internal --
------------------

toOptions ::
  (ApiResource a b) =>
  Network ->
  Ctx ->
  a ->
  Either Store.Except (Endo HTTP.Options)
toOptions :: forall a b.
ApiResource a b =>
Network -> Ctx -> a -> Either Except (Endo Options)
toOptions Network
net Ctx
ctx a
res =
  [Endo Options] -> Endo Options
forall a. Monoid a => [a] -> a
mconcat ([Endo Options] -> Endo Options)
-> Either Except [Endo Options] -> Either Except (Endo Options)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (ParamBox -> Either Except (Endo Options))
-> [ParamBox] -> Either Except [Endo Options]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ParamBox -> Either Except (Endo Options)
f (([ParamBox], [ParamBox]) -> [ParamBox]
forall a b. (a, b) -> b
snd (([ParamBox], [ParamBox]) -> [ParamBox])
-> ([ParamBox], [ParamBox]) -> [ParamBox]
forall a b. (a -> b) -> a -> b
$ a -> ([ParamBox], [ParamBox])
forall a b. ApiResource a b => a -> ([ParamBox], [ParamBox])
queryParams a
res)
  where
    f :: ParamBox -> Either Except (Endo Options)
f (ParamBox p
p) = Network -> Ctx -> p -> Either Except (Endo Options)
forall a.
Param a =>
Network -> Ctx -> a -> Either Except (Endo Options)
toOption Network
net Ctx
ctx p
p

toOption ::
  (Param a) =>
  Network ->
  Ctx ->
  a ->
  Either Store.Except (Endo HTTP.Options)
toOption :: forall a.
Param a =>
Network -> Ctx -> a -> Either Except (Endo Options)
toOption Network
net Ctx
ctx a
a = do
  [Text]
res <-
    Except -> Maybe [Text] -> Either Except [Text]
forall b a. b -> Maybe a -> Either b a
maybeToEither (String -> Except
Store.UserError String
"Invalid Param") (Maybe [Text] -> Either Except [Text])
-> Maybe [Text] -> Either Except [Text]
forall a b. (a -> b) -> a -> b
$
      Network -> Ctx -> a -> Maybe [Text]
forall a. Param a => Network -> Ctx -> a -> Maybe [Text]
encodeParam Network
net Ctx
ctx a
a
  Endo Options -> Either Except (Endo Options)
forall a. a -> Either Except a
forall (m :: * -> *) a. Monad m => a -> m a
return (Endo Options -> Either Except (Endo Options))
-> Endo Options -> Either Except (Endo Options)
forall a b. (a -> b) -> a -> b
$ Text -> [Text] -> Endo Options
applyOpt (a -> Text
forall p. Param p => p -> Text
paramLabel a
a) [Text]
res

applyOpt :: Text -> [Text] -> Endo HTTP.Options
applyOpt :: Text -> [Text] -> Endo Options
applyOpt Text
p [Text]
t = (Options -> Options) -> Endo Options
forall a. (a -> a) -> Endo a
Endo ((Options -> Options) -> Endo Options)
-> (Options -> Options) -> Endo Options
forall a b. (a -> b) -> a -> b
$ Text -> Lens' Options [Text]
HTTP.param Text
p (([Text] -> Identity [Text]) -> Options -> Identity Options)
-> [Text] -> Options -> Options
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [Text -> [Text] -> Text
Text.intercalate Text
"," [Text]
t]

getBinary ::
  (Serial a) =>
  Endo HTTP.Options ->
  String ->
  IO (Either Store.Except a)
getBinary :: forall a.
Serial a =>
Endo Options -> String -> IO (Either Except a)
getBinary Endo Options
opts String
url = do
  Either Except (Response ByteString)
resE <- IO (Response ByteString)
-> IO (Either Except (Response ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Response ByteString)
 -> IO (Either Except (Response ByteString)))
-> IO (Response ByteString)
-> IO (Either Except (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Options -> String -> IO (Response ByteString)
HTTP.getWith (Endo Options -> Options
binaryOpts Endo Options
opts) String
url
  Either Except a -> IO (Either Except a)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Except a -> IO (Either Except a))
-> Either Except a -> IO (Either Except a)
forall a b. (a -> b) -> a -> b
$ do
    Response ByteString
res <- Either Except (Response ByteString)
resE
    a -> Either Except a
forall a. a -> Either Except a
forall (m :: * -> *) a. Monad m => a -> m a
return (a -> Either Except a)
-> (ByteString -> a) -> ByteString -> Either Except a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get a -> ByteString -> a
forall a. Get a -> ByteString -> a
runGetL Get a
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
forall (m :: * -> *). MonadGet m => m a
deserialize (ByteString -> Either Except a) -> ByteString -> Either Except a
forall a b. (a -> b) -> a -> b
$ Response ByteString
res Response ByteString
-> Getting ByteString (Response ByteString) ByteString
-> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString (Response ByteString) ByteString
forall body0 body1 (f :: * -> *).
Functor f =>
(body0 -> f body1) -> Response body0 -> f (Response body1)
HTTP.responseBody

postBinary ::
  (Serial a, Serial r) =>
  Endo HTTP.Options ->
  String ->
  a ->
  IO (Either Store.Except r)
postBinary :: forall a r.
(Serial a, Serial r) =>
Endo Options -> String -> a -> IO (Either Except r)
postBinary Endo Options
opts String
url a
body = do
  Either Except (Response ByteString)
resE <- IO (Response ByteString)
-> IO (Either Except (Response ByteString))
forall e a. Exception e => IO a -> IO (Either e a)
try (IO (Response ByteString)
 -> IO (Either Except (Response ByteString)))
-> IO (Response ByteString)
-> IO (Either Except (Response ByteString))
forall a b. (a -> b) -> a -> b
$ Options -> String -> ByteString -> IO (Response ByteString)
forall a.
Postable a =>
Options -> String -> a -> IO (Response ByteString)
HTTP.postWith (Endo Options -> Options
binaryOpts Endo Options
opts) String
url (Put -> ByteString
runPutL (a -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => a -> m ()
serialize a
body))
  Either Except r -> IO (Either Except r)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Except r -> IO (Either Except r))
-> Either Except r -> IO (Either Except r)
forall a b. (a -> b) -> a -> b
$ do
    Response ByteString
res <- Either Except (Response ByteString)
resE
    r -> Either Except r
forall a. a -> Either Except a
forall (m :: * -> *) a. Monad m => a -> m a
return (r -> Either Except r)
-> (ByteString -> r) -> ByteString -> Either Except r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Get r -> ByteString -> r
forall a. Get a -> ByteString -> a
runGetL Get r
forall a (m :: * -> *). (Serial a, MonadGet m) => m a
forall (m :: * -> *). MonadGet m => m r
deserialize (ByteString -> Either Except r) -> ByteString -> Either Except r
forall a b. (a -> b) -> a -> b
$ Response ByteString
res Response ByteString
-> Getting ByteString (Response ByteString) ByteString
-> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString (Response ByteString) ByteString
forall body0 body1 (f :: * -> *).
Functor f =>
(body0 -> f body1) -> Response body0 -> f (Response body1)
HTTP.responseBody

binaryOpts :: Endo HTTP.Options -> HTTP.Options
binaryOpts :: Endo Options -> Options
binaryOpts Endo Options
opts =
  Endo Options -> Options -> Options
forall a. Endo a -> a -> a
appEndo (Endo Options
opts Endo Options -> Endo Options -> Endo Options
forall a. Semigroup a => a -> a -> a
<> Endo Options
accept Endo Options -> Endo Options -> Endo Options
forall a. Semigroup a => a -> a -> a
<> Endo Options
stat) Options
HTTP.defaults
  where
    accept :: Endo Options
accept = (Options -> Options) -> Endo Options
forall a. (a -> a) -> Endo a
Endo ((Options -> Options) -> Endo Options)
-> (Options -> Options) -> Endo Options
forall a b. (a -> b) -> a -> b
$ HeaderName -> Lens' Options [ByteString]
HTTP.header HeaderName
"Accept" (([ByteString] -> Identity [ByteString])
 -> Options -> Identity Options)
-> [ByteString] -> Options -> Options
forall s t a b. ASetter s t a b -> b -> s -> t
.~ [ByteString
"application/octet-stream"]
    stat :: Endo Options
stat = (Options -> Options) -> Endo Options
forall a. (a -> a) -> Endo a
Endo ((Options -> Options) -> Endo Options)
-> (Options -> Options) -> Endo Options
forall a b. (a -> b) -> a -> b
$ (Maybe ResponseChecker -> Identity (Maybe ResponseChecker))
-> Options -> Identity Options
Lens' Options (Maybe ResponseChecker)
HTTP.checkResponse ((Maybe ResponseChecker -> Identity (Maybe ResponseChecker))
 -> Options -> Identity Options)
-> ResponseChecker -> Options -> Options
forall s t a b. ASetter s t a (Maybe b) -> b -> s -> t
?~ ResponseChecker
checkStatus

checkStatus :: ResponseChecker
checkStatus :: ResponseChecker
checkStatus Request
req Response (IO ByteString)
res
  | Status -> Bool
statusIsSuccessful Status
status = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
isHealthPath Bool -> Bool -> Bool
&& Int
code Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
503 = () -> IO ()
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- Ignore health checks
  | Bool
otherwise = do
      Maybe Except
e <- ByteString -> Maybe Except
forall a. FromJSON a => ByteString -> Maybe a
A.decodeStrict (ByteString -> Maybe Except) -> IO ByteString -> IO (Maybe Except)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Response (IO ByteString)
res Response (IO ByteString)
-> Getting
     (IO ByteString) (Response (IO ByteString)) (IO ByteString)
-> IO ByteString
forall s a. s -> Getting a s a -> a
^. Getting (IO ByteString) (Response (IO ByteString)) (IO ByteString)
forall body0 body1 (f :: * -> *).
Functor f =>
(body0 -> f body1) -> Response body0 -> f (Response body1)
HTTP.responseBody
      Except -> IO ()
forall e a. Exception e => e -> IO a
throwIO (Except -> IO ()) -> Except -> IO ()
forall a b. (a -> b) -> a -> b
$
        case Maybe Except
e of
          Just Except
except -> Except
except :: Store.Except
          Maybe Except
Nothing -> String -> Except
Store.StringError String
"could not decode error"
  where
    code :: Int
code = Response (IO ByteString)
res Response (IO ByteString)
-> Getting Int (Response (IO ByteString)) Int -> Int
forall s a. s -> Getting a s a -> a
^. (Status -> Const Int Status)
-> Response (IO ByteString) -> Const Int (Response (IO ByteString))
forall body (f :: * -> *).
Functor f =>
(Status -> f Status) -> Response body -> f (Response body)
HTTP.responseStatus ((Status -> Const Int Status)
 -> Response (IO ByteString)
 -> Const Int (Response (IO ByteString)))
-> ((Int -> Const Int Int) -> Status -> Const Int Status)
-> Getting Int (Response (IO ByteString)) Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> Const Int Int) -> Status -> Const Int Status
Lens' Status Int
HTTP.statusCode
    message :: ByteString
message = Response (IO ByteString)
res Response (IO ByteString)
-> Getting ByteString (Response (IO ByteString)) ByteString
-> ByteString
forall s a. s -> Getting a s a -> a
^. (Status -> Const ByteString Status)
-> Response (IO ByteString)
-> Const ByteString (Response (IO ByteString))
forall body (f :: * -> *).
Functor f =>
(Status -> f Status) -> Response body -> f (Response body)
HTTP.responseStatus ((Status -> Const ByteString Status)
 -> Response (IO ByteString)
 -> Const ByteString (Response (IO ByteString)))
-> ((ByteString -> Const ByteString ByteString)
    -> Status -> Const ByteString Status)
-> Getting ByteString (Response (IO ByteString)) ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Const ByteString ByteString)
-> Status -> Const ByteString Status
Lens' Status ByteString
HTTP.statusMessage
    status :: Status
status = Int -> ByteString -> Status
mkStatus Int
code ByteString
message
    isHealthPath :: Bool
isHealthPath = Text
"/health" Text -> Text -> Bool
`Text.isInfixOf` ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (Request -> ByteString
path Request
req)

---------------
-- Utilities --
---------------

chunksOf :: Natural -> [a] -> [[a]]
chunksOf :: forall a. Natural -> [a] -> [[a]]
chunksOf Natural
n [a]
xs
  | [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
xs = []
  | Bool
otherwise =
      ([a] -> [[a]] -> [[a]]) -> ([a], [[a]]) -> [[a]]
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (:) (([a], [[a]]) -> [[a]]) -> ([a], [[a]]) -> [[a]]
forall a b. (a -> b) -> a -> b
$ ([a] -> [[a]]) -> ([a], [a]) -> ([a], [[a]])
forall b c d. (b -> c) -> (d, b) -> (d, c)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (d, b) (d, c)
second (Natural -> [a] -> [[a]]
forall a. Natural -> [a] -> [[a]]
chunksOf Natural
n) (([a], [a]) -> ([a], [[a]])) -> ([a], [a]) -> ([a], [[a]])
forall a b. (a -> b) -> a -> b
$ Int -> [a] -> ([a], [a])
forall a. Int -> [a] -> ([a], [a])
splitAt (Natural -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Natural
n) [a]
xs