{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeApplications #-}

module BtcLsp.Grpc.Client.HighLevel
  ( swapIntoLn,
    swapIntoLnT,
    getCfg,
    getCfgT,
  )
where

import BtcLsp.Grpc.Client.LowLevel
import BtcLsp.Import
import qualified Data.Binary.Builder as BS
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import Data.ProtoLens.Field
import Data.ProtoLens.Message
import qualified LndClient.Data.VerifyMessage as Lnd
import qualified LndClient.RPC.Katip as Lnd
import qualified Network.GRPC.HTTP2.Encoding as G
import Network.GRPC.HTTP2.ProtoLens (RPC (..))
import Proto.BtcLsp (Service)
import qualified Proto.BtcLsp.Data.HighLevel as Proto
import qualified Proto.BtcLsp.Data.HighLevel_Fields as Proto
import qualified Proto.BtcLsp.Method.GetCfg as GetCfg
import qualified Proto.BtcLsp.Method.SwapIntoLn as SwapIntoLn

swapIntoLn ::
  ( Env m
  ) =>
  GCEnv ->
  SwapIntoLn.Request ->
  m (Either Failure SwapIntoLn.Response)
swapIntoLn :: forall (m :: * -> *).
Env m =>
GCEnv -> Request -> m (Either Failure Response)
swapIntoLn GCEnv
env Request
req = ((forall a. m a -> IO a) -> IO (Either Failure Response))
-> m (Either Failure Response)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO (Either Failure Response))
 -> m (Either Failure Response))
-> ((forall a. m a -> IO a) -> IO (Either Failure Response))
-> m (Either Failure Response)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
  (Text -> Failure)
-> Either Text Response -> Either Failure Response
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FailureInternal -> Failure
FailureInt (FailureInternal -> Failure)
-> (Text -> FailureInternal) -> Text -> Failure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FailureInternal
FailureGrpcClient)
    (Either Text Response -> Either Failure Response)
-> IO (Either Text Response) -> IO (Either Failure Response)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RPC Service "swapIntoLn"
-> GCEnv
-> (Response -> ByteString -> CompressMode -> IO Bool)
-> Request
-> IO (Either Text Response)
forall res s (m :: Symbol) req.
(Out res, Show res, HasMethod s m, req ~ MethodInput s m,
 res ~ MethodOutput s m) =>
RPC s m
-> GCEnv
-> (res -> ByteString -> CompressMode -> IO Bool)
-> req
-> IO (Either Text res)
runUnary
      (RPC Service "swapIntoLn"
forall s (m :: Symbol). RPC s m
RPC :: RPC Service "swapIntoLn")
      GCEnv
env
      ( \Response
res ByteString
sig CompressMode
compressMode ->
          m Bool -> IO Bool
forall a. m a -> IO a
run (m Bool -> IO Bool) -> m Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
            Response -> ByteString -> CompressMode -> m Bool
forall (m :: * -> *) msg.
(Env m, Message msg, HasField msg "ctx" Ctx) =>
msg -> ByteString -> CompressMode -> m Bool
verifySig Response
res ByteString
sig CompressMode
compressMode
      )
      Request
req

swapIntoLnT ::
  ( Env m
  ) =>
  GCEnv ->
  SwapIntoLn.Request ->
  ExceptT Failure m SwapIntoLn.Response
swapIntoLnT :: forall (m :: * -> *).
Env m =>
GCEnv -> Request -> ExceptT Failure m Response
swapIntoLnT GCEnv
env =
  m (Either Failure Response) -> ExceptT Failure m Response
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either Failure Response) -> ExceptT Failure m Response)
-> (Request -> m (Either Failure Response))
-> Request
-> ExceptT Failure m Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GCEnv -> Request -> m (Either Failure Response)
forall (m :: * -> *).
Env m =>
GCEnv -> Request -> m (Either Failure Response)
swapIntoLn GCEnv
env

getCfg ::
  ( Env m
  ) =>
  GCEnv ->
  GetCfg.Request ->
  m (Either Failure GetCfg.Response)
getCfg :: forall (m :: * -> *).
Env m =>
GCEnv -> Request -> m (Either Failure Response)
getCfg GCEnv
env Request
req = ((forall a. m a -> IO a) -> IO (Either Failure Response))
-> m (Either Failure Response)
forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO (((forall a. m a -> IO a) -> IO (Either Failure Response))
 -> m (Either Failure Response))
-> ((forall a. m a -> IO a) -> IO (Either Failure Response))
-> m (Either Failure Response)
forall a b. (a -> b) -> a -> b
$ \forall a. m a -> IO a
run ->
  (Text -> Failure)
-> Either Text Response -> Either Failure Response
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (FailureInternal -> Failure
FailureInt (FailureInternal -> Failure)
-> (Text -> FailureInternal) -> Text -> Failure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FailureInternal
FailureGrpcClient)
    (Either Text Response -> Either Failure Response)
-> IO (Either Text Response) -> IO (Either Failure Response)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RPC Service "getCfg"
-> GCEnv
-> (Response -> ByteString -> CompressMode -> IO Bool)
-> Request
-> IO (Either Text Response)
forall res s (m :: Symbol) req.
(Out res, Show res, HasMethod s m, req ~ MethodInput s m,
 res ~ MethodOutput s m) =>
RPC s m
-> GCEnv
-> (res -> ByteString -> CompressMode -> IO Bool)
-> req
-> IO (Either Text res)
runUnary
      (RPC Service "getCfg"
forall s (m :: Symbol). RPC s m
RPC :: RPC Service "getCfg")
      GCEnv
env
      ( \Response
res ByteString
sig CompressMode
compressMode ->
          m Bool -> IO Bool
forall a. m a -> IO a
run (m Bool -> IO Bool) -> m Bool -> IO Bool
forall a b. (a -> b) -> a -> b
$
            Response -> ByteString -> CompressMode -> m Bool
forall (m :: * -> *) msg.
(Env m, Message msg, HasField msg "ctx" Ctx) =>
msg -> ByteString -> CompressMode -> m Bool
verifySig Response
res ByteString
sig CompressMode
compressMode
      )
      Request
req

getCfgT ::
  ( Env m
  ) =>
  GCEnv ->
  GetCfg.Request ->
  ExceptT Failure m GetCfg.Response
getCfgT :: forall (m :: * -> *).
Env m =>
GCEnv -> Request -> ExceptT Failure m Response
getCfgT GCEnv
env =
  m (Either Failure Response) -> ExceptT Failure m Response
forall e (m :: * -> *) a. m (Either e a) -> ExceptT e m a
ExceptT (m (Either Failure Response) -> ExceptT Failure m Response)
-> (Request -> m (Either Failure Response))
-> Request
-> ExceptT Failure m Response
forall b c a. (b -> c) -> (a -> b) -> a -> c
. GCEnv -> Request -> m (Either Failure Response)
forall (m :: * -> *).
Env m =>
GCEnv -> Request -> m (Either Failure Response)
getCfg GCEnv
env

-- | WARNING : this function is unsafe and inefficient
-- but it is used for testing purposes only!
verifySig ::
  ( Env m,
    Message msg,
    HasField msg "ctx" Proto.Ctx
  ) =>
  msg ->
  ByteString ->
  CompressMode ->
  m Bool
verifySig :: forall (m :: * -> *) msg.
(Env m, Message msg, HasField msg "ctx" Ctx) =>
msg -> ByteString -> CompressMode -> m Bool
verifySig msg
msg ByteString
sig CompressMode
compressMode = do
  let msgEncoded :: ByteString
msgEncoded =
        msg -> ByteString
forall msg. Message msg => msg -> ByteString
encodeMessage msg
msg
  let msgChunk :: ByteString
msgChunk =
        case CompressMode
compressMode of
          CompressMode
Compressed -> Compression -> ByteString -> ByteString
G._compressionFunction Compression
G.gzip ByteString
msgEncoded
          CompressMode
Uncompressed -> ByteString
msgEncoded
  let msgWire :: ByteString
msgWire =
        [Word8] -> ByteString
BS.pack
          [ case CompressMode
compressMode of
              CompressMode
Compressed -> Word8
1
              CompressMode
Uncompressed -> Word8
0
          ]
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ( ByteString -> ByteString
BL.toStrict
                 (ByteString -> ByteString)
-> (Int -> ByteString) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
BS.toLazyByteString
                 (Builder -> ByteString) -> (Int -> Builder) -> Int -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Word32 -> Builder
BS.putWord32be
                 (Word32 -> Builder) -> (Int -> Word32) -> Int -> Builder
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Word32
forall a b. (Integral a, Num b) => a -> b
fromIntegral -- Length is non-neg, it's fine.
                 (Int -> ByteString) -> Int -> ByteString
forall a b. (a -> b) -> a -> b
$ ByteString -> Int
BS.length ByteString
msgChunk
             )
          ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
msgChunk
  let pub :: ByteString
pub =
        msg
msg
          msg -> Getting ByteString msg ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. forall (x :: Symbol) s a (f :: * -> *).
(HasField s x a, Functor f) =>
(a -> f a) -> s -> f s
field @"ctx"
            ((Ctx -> Const ByteString Ctx) -> msg -> Const ByteString msg)
-> ((ByteString -> Const ByteString ByteString)
    -> Ctx -> Const ByteString Ctx)
-> Getting ByteString msg ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LensLike' (Const ByteString) Ctx LnPubKey
forall (f :: * -> *) s a.
(Functor f, HasField s "lnPubKey" a) =>
LensLike' f s a
Proto.lnPubKey
            LensLike' (Const ByteString) Ctx LnPubKey
-> ((ByteString -> Const ByteString ByteString)
    -> LnPubKey -> Const ByteString LnPubKey)
-> (ByteString -> Const ByteString ByteString)
-> Ctx
-> Const ByteString Ctx
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (ByteString -> Const ByteString ByteString)
-> LnPubKey -> Const ByteString LnPubKey
forall (f :: * -> *) s a.
(Functor f, HasField s "val" a) =>
LensLike' f s a
Proto.val
  Either Failure VerifyMessageResponse
res <-
    (LndEnv
 -> VerifyMessageRequest
 -> m (Either LndError VerifyMessageResponse))
-> ((VerifyMessageRequest
     -> m (Either LndError VerifyMessageResponse))
    -> m (Either LndError VerifyMessageResponse))
-> m (Either Failure VerifyMessageResponse)
forall (m :: * -> *) a b.
Env m =>
(LndEnv -> a)
-> (a -> m (Either LndError b)) -> m (Either Failure b)
withLnd
      LndEnv
-> VerifyMessageRequest
-> m (Either LndError VerifyMessageResponse)
forall (m :: * -> *).
(KatipContext m, MonadUnliftIO m) =>
LndEnv
-> VerifyMessageRequest
-> m (Either LndError VerifyMessageResponse)
Lnd.verifyMessage
      ( (VerifyMessageRequest -> m (Either LndError VerifyMessageResponse))
-> VerifyMessageRequest
-> m (Either LndError VerifyMessageResponse)
forall a b. (a -> b) -> a -> b
$
          VerifyMessageRequest :: ByteString -> ByteString -> ByteString -> VerifyMessageRequest
Lnd.VerifyMessageRequest
            { message :: ByteString
Lnd.message = ByteString
msgWire,
              signature :: ByteString
Lnd.signature = ByteString
sig,
              pubkey :: ByteString
Lnd.pubkey = ByteString
pub
            }
      )
  case Either Failure VerifyMessageResponse
res of
    Left 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
$
        Text
"Client ==> signature verification failed "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Failure -> Text
forall a. Out a => a -> Text
inspect Failure
e
      Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
    Right VerifyMessageResponse
x ->
      if VerifyMessageResponse -> Bool
coerce VerifyMessageResponse
x
        then Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
        else 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
$
            Text
"Client ==> signature verification failed "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"for message of "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Out a => a -> Text
inspect (ByteString -> Int
BS.length ByteString
msgWire)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a. Out a => a -> Text
inspect ByteString
msgWire
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" with signature of "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Int -> Text
forall a. Out a => a -> Text
inspect (ByteString -> Int
BS.length ByteString
sig)
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" bytes "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a. Out a => a -> Text
inspect ByteString
sig
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" and pub key "
              Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a. Out a => a -> Text
inspect ByteString
pub
          Bool -> m Bool
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False