module BtcLsp.Grpc.Sig
  ( MsgToSign (..),
    LndSig (..),
    sigToVerify,
    msgToVerify,
  )
where

import BtcLsp.Data.Type
import BtcLsp.Grpc.Data
import BtcLsp.Import.External
import qualified Crypto.Hash as CH
import qualified Crypto.Secp256k1 as C
import qualified Data.ByteArray as BA
import qualified Data.ByteString as BS
import qualified Data.ByteString.Base64 as B64
import qualified Data.CaseInsensitive as CI
import Network.Wai.Internal (Request (..))

newtype MsgToSign = MsgToSign
  { MsgToSign -> ByteString
unMsgToSign :: ByteString
  }
  deriving newtype
    ( MsgToSign -> MsgToSign -> Bool
(MsgToSign -> MsgToSign -> Bool)
-> (MsgToSign -> MsgToSign -> Bool) -> Eq MsgToSign
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MsgToSign -> MsgToSign -> Bool
$c/= :: MsgToSign -> MsgToSign -> Bool
== :: MsgToSign -> MsgToSign -> Bool
$c== :: MsgToSign -> MsgToSign -> Bool
Eq,
      Eq MsgToSign
Eq MsgToSign
-> (MsgToSign -> MsgToSign -> Ordering)
-> (MsgToSign -> MsgToSign -> Bool)
-> (MsgToSign -> MsgToSign -> Bool)
-> (MsgToSign -> MsgToSign -> Bool)
-> (MsgToSign -> MsgToSign -> Bool)
-> (MsgToSign -> MsgToSign -> MsgToSign)
-> (MsgToSign -> MsgToSign -> MsgToSign)
-> Ord MsgToSign
MsgToSign -> MsgToSign -> Bool
MsgToSign -> MsgToSign -> Ordering
MsgToSign -> MsgToSign -> MsgToSign
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MsgToSign -> MsgToSign -> MsgToSign
$cmin :: MsgToSign -> MsgToSign -> MsgToSign
max :: MsgToSign -> MsgToSign -> MsgToSign
$cmax :: MsgToSign -> MsgToSign -> MsgToSign
>= :: MsgToSign -> MsgToSign -> Bool
$c>= :: MsgToSign -> MsgToSign -> Bool
> :: MsgToSign -> MsgToSign -> Bool
$c> :: MsgToSign -> MsgToSign -> Bool
<= :: MsgToSign -> MsgToSign -> Bool
$c<= :: MsgToSign -> MsgToSign -> Bool
< :: MsgToSign -> MsgToSign -> Bool
$c< :: MsgToSign -> MsgToSign -> Bool
compare :: MsgToSign -> MsgToSign -> Ordering
$ccompare :: MsgToSign -> MsgToSign -> Ordering
Ord,
      Int -> MsgToSign -> ShowS
[MsgToSign] -> ShowS
MsgToSign -> String
(Int -> MsgToSign -> ShowS)
-> (MsgToSign -> String)
-> ([MsgToSign] -> ShowS)
-> Show MsgToSign
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MsgToSign] -> ShowS
$cshowList :: [MsgToSign] -> ShowS
show :: MsgToSign -> String
$cshow :: MsgToSign -> String
showsPrec :: Int -> MsgToSign -> ShowS
$cshowsPrec :: Int -> MsgToSign -> ShowS
Show,
      MsgToSign -> ()
(MsgToSign -> ()) -> NFData MsgToSign
forall a. (a -> ()) -> NFData a
rnf :: MsgToSign -> ()
$crnf :: MsgToSign -> ()
NFData
    )
  deriving stock
    ( (forall x. MsgToSign -> Rep MsgToSign x)
-> (forall x. Rep MsgToSign x -> MsgToSign) -> Generic MsgToSign
forall x. Rep MsgToSign x -> MsgToSign
forall x. MsgToSign -> Rep MsgToSign x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep MsgToSign x -> MsgToSign
$cfrom :: forall x. MsgToSign -> Rep MsgToSign x
Generic
    )

instance Out MsgToSign

newtype LndSig = LndSig
  { LndSig -> ByteString
unLndSig :: ByteString
  }
  deriving newtype
    ( LndSig -> LndSig -> Bool
(LndSig -> LndSig -> Bool)
-> (LndSig -> LndSig -> Bool) -> Eq LndSig
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LndSig -> LndSig -> Bool
$c/= :: LndSig -> LndSig -> Bool
== :: LndSig -> LndSig -> Bool
$c== :: LndSig -> LndSig -> Bool
Eq,
      Eq LndSig
Eq LndSig
-> (LndSig -> LndSig -> Ordering)
-> (LndSig -> LndSig -> Bool)
-> (LndSig -> LndSig -> Bool)
-> (LndSig -> LndSig -> Bool)
-> (LndSig -> LndSig -> Bool)
-> (LndSig -> LndSig -> LndSig)
-> (LndSig -> LndSig -> LndSig)
-> Ord LndSig
LndSig -> LndSig -> Bool
LndSig -> LndSig -> Ordering
LndSig -> LndSig -> LndSig
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LndSig -> LndSig -> LndSig
$cmin :: LndSig -> LndSig -> LndSig
max :: LndSig -> LndSig -> LndSig
$cmax :: LndSig -> LndSig -> LndSig
>= :: LndSig -> LndSig -> Bool
$c>= :: LndSig -> LndSig -> Bool
> :: LndSig -> LndSig -> Bool
$c> :: LndSig -> LndSig -> Bool
<= :: LndSig -> LndSig -> Bool
$c<= :: LndSig -> LndSig -> Bool
< :: LndSig -> LndSig -> Bool
$c< :: LndSig -> LndSig -> Bool
compare :: LndSig -> LndSig -> Ordering
$ccompare :: LndSig -> LndSig -> Ordering
Ord,
      Int -> LndSig -> ShowS
[LndSig] -> ShowS
LndSig -> String
(Int -> LndSig -> ShowS)
-> (LndSig -> String) -> ([LndSig] -> ShowS) -> Show LndSig
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LndSig] -> ShowS
$cshowList :: [LndSig] -> ShowS
show :: LndSig -> String
$cshow :: LndSig -> String
showsPrec :: Int -> LndSig -> ShowS
$cshowsPrec :: Int -> LndSig -> ShowS
Show,
      LndSig -> ()
(LndSig -> ()) -> NFData LndSig
forall a. (a -> ()) -> NFData a
rnf :: LndSig -> ()
$crnf :: LndSig -> ()
NFData
    )
  deriving stock
    ( (forall x. LndSig -> Rep LndSig x)
-> (forall x. Rep LndSig x -> LndSig) -> Generic LndSig
forall x. Rep LndSig x -> LndSig
forall x. LndSig -> Rep LndSig x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LndSig x -> LndSig
$cfrom :: forall x. LndSig -> Rep LndSig x
Generic
    )

instance Out LndSig

sigToVerify :: SigHeaderName -> Request -> Either Failure C.Sig
sigToVerify :: SigHeaderName -> Request -> Either Failure Sig
sigToVerify SigHeaderName
sigHeaderName Request
waiReq = do
  (CI ByteString
_, ByteString
b64sig) <-
    Failure
-> Maybe (CI ByteString, ByteString)
-> Either Failure (CI ByteString, ByteString)
forall l r. l -> Maybe r -> Either l r
maybeToRight
      ( FailureInternal -> Failure
FailureInt (FailureInternal -> Failure)
-> (Text -> FailureInternal) -> Text -> Failure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FailureInternal
FailureGrpcServer (Text -> Failure) -> Text -> Failure
forall a b. (a -> b) -> a -> b
$
          Text
"Missing "
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sigHeaderNameText
            Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" header"
      )
      (Maybe (CI ByteString, ByteString)
 -> Either Failure (CI ByteString, ByteString))
-> (RequestHeaders -> Maybe (CI ByteString, ByteString))
-> RequestHeaders
-> Either Failure (CI ByteString, ByteString)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Element RequestHeaders -> Bool)
-> RequestHeaders -> Maybe (Element RequestHeaders)
forall t.
Container t =>
(Element t -> Bool) -> t -> Maybe (Element t)
find (\Element RequestHeaders
x -> (CI ByteString, ByteString) -> CI ByteString
forall a b. (a, b) -> a
fst (CI ByteString, ByteString)
Element RequestHeaders
x CI ByteString -> CI ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== CI ByteString
sigHeaderNameCI)
      (RequestHeaders -> Either Failure (CI ByteString, ByteString))
-> RequestHeaders -> Either Failure (CI ByteString, ByteString)
forall a b. (a -> b) -> a -> b
$ Request -> RequestHeaders
requestHeaders Request
waiReq
  let sigDer :: ByteString
sigDer =
        ByteString -> ByteString
B64.decodeLenient ByteString
b64sig
  Failure -> Maybe Sig -> Either Failure Sig
forall l r. l -> Maybe r -> Either l r
maybeToRight
    ( FailureInternal -> Failure
FailureInt (FailureInternal -> Failure)
-> (Text -> FailureInternal) -> Text -> Failure
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> FailureInternal
FailureGrpcServer (Text -> Failure) -> Text -> Failure
forall a b. (a -> b) -> a -> b
$
        Text
"Signature "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
sigHeaderNameText
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" import from der payload "
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> ByteString -> Text
forall a. Out a => a -> Text
inspectPlain ByteString
sigDer
          Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" failed"
    )
    (Maybe Sig -> Either Failure Sig)
-> Maybe Sig -> Either Failure Sig
forall a b. (a -> b) -> a -> b
$ ByteString -> Maybe Sig
C.importSig ByteString
sigDer
  where
    sigHeaderNameText :: Text
sigHeaderNameText =
      SigHeaderName -> Text
forall source target.
(From source target, 'False ~ (source == target)) =>
source -> target
from SigHeaderName
sigHeaderName
    sigHeaderNameBS :: ByteString
sigHeaderNameBS =
      SigHeaderName -> ByteString
forall source target.
(From source target, 'False ~ (source == target)) =>
source -> target
from SigHeaderName
sigHeaderName
    sigHeaderNameCI :: CI ByteString
sigHeaderNameCI =
      ByteString -> CI ByteString
forall s. FoldCase s => s -> CI s
CI.mk ByteString
sigHeaderNameBS

msgToVerify :: ByteString -> Maybe C.Msg
msgToVerify :: ByteString -> Maybe Msg
msgToVerify =
  ByteString -> Maybe Msg
C.msg
    (ByteString -> Maybe Msg)
-> (ByteString -> ByteString) -> ByteString -> Maybe Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Word8] -> ByteString
BS.pack
    ([Word8] -> ByteString)
-> (ByteString -> [Word8]) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Digest SHA256 -> [Word8]
forall a. ByteArrayAccess a => a -> [Word8]
BA.unpack
    (Digest SHA256 -> [Word8])
-> (ByteString -> Digest SHA256) -> ByteString -> [Word8]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Digest SHA256
hash256
  where
    hash256 :: ByteString -> CH.Digest CH.SHA256
    hash256 :: ByteString -> Digest SHA256
hash256 = ByteString -> Digest SHA256
forall ba a.
(ByteArrayAccess ba, HashAlgorithm a) =>
ba -> Digest a
CH.hash