{-# LANGUAGE TemplateHaskell #-}

module BtcLsp.Thread.Main
  ( main,
    apply,
    waitForSync,
  )
where

import BtcLsp.Data.AppM (runApp)
import qualified BtcLsp.Data.Env as Env
import BtcLsp.Import
import qualified BtcLsp.Storage.Migration as Storage
import qualified BtcLsp.Thread.BlockScanner as BlockScanner
import qualified BtcLsp.Thread.Expirer as Expirer
import qualified BtcLsp.Thread.LnChanOpener as LnChanOpener
import qualified BtcLsp.Thread.LnChanWatcher as LnChanWatcher
import qualified BtcLsp.Thread.Refunder as Refunder
import qualified BtcLsp.Thread.Server as Server
import qualified BtcLsp.Yesod.Application as Yesod
import Katip
import qualified LndClient.Data.GetInfo as Lnd
import qualified LndClient.RPC.Katip as Lnd
import qualified Network.Bitcoin.BlockChain as Btc

main :: IO ()
main :: IO ()
main = do
  Scribe
startupScribe <-
    ColorStrategy -> Handle -> PermitFunc -> Verbosity -> IO Scribe
mkHandleScribe ColorStrategy
ColorIfTerminal Handle
stdout (Severity -> Item a -> IO Bool
forall (m :: * -> *) a. Monad m => Severity -> Item a -> m Bool
permitItem Severity
InfoS) Verbosity
V2
  let startupLogEnv :: IO LogEnv
startupLogEnv =
        Text -> Scribe -> ScribeSettings -> LogEnv -> IO LogEnv
registerScribe
          Text
"stdout"
          Scribe
startupScribe
          ScribeSettings
defaultScribeSettings
          (LogEnv -> IO LogEnv) -> IO LogEnv -> IO LogEnv
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Namespace -> Environment -> IO LogEnv
initLogEnv Namespace
"BtcLsp" Environment
"startup"
  RawConfig
cfg <- IO LogEnv
-> (LogEnv -> IO LogEnv)
-> (LogEnv -> IO RawConfig)
-> IO RawConfig
forall (m :: * -> *) a b c.
MonadUnliftIO m =>
m a -> (a -> m b) -> (a -> m c) -> m c
bracket IO LogEnv
startupLogEnv LogEnv -> IO LogEnv
closeScribes ((LogEnv -> IO RawConfig) -> IO RawConfig)
-> (LogEnv -> IO RawConfig) -> IO RawConfig
forall a b. (a -> b) -> a -> b
$ \LogEnv
le ->
    LogEnv
-> LogContexts
-> Namespace
-> KatipContextT IO RawConfig
-> IO RawConfig
forall c (m :: * -> *) a.
LogItem c =>
LogEnv -> c -> Namespace -> KatipContextT m a -> m a
runKatipContextT LogEnv
le (LogContexts
forall a. Monoid a => a
mempty :: LogContexts) Namespace
forall a. Monoid a => a
mempty (KatipContextT IO RawConfig -> IO RawConfig)
-> KatipContextT IO RawConfig -> IO RawConfig
forall a b. (a -> b) -> a -> b
$ do
      $(logTM) Severity
InfoS LogStr
"Lsp is starting!"
      $(logTM) Severity
InfoS LogStr
"Reading lsp raw environment..."
      RawConfig
cfg <- IO RawConfig -> KatipContextT IO RawConfig
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO RawConfig
readRawConfig
      let secret :: Text -> [(Text, Text)] -> LogStr
secret Text
title [(Text, Text)]
x =
            Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> LogStr) -> Text -> LogStr
forall a b. (a -> b) -> a -> b
$
              Text
title
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" = "
                Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> PrettyLog [(Text, Text)] -> Text
forall a. Out a => a -> Text
inspect
                  ( SecretVision -> [(Text, Text)] -> PrettyLog [(Text, Text)]
forall a. SecretVision -> a -> PrettyLog a
SecretLog (RawConfig -> SecretVision
Env.rawConfigLogSecrets RawConfig
cfg) [(Text, Text)]
x
                  )
      let btc :: BitcoindEnv
btc = RawConfig -> BitcoindEnv
Env.rawConfigBtcEnv RawConfig
cfg
      $(logTM) Severity
InfoS (LogStr -> KatipContextT IO ()) -> LogStr -> KatipContextT IO ()
forall a b. (a -> b) -> a -> b
$
        Text -> [(Text, Text)] -> LogStr
secret
          Text
"rawConfigBtcEnv"
          [ (Text
"host" :: Text, BitcoindEnv -> Text
Env.bitcoindEnvHost BitcoindEnv
btc),
            (Text
"user", BitcoindEnv -> Text
Env.bitcoindEnvUsername BitcoindEnv
btc),
            (Text
"pass", BitcoindEnv -> Text
Env.bitcoindEnvPassword BitcoindEnv
btc)
          ]
      $(logTM) Severity
InfoS LogStr
"Creating lsp runtime environment..."
      RawConfig -> KatipContextT IO RawConfig
forall (f :: * -> *) a. Applicative f => a -> f a
pure RawConfig
cfg
  RawConfig -> (Env -> KatipContextT IO ()) -> IO ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
RawConfig -> (Env -> KatipContextT m a) -> m a
withEnv RawConfig
cfg ((Env -> KatipContextT IO ()) -> IO ())
-> (Env -> KatipContextT IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$
    \Env
env -> Env -> AppM (KatipContextT IO) () -> KatipContextT IO ()
forall (m :: * -> *) a. Env -> AppM m a -> m a
runApp Env
env AppM (KatipContextT IO) ()
forall (m :: * -> *). Env m => m ()
apply

apply :: (Env m) => m ()
apply :: forall (m :: * -> *). Env m => m ()
apply = do
  $(logTM) Severity
InfoS LogStr
"Waiting for bitcoind..."
  m ()
forall (m :: * -> *). Env m => m ()
waitForBitcoindSync
  $(logTM) Severity
InfoS LogStr
"Waiting for lnd unlock..."
  Either Failure ()
unlocked <- (LndEnv -> m (Either LndError ()))
-> (m (Either LndError ()) -> m (Either LndError ()))
-> m (Either Failure ())
forall (m :: * -> *) a b.
Env m =>
(LndEnv -> a)
-> (a -> m (Either LndError b)) -> m (Either Failure b)
withLnd LndEnv -> m (Either LndError ())
forall (m :: * -> *).
(KatipContext m, MonadUnliftIO m) =>
LndEnv -> m (Either LndError ())
Lnd.lazyUnlockWallet m (Either LndError ()) -> m (Either LndError ())
forall a. a -> a
id
  if Either Failure () -> Bool
forall a b. Either a b -> Bool
isRight Either Failure ()
unlocked
    then do
      $(logTM) Severity
InfoS LogStr
"Waiting for lnd sync..."
      m ()
forall (m :: * -> *). Env m => m ()
waitForLndSync
      $(logTM) Severity
InfoS LogStr
"Running postgres migrations..."
      m ()
forall (m :: * -> *). (Storage m, KatipContext m) => m ()
Storage.migrateAll
      YesodLog
log <- m YesodLog
forall (m :: * -> *). Env m => m YesodLog
getYesodLog
      Pool SqlBackend
pool <- m (Pool SqlBackend)
forall (m :: * -> *). Storage m => m (Pool SqlBackend)
getSqlPool
      $(logTM) Severity
InfoS LogStr
"Spawning lsp threads..."
      [Async ()]
xs <-
        (m () -> m (Async ())) -> [m ()] -> m [Async ()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
          m () -> m (Async ())
forall (m :: * -> *) a. MonadUnliftIO m => m a -> m (Async a)
spawnLink
          [ m ()
forall (m :: * -> *). Env m => m ()
Server.apply,
            m ()
forall (m :: * -> *). Env m => m ()
LnChanWatcher.applySub,
            m ()
forall (m :: * -> *). Env m => m ()
LnChanWatcher.applyPoll,
            m ()
forall (m :: * -> *). Env m => m ()
LnChanOpener.apply,
            m ()
forall (m :: * -> *). Env m => m ()
BlockScanner.apply,
            m ()
forall (m :: * -> *). Env m => m ()
Refunder.apply,
            m ()
forall (m :: * -> *). Env m => m ()
Expirer.apply,
            (UnliftIO m -> IO ()) -> m ()
forall (m :: * -> *) a.
MonadUnliftIO m =>
(UnliftIO m -> IO a) -> m a
withUnliftIO ((UnliftIO m -> IO ()) -> m ()) -> (UnliftIO m -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ YesodLog -> Pool SqlBackend -> UnliftIO m -> IO ()
forall (m :: * -> *).
Env m =>
YesodLog -> Pool SqlBackend -> UnliftIO m -> IO ()
Yesod.appMain YesodLog
log Pool SqlBackend
pool
          ]
      $(logTM) Severity
InfoS LogStr
"Lsp is running!"
      IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO
        (IO () -> m ())
-> (IO (Async (), ()) -> IO ()) -> IO (Async (), ()) -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO (Async (), ()) -> IO ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void
        (IO (Async (), ()) -> m ()) -> IO (Async (), ()) -> m ()
forall a b. (a -> b) -> a -> b
$ [Async ()] -> IO (Async (), ())
forall a. [Async a] -> IO (Async a, a)
waitAnyCancel [Async ()]
xs
    else
      $(logTM) Severity
ErrorS (LogStr -> m ()) -> (Text -> LogStr) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$
        Text
"Can not unlock wallet, got "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Either Failure () -> Text
forall a. Out a => a -> Text
inspect Either Failure ()
unlocked
  $(logTM) Severity
ErrorS LogStr
"Lsp terminates!"

waitForBitcoindSync :: (Env m) => m ()
waitForBitcoindSync :: forall (m :: * -> *). Env m => m ()
waitForBitcoindSync =
  (Failure -> m ())
-> (BlockChainInfo -> m ())
-> m (Either Failure BlockChainInfo)
-> m ()
forall (m :: * -> *) a c b.
Monad m =>
(a -> m c) -> (b -> m c) -> m (Either a b) -> m c
eitherM
    ( \Failure
e -> do
        $(logTM) Severity
ErrorS (LogStr -> m ()) -> (Text -> LogStr) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Failure -> Text
forall a. Out a => a -> Text
inspect Failure
e
        m ()
forall (m :: * -> *). Env m => m ()
waitAndRetry
    )
    ( \BlockChainInfo
x ->
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockChainInfo -> Bool
Btc.bciInitialBlockDownload BlockChainInfo
x) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          $(logTM) Severity
InfoS (LogStr -> m ()) -> (Text -> LogStr) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Waiting IBD: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> BlockChainInfo -> Text
forall a. Out a => a -> Text
inspect BlockChainInfo
x
          m ()
forall (m :: * -> *). Env m => m ()
waitAndRetry
    )
    (m (Either Failure BlockChainInfo) -> m ())
-> m (Either Failure BlockChainInfo) -> m ()
forall a b. (a -> b) -> a -> b
$ (Client -> IO BlockChainInfo)
-> (IO BlockChainInfo -> IO BlockChainInfo)
-> m (Either Failure BlockChainInfo)
forall (m :: * -> *) a b.
Env m =>
(Client -> a) -> (a -> IO b) -> m (Either Failure b)
withBtc Client -> IO BlockChainInfo
Btc.getBlockChainInfo IO BlockChainInfo -> IO BlockChainInfo
forall a. a -> a
id
  where
    waitAndRetry :: (Env m) => m ()
    waitAndRetry :: forall (m :: * -> *). Env m => m ()
waitAndRetry =
      m ()
forall (m :: * -> *). MonadIO m => m ()
sleep5s m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: * -> *). Env m => m ()
waitForBitcoindSync

waitForLndSync :: (Env m) => m ()
waitForLndSync :: forall (m :: * -> *). Env m => m ()
waitForLndSync =
  (Failure -> m ())
-> (GetInfoResponse -> m ())
-> m (Either Failure GetInfoResponse)
-> m ()
forall (m :: * -> *) a c b.
Monad m =>
(a -> m c) -> (b -> m c) -> m (Either a b) -> m c
eitherM
    ( \Failure
e -> do
        $(logTM) Severity
ErrorS (LogStr -> m ()) -> (Text -> LogStr) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Failure -> Text
forall a. Out a => a -> Text
inspect Failure
e
        m ()
forall (m :: * -> *). Env m => m ()
waitAndRetry
    )
    ( \GetInfoResponse
x ->
        Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (GetInfoResponse -> Bool
Lnd.syncedToChain GetInfoResponse
x) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
          $(logTM) Severity
InfoS (LogStr -> m ()) -> (Text -> LogStr) -> Text -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> LogStr
forall a. StringConv a Text => a -> LogStr
logStr (Text -> m ()) -> Text -> m ()
forall a b. (a -> b) -> a -> b
$ Text
"Waiting Lnd: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> GetInfoResponse -> Text
forall a. Out a => a -> Text
inspect GetInfoResponse
x
          m ()
forall (m :: * -> *). Env m => m ()
waitAndRetry
    )
    (m (Either Failure GetInfoResponse) -> m ())
-> m (Either Failure GetInfoResponse) -> m ()
forall a b. (a -> b) -> a -> b
$ (LndEnv -> m (Either LndError GetInfoResponse))
-> (m (Either LndError GetInfoResponse)
    -> m (Either LndError GetInfoResponse))
-> m (Either Failure GetInfoResponse)
forall (m :: * -> *) a b.
Env m =>
(LndEnv -> a)
-> (a -> m (Either LndError b)) -> m (Either Failure b)
withLnd LndEnv -> m (Either LndError GetInfoResponse)
forall (m :: * -> *).
(KatipContext m, MonadUnliftIO m) =>
LndEnv -> m (Either LndError GetInfoResponse)
Lnd.getInfo m (Either LndError GetInfoResponse)
-> m (Either LndError GetInfoResponse)
forall a. a -> a
id
  where
    waitAndRetry :: (Env m) => m ()
    waitAndRetry :: forall (m :: * -> *). Env m => m ()
waitAndRetry =
      m ()
forall (m :: * -> *). MonadIO m => m ()
sleep5s m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: * -> *). Env m => m ()
waitForLndSync

waitForSync :: (Env m) => m ()
waitForSync :: forall (m :: * -> *). Env m => m ()
waitForSync =
  m ()
forall (m :: * -> *). Env m => m ()
waitForBitcoindSync
    m () -> m () -> m ()
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> m ()
forall (m :: * -> *). Env m => m ()
waitForLndSync