{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}

module BtcLsp.Data.AppM
  ( runApp,
    AppM (..),
  )
where

import BtcLsp.Data.Env as Env (Env (..))
import BtcLsp.Import as I
import qualified BtcLsp.Import.Psql as Psql
import qualified LndClient.Data.WalletBalance as Lnd
import qualified UnliftIO.Exception as UnIO

newtype AppM m a = AppM
  { forall (m :: * -> *) a. AppM m a -> ReaderT Env m a
unAppM :: ReaderT Env.Env m a
  }
  deriving stock ((forall a b. (a -> b) -> AppM m a -> AppM m b)
-> (forall a b. a -> AppM m b -> AppM m a) -> Functor (AppM m)
forall a b. a -> AppM m b -> AppM m a
forall a b. (a -> b) -> AppM m a -> AppM m b
forall (m :: * -> *) a b. Functor m => a -> AppM m b -> AppM m a
forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> AppM m a -> AppM m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> AppM m b -> AppM m a
$c<$ :: forall (m :: * -> *) a b. Functor m => a -> AppM m b -> AppM m a
fmap :: forall a b. (a -> b) -> AppM m a -> AppM m b
$cfmap :: forall (m :: * -> *) a b.
Functor m =>
(a -> b) -> AppM m a -> AppM m b
Functor)
  deriving newtype
    ( Functor (AppM m)
Functor (AppM m)
-> (forall a. a -> AppM m a)
-> (forall a b. AppM m (a -> b) -> AppM m a -> AppM m b)
-> (forall a b c.
    (a -> b -> c) -> AppM m a -> AppM m b -> AppM m c)
-> (forall a b. AppM m a -> AppM m b -> AppM m b)
-> (forall a b. AppM m a -> AppM m b -> AppM m a)
-> Applicative (AppM m)
forall a. a -> AppM m a
forall a b. AppM m a -> AppM m b -> AppM m a
forall a b. AppM m a -> AppM m b -> AppM m b
forall a b. AppM m (a -> b) -> AppM m a -> AppM m b
forall a b c. (a -> b -> c) -> AppM m a -> AppM m b -> AppM m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
forall {m :: * -> *}. Applicative m => Functor (AppM m)
forall (m :: * -> *) a. Applicative m => a -> AppM m a
forall (m :: * -> *) a b.
Applicative m =>
AppM m a -> AppM m b -> AppM m a
forall (m :: * -> *) a b.
Applicative m =>
AppM m a -> AppM m b -> AppM m b
forall (m :: * -> *) a b.
Applicative m =>
AppM m (a -> b) -> AppM m a -> AppM m b
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> AppM m a -> AppM m b -> AppM m c
<* :: forall a b. AppM m a -> AppM m b -> AppM m a
$c<* :: forall (m :: * -> *) a b.
Applicative m =>
AppM m a -> AppM m b -> AppM m a
*> :: forall a b. AppM m a -> AppM m b -> AppM m b
$c*> :: forall (m :: * -> *) a b.
Applicative m =>
AppM m a -> AppM m b -> AppM m b
liftA2 :: forall a b c. (a -> b -> c) -> AppM m a -> AppM m b -> AppM m c
$cliftA2 :: forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> AppM m a -> AppM m b -> AppM m c
<*> :: forall a b. AppM m (a -> b) -> AppM m a -> AppM m b
$c<*> :: forall (m :: * -> *) a b.
Applicative m =>
AppM m (a -> b) -> AppM m a -> AppM m b
pure :: forall a. a -> AppM m a
$cpure :: forall (m :: * -> *) a. Applicative m => a -> AppM m a
Applicative,
      Applicative (AppM m)
Applicative (AppM m)
-> (forall a b. AppM m a -> (a -> AppM m b) -> AppM m b)
-> (forall a b. AppM m a -> AppM m b -> AppM m b)
-> (forall a. a -> AppM m a)
-> Monad (AppM m)
forall a. a -> AppM m a
forall a b. AppM m a -> AppM m b -> AppM m b
forall a b. AppM m a -> (a -> AppM m b) -> AppM m b
forall {m :: * -> *}. Monad m => Applicative (AppM m)
forall (m :: * -> *) a. Monad m => a -> AppM m a
forall (m :: * -> *) a b.
Monad m =>
AppM m a -> AppM m b -> AppM m b
forall (m :: * -> *) a b.
Monad m =>
AppM m a -> (a -> AppM m b) -> AppM m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> AppM m a
$creturn :: forall (m :: * -> *) a. Monad m => a -> AppM m a
>> :: forall a b. AppM m a -> AppM m b -> AppM m b
$c>> :: forall (m :: * -> *) a b.
Monad m =>
AppM m a -> AppM m b -> AppM m b
>>= :: forall a b. AppM m a -> (a -> AppM m b) -> AppM m b
$c>>= :: forall (m :: * -> *) a b.
Monad m =>
AppM m a -> (a -> AppM m b) -> AppM m b
Monad,
      Monad (AppM m)
Monad (AppM m) -> (forall a. IO a -> AppM m a) -> MonadIO (AppM m)
forall a. IO a -> AppM m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
forall {m :: * -> *}. MonadIO m => Monad (AppM m)
forall (m :: * -> *) a. MonadIO m => IO a -> AppM m a
liftIO :: forall a. IO a -> AppM m a
$cliftIO :: forall (m :: * -> *) a. MonadIO m => IO a -> AppM m a
MonadIO,
      MonadReader Env.Env,
      MonadIO (AppM m)
MonadIO (AppM m)
-> (forall b. ((forall a. AppM m a -> IO a) -> IO b) -> AppM m b)
-> MonadUnliftIO (AppM m)
forall b. ((forall a. AppM m a -> IO a) -> IO b) -> AppM m b
forall (m :: * -> *).
MonadIO m
-> (forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
forall {m :: * -> *}. MonadUnliftIO m => MonadIO (AppM m)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. AppM m a -> IO a) -> IO b) -> AppM m b
withRunInIO :: forall b. ((forall a. AppM m a -> IO a) -> IO b) -> AppM m b
$cwithRunInIO :: forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. AppM m a -> IO a) -> IO b) -> AppM m b
MonadUnliftIO
    )

runApp :: Env.Env -> AppM m a -> m a
runApp :: forall (m :: * -> *) a. Env -> AppM m a -> m a
runApp Env
env AppM m a
app = ReaderT Env m a -> Env -> m a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (AppM m a -> ReaderT Env m a
forall (m :: * -> *) a. AppM m a -> ReaderT Env m a
unAppM AppM m a
app) Env
env

instance (MonadIO m) => Katip (AppM m) where
  getLogEnv :: AppM m LogEnv
getLogEnv = (Env -> LogEnv) -> AppM m LogEnv
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> LogEnv
envKatipLE
  localLogEnv :: forall a. (LogEnv -> LogEnv) -> AppM m a -> AppM m a
localLogEnv LogEnv -> LogEnv
f (AppM ReaderT Env m a
m) =
    ReaderT Env m a -> AppM m a
forall (m :: * -> *) a. ReaderT Env m a -> AppM m a
AppM ((Env -> Env) -> ReaderT Env m a -> ReaderT Env m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Env
s -> Env
s {envKatipLE :: LogEnv
envKatipLE = LogEnv -> LogEnv
f (Env -> LogEnv
envKatipLE Env
s)}) ReaderT Env m a
m)

instance (MonadIO m) => KatipContext (AppM m) where
  getKatipContext :: AppM m LogContexts
getKatipContext = (Env -> LogContexts) -> AppM m LogContexts
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> LogContexts
envKatipCTX
  localKatipContext :: forall a. (LogContexts -> LogContexts) -> AppM m a -> AppM m a
localKatipContext LogContexts -> LogContexts
f (AppM ReaderT Env m a
m) =
    ReaderT Env m a -> AppM m a
forall (m :: * -> *) a. ReaderT Env m a -> AppM m a
AppM ((Env -> Env) -> ReaderT Env m a -> ReaderT Env m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Env
s -> Env
s {envKatipCTX :: LogContexts
envKatipCTX = LogContexts -> LogContexts
f (Env -> LogContexts
envKatipCTX Env
s)}) ReaderT Env m a
m)
  getKatipNamespace :: AppM m Namespace
getKatipNamespace = (Env -> Namespace) -> AppM m Namespace
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Namespace
envKatipNS
  localKatipNamespace :: forall a. (Namespace -> Namespace) -> AppM m a -> AppM m a
localKatipNamespace Namespace -> Namespace
f (AppM ReaderT Env m a
m) =
    ReaderT Env m a -> AppM m a
forall (m :: * -> *) a. ReaderT Env m a -> AppM m a
AppM ((Env -> Env) -> ReaderT Env m a -> ReaderT Env m a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\Env
s -> Env
s {envKatipNS :: Namespace
envKatipNS = Namespace -> Namespace
f (Env -> Namespace
envKatipNS Env
s)}) ReaderT Env m a
m)

instance (MonadUnliftIO m) => I.Env (AppM m) where
  getGsEnv :: AppM m GSEnv
getGsEnv =
    (Env -> GSEnv) -> AppM m GSEnv
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> GSEnv
Env.envGrpcServer
  getSwapIntoLnMinAmt :: AppM m (Money 'Usr 'OnChain 'Fund)
getSwapIntoLnMinAmt =
    (Env -> Money 'Usr 'OnChain 'Fund)
-> AppM m (Money 'Usr 'OnChain 'Fund)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Money 'Usr 'OnChain 'Fund
Env.envSwapIntoLnMinAmt
  getMsatPerByte :: AppM m (Maybe MSat)
getMsatPerByte =
    (Env -> Maybe MSat) -> AppM m (Maybe MSat)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Maybe MSat
Env.envMsatPerByte
  getLspPubKeyVar :: AppM m (MVar NodePubKey)
getLspPubKeyVar =
    (Env -> MVar NodePubKey) -> AppM m (MVar NodePubKey)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> MVar NodePubKey
Env.envLndPubKey
  getLspLndEnv :: AppM m LndEnv
getLspLndEnv =
    (Env -> LndEnv) -> AppM m LndEnv
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> LndEnv
Env.envLnd
  getYesodLog :: AppM m YesodLog
getYesodLog =
    (Env -> YesodLog) -> AppM m YesodLog
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> YesodLog
Env.envYesodLog
  getLndP2PSocketAddress :: AppM m SocketAddress
getLndP2PSocketAddress = do
    HostName
host <- (Env -> HostName) -> AppM m HostName
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> HostName
Env.envLndP2PHost
    PortNumber
port <- (Env -> PortNumber) -> AppM m PortNumber
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> PortNumber
Env.envLndP2PPort
    SocketAddress -> AppM m SocketAddress
forall (f :: * -> *) a. Applicative f => a -> f a
pure
      SocketAddress :: HostName -> PortNumber -> SocketAddress
SocketAddress
        { socketAddressHost :: HostName
socketAddressHost = HostName
host,
          socketAddressPort :: PortNumber
socketAddressPort = PortNumber
port
        }
  withLnd :: forall a b.
(LndEnv -> a)
-> (a -> AppM m (Either LndError b)) -> AppM m (Either Failure b)
withLnd LndEnv -> a
method a -> AppM m (Either LndError b)
args = do
    LndEnv
lnd <- (Env -> LndEnv) -> AppM m LndEnv
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> LndEnv
Env.envLnd
    (LndError -> Failure) -> Either LndError b -> Either Failure b
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Failure -> LndError -> Failure
forall a b. a -> b -> a
const (Failure -> LndError -> Failure) -> Failure -> LndError -> Failure
forall a b. (a -> b) -> a -> b
$ FailureInternal -> Failure
FailureInt FailureInternal
FailureRedacted) (Either LndError b -> Either Failure b)
-> AppM m (Either LndError b) -> AppM m (Either Failure b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> AppM m (Either LndError b)
args (LndEnv -> a
method LndEnv
lnd)
  withBtc :: forall a b.
(Client -> a) -> (a -> IO b) -> AppM m (Either Failure b)
withBtc Client -> a
method a -> IO b
args = do
    Client
env <- (Env -> Client) -> AppM m Client
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Client
Env.envBtc
    IO (Either Failure b) -> AppM m (Either Failure b)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either Failure b) -> AppM m (Either Failure b))
-> IO (Either Failure b) -> AppM m (Either Failure b)
forall a b. (a -> b) -> a -> b
$ (SomeException -> Failure)
-> Either SomeException b -> Either Failure b
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first SomeException -> Failure
forall e. Exception e => e -> Failure
exHandler (Either SomeException b -> Either Failure b)
-> IO (Either SomeException b) -> IO (Either Failure b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO b -> IO (Either SomeException b)
forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> m (Either SomeException a)
UnIO.tryAny (a -> IO b
args (a -> IO b) -> a -> IO b
forall a b. (a -> b) -> a -> b
$ Client -> a
method Client
env)
    where
      exHandler :: (Exception e) => e -> Failure
      exHandler :: forall e. Exception e => e -> Failure
exHandler =
        FailureInternal -> Failure
FailureInt (FailureInternal -> Failure)
-> (e -> FailureInternal) -> e -> Failure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FailureInternal
FailurePrivate (Text -> FailureInternal) -> (e -> Text) -> e -> FailureInternal
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HostName -> Text
pack (HostName -> Text) -> (e -> HostName) -> e -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. e -> HostName
forall e. Exception e => e -> HostName
displayException
  monitorTotalExtOutgoingLiquidity :: Liquidity 'Outgoing -> AppM m ()
monitorTotalExtOutgoingLiquidity Liquidity 'Outgoing
amt = do
    Liquidity 'Outgoing
lim <- (Env -> Liquidity 'Outgoing) -> AppM m (Liquidity 'Outgoing)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Liquidity 'Outgoing
Env.envMinTotalExtOutgoingLiquidity
    Bool -> AppM m () -> AppM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Liquidity 'Outgoing
amt Liquidity 'Outgoing -> Liquidity 'Outgoing -> Bool
forall a. Ord a => a -> a -> Bool
< Liquidity 'Outgoing
lim) (AppM m () -> AppM m ()) -> AppM m () -> AppM m ()
forall a b. (a -> b) -> a -> b
$
      $(logTM) Severity
CriticalS (LogStr -> AppM m ()) -> (Text -> LogStr) -> Text -> AppM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> AppM m ()) -> Text -> AppM m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Not enough outgoing liquidity to the external "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"lightning network, got "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Liquidity 'Outgoing -> Text
forall a. Out a => a -> Text
inspect Liquidity 'Outgoing
amt
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but minimum is "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Liquidity 'Outgoing -> Text
forall a. Out a => a -> Text
inspect Liquidity 'Outgoing
lim
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
  monitorTotalExtIncomingLiquidity :: Liquidity 'Incoming -> AppM m ()
monitorTotalExtIncomingLiquidity Liquidity 'Incoming
amt = do
    Liquidity 'Incoming
lim <- (Env -> Liquidity 'Incoming) -> AppM m (Liquidity 'Incoming)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Liquidity 'Incoming
Env.envMinTotalExtIncomingLiquidity
    Bool -> AppM m () -> AppM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Liquidity 'Incoming
amt Liquidity 'Incoming -> Liquidity 'Incoming -> Bool
forall a. Ord a => a -> a -> Bool
< Liquidity 'Incoming
lim) (AppM m () -> AppM m ()) -> AppM m () -> AppM m ()
forall a b. (a -> b) -> a -> b
$
      $(logTM) Severity
CriticalS (LogStr -> AppM m ()) -> (Text -> LogStr) -> Text -> AppM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> AppM m ()) -> Text -> AppM m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Not enough incoming liquidity from the external "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"lightning network, got "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Liquidity 'Incoming -> Text
forall a. Out a => a -> Text
inspect Liquidity 'Incoming
amt
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but minimum is "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Liquidity 'Incoming -> Text
forall a. Out a => a -> Text
inspect Liquidity 'Incoming
lim
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."
  monitorTotalOnChainLiquidity :: WalletBalance -> AppM m ()
monitorTotalOnChainLiquidity WalletBalance
wal = do
    MSat
lim <- (Env -> MSat) -> AppM m MSat
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> MSat
Env.envMinTotalOnChainLiquidity
    Bool -> AppM m () -> AppM m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (WalletBalance -> MSat
Lnd.totalBalance WalletBalance
wal MSat -> MSat -> Bool
forall a. Ord a => a -> a -> Bool
< MSat
lim) (AppM m () -> AppM m ()) -> AppM m () -> AppM m ()
forall a b. (a -> b) -> a -> b
$
      $(logTM) Severity
CriticalS (LogStr -> AppM m ()) -> (Text -> LogStr) -> Text -> AppM m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> AppM m ()) -> Text -> AppM m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Not enough onchain liquidity, got "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> WalletBalance -> Text
forall a. Out a => a -> Text
inspect WalletBalance
wal
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" but minimum is "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> MSat -> Text
forall a. Out a => a -> Text
inspect MSat
lim
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"."

instance (MonadUnliftIO m) => Storage (AppM m) where
  getSqlPool :: AppM m (Pool SqlBackend)
getSqlPool = (Env -> Pool SqlBackend) -> AppM m (Pool SqlBackend)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Pool SqlBackend
envSQLPool
  runSql :: forall a. ReaderT SqlBackend (AppM m) a -> AppM m a
runSql ReaderT SqlBackend (AppM m) a
query = do
    Pool SqlBackend
pool <- (Env -> Pool SqlBackend) -> AppM m (Pool SqlBackend)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Env -> Pool SqlBackend
envSQLPool
    ReaderT SqlBackend (AppM m) a -> Pool SqlBackend -> AppM m a
forall backend (m :: * -> *) a.
(MonadUnliftIO m, BackendCompatible SqlBackend backend) =>
ReaderT backend m a -> Pool backend -> m a
Psql.runSqlPool ReaderT SqlBackend (AppM m) a
query Pool SqlBackend
pool