{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
module LndClient.LndTest
(
BtcUrl (..),
BtcLogin (..),
BtcPassword (..),
BtcEnv (..),
newBtcClient,
TestEnv,
newTestEnv,
spawnLinkChannelWatcher,
spawnLinkInvoiceWatcher,
spawnLinkSingleInvoiceWatcher,
LndTest (..),
mine,
mine1,
syncWallets,
syncPendingChannels,
syncPendingChannelsFor,
sendTestPayment,
receiveClosedChannels,
receiveActiveChannel,
receiveInvoice,
lazyMineInitialCoins,
lazyConnectNodes,
watchDefaults,
cancelAllInvoices,
closeAllChannels,
setupZeroChannels,
setupOneChannel,
liftLndResult,
liftMaybe,
purgeChan,
ignore2,
ignore3,
)
where
import LndClient.Data.AddInvoice as AddInvoice
( AddInvoiceRequest (..),
AddInvoiceResponse (..),
)
import LndClient.Data.Channel as Channel (Channel (..))
import LndClient.Data.ChannelPoint as ChannelPoint (ChannelPoint (..))
import LndClient.Data.CloseChannel
( ChannelCloseSummary (..),
CloseChannelRequest (..),
)
import LndClient.Data.ClosedChannels as ClosedChannels
import LndClient.Data.GetInfo (GetInfoResponse (..))
import qualified LndClient.Data.GetInfo as Lnd (GetInfoResponse (..))
import LndClient.Data.Invoice as Invoice (Invoice (..), InvoiceState (..))
import LndClient.Data.ListChannels as LC (ListChannelsRequest (..))
import qualified LndClient.Data.ListInvoices as ListInvoices
import qualified LndClient.Data.NewAddress as Lnd
( AddressType (..),
NewAddressRequest (..),
NewAddressResponse (..),
)
import LndClient.Data.OpenChannel as OpenChannel
( OpenChannelRequest (..),
)
import LndClient.Data.Peer
( ConnectPeerRequest (..),
LightningAddress (..),
)
import LndClient.Data.PendingChannels (PendingChannelsResponse (..))
import LndClient.Data.SendPayment as SendPayment
( SendPaymentRequest (..),
)
import LndClient.Data.SubscribeChannelEvents
import LndClient.Data.SubscribeInvoices
( SubscribeInvoicesRequest (..),
)
import LndClient.Import
import qualified LndClient.RPC.Katip as Lnd
import LndClient.Watcher as Watcher
import qualified Network.Bitcoin as BTC (Client, getClient)
import qualified Network.Bitcoin.BlockChain as BTC (getBlockCount)
import qualified Network.Bitcoin.Mining as BTC (generateToAddress)
newtype BtcUrl = BtcUrl String
newtype BtcLogin = BtcLogin ByteString
newtype BtcPassword = BtcPassword ByteString
data BtcEnv
= BtcEnv
{ btcUrl :: BtcUrl,
btcLogin :: BtcLogin,
btcPassword :: BtcPassword
}
data TestEnv
= TestEnv
{ testLndEnv :: LndEnv,
testNodeLocation :: NodeLocation,
testChannelWatcher :: Watcher () ChannelEventUpdate,
testInvoiceWatcher :: Watcher SubscribeInvoicesRequest Invoice,
testSingleInvoiceWatcher :: Watcher RHash Invoice
}
uniquePairs :: (Ord a, Enum a, Bounded a) => [(a, a)]
uniquePairs = [(x0, x1) | x0 <- enumerate, x1 <- enumerate, x0 < x1]
newBtcClient :: MonadIO m => BtcEnv -> m BTC.Client
newBtcClient x =
liftIO $
BTC.getClient
(coerce $ btcUrl x)
(coerce $ btcLogin x)
(coerce $ btcPassword x)
newTestEnv ::
( KatipContext m,
MonadUnliftIO m
) =>
LndEnv ->
NodeLocation ->
m TestEnv
newTestEnv lnd loc = do
cw <- spawnLinkChannelWatcher lnd
iw <- spawnLinkInvoiceWatcher lnd
siw <- spawnLinkSingleInvoiceWatcher lnd
pure $
TestEnv
{ testLndEnv = lnd,
testNodeLocation = loc,
testChannelWatcher = cw,
testInvoiceWatcher = iw,
testSingleInvoiceWatcher = siw
}
class
( KatipContext m,
MonadUnliftIO m,
Ord owner,
Enum owner,
Bounded owner,
Show owner
) =>
LndTest m owner where
getBtcClient :: owner -> m BTC.Client
getTestEnv :: owner -> m TestEnv
getLndEnv :: owner -> m LndEnv
getLndEnv = (testLndEnv <$>) . getTestEnv
getSev :: owner -> Severity -> m Severity
getSev owner sev = do
env <- testLndEnv <$> getTestEnv owner
pure $ newSev env sev
getNodeLocation :: owner -> m NodeLocation
getNodeLocation = (testNodeLocation <$>) . getTestEnv
getChannelTChan :: owner -> m (TChan ((), ChannelEventUpdate))
getChannelTChan =
(Watcher.dupLndTChan =<<)
. (testChannelWatcher <$>)
. getTestEnv
getInvoiceTChan :: owner -> m (TChan (SubscribeInvoicesRequest, Invoice))
getInvoiceTChan =
(Watcher.dupLndTChan =<<)
. (testInvoiceWatcher <$>)
. getTestEnv
getSingleInvoiceTChan :: owner -> m (TChan (RHash, Invoice))
getSingleInvoiceTChan =
(Watcher.dupLndTChan =<<)
. (testSingleInvoiceWatcher <$>)
. getTestEnv
watchSingleInvoice :: owner -> RHash -> m ()
watchSingleInvoice owner rh = do
env <- getTestEnv owner
Watcher.watch (testSingleInvoiceWatcher env) rh
walletAddress :: LndTest m owner => owner -> m Text
walletAddress owner = do
lnd <- getLndEnv owner
Lnd.NewAddressResponse x <-
liftLndResult
=<< Lnd.newAddress
lnd
(Lnd.NewAddressRequest Lnd.WITNESS_PUBKEY_HASH Nothing)
pure x
lazyMineInitialCoins :: forall m owner. LndTest m owner => Proxy owner -> m ()
lazyMineInitialCoins = const $ do
mapM_ (liftLndResult <=< Lnd.lazyInitWallet <=< getLndEnv) xs
bc <- getBtcClient someone
h <- liftIO $ BTC.getBlockCount bc
when (h < 101 + numOwners) $ do
mapM_ (mine 1) xs
mine 101 someone
where
xs = enumerate :: [owner]
someone = minBound :: owner
numOwners = fromIntegral $ length xs
lazyConnectNodes :: forall m owner. LndTest m owner => Proxy owner -> m ()
lazyConnectNodes = const $ mapM_ this uniquePairs
where
this :: (owner, owner) -> m ()
this (owner0, owner1) = do
testEnvOwner0 <- getTestEnv owner0
Lnd.GetInfoResponse pubKeyOwner0 _ _ <-
liftLndResult =<< Lnd.getInfo (testLndEnv testEnvOwner0)
let req =
ConnectPeerRequest
{ addr =
LightningAddress
{ pubkey = pubKeyOwner0,
host = testNodeLocation testEnvOwner0
},
perm = False
}
lndEnvOwner1 <- getLndEnv owner1
liftLndResult =<< Lnd.lazyConnectPeer lndEnvOwner1 req
watchDefaults :: forall m owner. LndTest m owner => Proxy owner -> m ()
watchDefaults = const $ mapM_ this (enumerate :: [owner])
where
this owner = do
testEnv <- getTestEnv owner
Watcher.watchUnit $ testChannelWatcher testEnv
Watcher.watch (testInvoiceWatcher testEnv) iReq
iReq =
SubscribeInvoicesRequest (Just $ AddIndex 1) Nothing
mine :: forall m owner. LndTest m owner => Int -> owner -> m ()
mine blocks owner = do
btcAddr <- walletAddress owner
bc <- getBtcClient owner
sev <- getSev owner InfoS
$(logTM) sev $ logStr $
("Mining " :: Text)
<> show blocks
<> " blocks to "
<> show owner
<> " wallet"
void . liftIO $
BTC.generateToAddress
bc
blocks
btcAddr
Nothing
liftLndResult =<< syncWallets (Proxy :: Proxy owner)
mine1 :: forall m owner. LndTest m owner => Proxy owner -> m ()
mine1 = const $ mine 1 (minBound :: owner)
liftLndResult :: MonadIO m => Either LndError a -> m a
liftLndResult (Right x) =
pure x
liftLndResult (Left x) =
liftIO $ fail $ "LiftLndResult failed " <> show x
syncWallets ::
forall m owner.
LndTest m owner =>
Proxy owner ->
m (Either LndError ())
syncWallets = const $ this 0
where
this 30 = do
let msg = "SyncWallets attempt limit exceeded"
sev <- getSev (minBound :: owner) ErrorS
$(logTM) sev $ logStr msg
pure . Left $ LndError msg
this (attempt :: Int) = do
sev <- getSev (minBound :: owner) InfoS
$(logTM) sev "SyncWallets is running"
rs <- mapM (Lnd.getInfo <=< getLndEnv) (enumerate :: [owner])
if all isInSync rs
then pure $ Right ()
else liftIO (delay 1000000) >> this (attempt + 1)
isInSync = \case
Left {} -> False
Right x -> Lnd.syncedToChain x
syncPendingChannels :: forall m owner. LndTest m owner => Proxy owner -> m ()
syncPendingChannels =
const $ mapM_ (liftLndResult <=< syncPendingChannelsFor) (enumerate :: [owner])
syncPendingChannelsFor ::
forall m owner.
LndTest m owner =>
owner ->
m (Either LndError ())
syncPendingChannelsFor owner = this 0
where
this 30 = do
let msg =
"SyncPendingChannelsFor "
<> show owner
<> " attempt limit exceeded"
sev <- getSev owner ErrorS
$(logTM) sev $ logStr msg
pure . Left $ LndError msg
this (attempt :: Int) = do
sev <- getSev owner InfoS
$(logTM) sev $ logStr $
"SyncPendingChannelsFor "
<> (show owner :: Text)
<> " is running"
res <- Lnd.pendingChannels =<< getLndEnv owner
case res of
Left {} -> this (attempt + 1)
Right (PendingChannelsResponse _ x0 x1 x2 x3) ->
if null x0
&& null x1
&& null x2
&& null x3
then pure $ Right ()
else mine1 (Proxy :: Proxy owner) >> this (attempt + 1)
receiveClosedChannels ::
forall m owner.
LndTest m owner =>
Proxy owner ->
[ChannelPoint] ->
m (Either LndError ())
receiveClosedChannels po = this 0
where
this _ [] =
pure $ Right ()
this 30 _ =
pure
$ Left
$ LndError "receiveClosedChannels - exceeded"
this (attempt :: Integer) cps = do
let owners = enumerate :: [owner]
xs <- rights <$> mapM getOwnersCloseCPs owners
let filteredCps = filter (checkTwiceCP $ concat xs) cps
if null filteredCps
then pure $ Right ()
else mine1 po >> liftIO (delay 1000000) >> this (attempt + 1) filteredCps
checkTwiceCP :: [ChannelPoint] -> ChannelPoint -> Bool
checkTwiceCP cps cp = length (filter (cp ==) cps) < 2
getOwnersCloseCPs :: owner -> m (Either LndError [ChannelPoint])
getOwnersCloseCPs o = do
lnd <- getLndEnv o
ccs <- liftLndResult =<< Lnd.closedChannels lnd ClosedChannels.defReq
pure $ Right $ chPoint <$> ccs
cancelAllInvoices ::
forall m owner.
LndTest m owner =>
Proxy owner ->
m ()
cancelAllInvoices =
const $ mapM_ (this 0) (enumerate :: [owner])
where
listReq =
ListInvoices.ListInvoiceRequest
{ ListInvoices.pendingOnly = False,
ListInvoices.indexOffset = AddIndex 0,
ListInvoices.numMaxInvoices = 0,
ListInvoices.reversed = False
}
this :: Int -> owner -> m ()
this 30 owner =
error $ "CancelAllInvoices attempt limit exceeded for " <> show owner
this attempt owner = do
lnd <- getLndEnv owner
let getInvoices =
filter
( \x ->
Invoice.state x
`elem` [ Invoice.OPEN,
Invoice.ACCEPTED
]
)
. ListInvoices.invoices
<$> (liftLndResult =<< Lnd.listInvoices lnd listReq)
is0 <- getInvoices
res <- mapM (Lnd.cancelInvoice lnd) (Invoice.rHash <$> is0)
is1 <- getInvoices
if all isRight res && null is1
then pure ()
else liftIO (delay 1000000) >> this (attempt + 1) owner
closeAllChannels :: forall m owner. LndTest m owner => Proxy owner -> m ()
closeAllChannels po = do
cancelAllInvoices po
mapM_ (this 0) uniquePairs
where
this :: Int -> (owner, owner) -> m ()
this 30 owners =
error $ "CloseAllChannels - limit exceeded for " <> show owners
this attempt (owner0, owner1) = do
sev <- getSev owner0 InfoS
$(logTM) sev "CloseAllChannels - closing channels"
lnd0 <- getLndEnv owner0
peerLocation <- getNodeLocation owner1
GetInfoResponse peerPubKey _ _ <-
liftLndResult =<< Lnd.getInfo =<< getLndEnv owner1
let getChannels =
liftLndResult
=<< Lnd.listChannels
lnd0
(ListChannelsRequest False False False False (Just peerPubKey))
cs0 <- getChannels
let cps = Channel.channelPoint <$> cs0
res <-
mapM
( \cp ->
Lnd.closeChannelSync
lnd0
(ConnectPeerRequest (LightningAddress peerPubKey peerLocation) False)
(CloseChannelRequest cp False Nothing Nothing Nothing)
)
cps
cs1 <- getChannels
if all isRight res && null cs1
then liftLndResult =<< receiveClosedChannels po cps
else liftIO (delay 1000000) >> this (attempt + 1) (owner0, owner1)
receiveActiveChannel ::
LndTest m owner =>
Proxy owner ->
ChannelPoint ->
TChan ((), ChannelEventUpdate) ->
m (Either LndError ())
receiveActiveChannel po = this 0
where
this (attempt :: Integer) cp cq =
if attempt > 30
then pure $ Left $ LndError "receiveActiveChannel - exceeded"
else do
x <- readTChanTimeout (MicroSecondsDelay 1000000) cq
case channelEvent . snd <$> x of
Just (ChannelEventUpdateChannelActiveChannel gcp) ->
if cp == gcp
then pure $ Right ()
else mine1 po >> this (attempt + 1) cp cq
_ ->
mine1 po >> this (attempt + 1) cp cq
setupZeroChannels :: LndTest m owner => Proxy owner -> m ()
setupZeroChannels x = do
lazyMineInitialCoins x
lazyConnectNodes x
watchDefaults x
closeAllChannels x
syncPendingChannels x
setupOneChannel ::
forall m owner.
LndTest m owner =>
owner ->
owner ->
m ChannelPoint
setupOneChannel ownerFrom ownerTo = do
lndFrom <- getLndEnv ownerFrom
lndTo <- getLndEnv ownerTo
mq <- getChannelTChan ownerTo
cq <- getChannelTChan ownerFrom
sev <- getSev ownerFrom InfoS
$(logTM) sev "SetupOneChannel - opening channel"
GetInfoResponse merchantPubKey _ _ <-
liftLndResult =<< Lnd.getInfo lndTo
let openChannelRequest =
OpenChannel.OpenChannelRequest
{ OpenChannel.nodePubkey = merchantPubKey,
OpenChannel.localFundingAmount = MSat 200000000,
OpenChannel.pushSat = Just $ MSat 10000000,
OpenChannel.targetConf = Nothing,
OpenChannel.satPerByte = Nothing,
OpenChannel.private = Nothing,
OpenChannel.minHtlcMsat = Nothing,
OpenChannel.remoteCsvDelay = Nothing,
OpenChannel.minConfs = Nothing,
OpenChannel.spendUnconfirmed = Nothing,
OpenChannel.closeAddress = Nothing
}
cp <-
liftLndResult
=<< Lnd.openChannelSync lndFrom openChannelRequest
let po = Proxy :: Proxy owner
liftLndResult =<< receiveActiveChannel po cp mq
liftLndResult =<< receiveActiveChannel po cp cq
() <- sendTestPayment (MSat 1000000) ownerFrom ownerTo
() <- sendTestPayment (MSat 1000000) ownerTo ownerFrom
$(logTM) sev "SetupOneChannel - finished"
pure cp
sendTestPayment :: LndTest m owner => MSat -> owner -> owner -> m ()
sendTestPayment amt0 sender0 recepient0 = do
sender <- getLndEnv sender0
recepient <- getLndEnv recepient0
let addInvoiceRequest =
AddInvoice.AddInvoiceRequest
{ AddInvoice.memo = Just "HELLO",
AddInvoice.valueMsat = amt0,
AddInvoice.expiry = Just $ Seconds 1000
}
invoice <-
liftLndResult =<< Lnd.addInvoice recepient addInvoiceRequest
let payReq =
SendPayment.SendPaymentRequest
{ SendPayment.paymentRequest =
AddInvoice.paymentRequest invoice,
SendPayment.amt = amt0
}
void . liftLndResult =<< Lnd.sendPayment sender payReq
receiveInvoice ::
( MonadUnliftIO m,
KatipContext m
) =>
RHash ->
Invoice.InvoiceState ->
TChan (a, Invoice) ->
m (Either LndError ())
receiveInvoice rh s q = do
mx0 <- readTChanTimeout (MicroSecondsDelay 30000000) q
let mx = snd <$> mx0
$(logTM) DebugS $ logStr $
"receiveInvoice - " <> (show mx :: Text)
case (\x -> Invoice.rHash x == rh && Invoice.state x == s) <$> mx of
Just True -> return $ Right ()
Just False -> receiveInvoice rh s q
Nothing -> return . Left $ TChanTimeout "receiveInvoice"
liftMaybe :: MonadIO m => String -> Maybe a -> m a
liftMaybe msg mx =
case mx of
Just x -> pure x
Nothing -> liftIO $ fail msg
purgeChan :: MonadUnliftIO m => TChan a -> m ()
purgeChan chan = do
x <- readTChanTimeout (MicroSecondsDelay 500000) chan
when (isJust x) $ purgeChan chan
ignore2 :: Monad m => a -> b -> m ()
ignore2 _ _ = pure ()
ignore3 :: Monad m => a -> b -> c -> m ()
ignore3 _ _ _ = pure ()
spawnLinkChannelWatcher ::
(KatipContext m, MonadUnliftIO m) =>
LndEnv ->
m (Watcher () ChannelEventUpdate)
spawnLinkChannelWatcher lnd =
Watcher.spawnLinkUnit
lnd
Lnd.subscribeChannelEventsChan
ignore2
spawnLinkInvoiceWatcher ::
(KatipContext m, MonadUnliftIO m) =>
LndEnv ->
m (Watcher SubscribeInvoicesRequest Invoice)
spawnLinkInvoiceWatcher lnd =
Watcher.spawnLink
lnd
Lnd.subscribeInvoicesChan
ignore3
spawnLinkSingleInvoiceWatcher ::
(KatipContext m, MonadUnliftIO m) =>
LndEnv ->
m (Watcher RHash Invoice)
spawnLinkSingleInvoiceWatcher lnd =
Watcher.spawnLink
lnd
Lnd.subscribeSingleInvoiceChan
ignore3