{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}
module Haskoin.Crypto.Signature
(
signHash,
verifyHashSig,
isCanonicalHalfOrder,
decodeStrictSig,
exportSig,
)
where
import Control.Monad (guard, unless, when)
import Crypto.Secp256k1
import Data.Aeson
import Data.Aeson.Encoding
import Data.Binary (Binary (..))
import Data.ByteString (ByteString)
import Data.ByteString qualified as B
import Data.ByteString.Lazy qualified as L
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Maybe (fromMaybe, isNothing)
import Data.Serialize (Serialize (..))
import Data.Text qualified as T
import Haskoin.Crypto.Hash
import Haskoin.Util.Helpers
import Haskoin.Util.Marshal
import Numeric (showHex)
hashToMsg :: Hash256 -> Msg
hashToMsg :: Hash256 -> Msg
hashToMsg =
Msg -> Maybe Msg -> Msg
forall a. a -> Maybe a -> a
fromMaybe Msg
forall {a}. a
e (Maybe Msg -> Msg) -> (Hash256 -> Maybe Msg) -> Hash256 -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Maybe Msg
msg (ByteString -> Maybe Msg)
-> (Hash256 -> ByteString) -> Hash256 -> Maybe Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Put -> ByteString
runPutS (Put -> ByteString) -> (Hash256 -> Put) -> Hash256 -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash256 -> Put
forall a (m :: * -> *). (Serial a, MonadPut m) => a -> m ()
forall (m :: * -> *). MonadPut m => Hash256 -> m ()
serialize
where
e :: a
e = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Could not convert 32-byte hash to secp256k1 message"
signHash :: Ctx -> SecKey -> Hash256 -> Sig
signHash :: Ctx -> SecKey -> Hash256 -> Sig
signHash Ctx
ctx SecKey
k = Ctx -> SecKey -> Msg -> Sig
signMsg Ctx
ctx SecKey
k (Msg -> Sig) -> (Hash256 -> Msg) -> Hash256 -> Sig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash256 -> Msg
hashToMsg
verifyHashSig :: Ctx -> Hash256 -> Sig -> PubKey -> Bool
verifyHashSig :: Ctx -> Hash256 -> Sig -> PubKey -> Bool
verifyHashSig Ctx
ctx Hash256
h Sig
s PubKey
p = Ctx -> PubKey -> Sig -> Msg -> Bool
verifySig Ctx
ctx PubKey
p Sig
norm (Hash256 -> Msg
hashToMsg Hash256
h)
where
norm :: Sig
norm = Sig -> Maybe Sig -> Sig
forall a. a -> Maybe a -> a
fromMaybe Sig
s (Ctx -> Sig -> Maybe Sig
normalizeSig Ctx
ctx Sig
s)
instance Marshal Ctx Sig where
marshalGet :: forall (m :: * -> *). MonadGet m => Ctx -> m Sig
marshalGet Ctx
ctx = do
Int
l <- m Int -> m Int
forall a. m a -> m a
forall (m :: * -> *) a. MonadGet m => m a -> m a
lookAhead (m Int -> m Int) -> m Int -> m Int
forall a b. (a -> b) -> a -> b
$ do
Word8
t <- m Word8
forall (m :: * -> *). MonadGet m => m Word8
getWord8
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Word8
t Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x30) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
[Char] -> m ()
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$
[Char]
"Bad DER identifier byte 0x" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Word8 -> [Char] -> [Char]
forall a. Integral a => a -> [Char] -> [Char]
showHex Word8
t [Char]
". Expecting 0x30"
Word8
l <- m Word8
forall (m :: * -> *). MonadGet m => m Word8
getWord8
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
l Word8 -> Word8 -> Bool
forall a. Eq a => a -> a -> Bool
== Word8
0x00) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> m ()
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Indeterminate form unsupported"
Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word8
l Word8 -> Word8 -> Bool
forall a. Ord a => a -> a -> Bool
>= Word8
0x80) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ [Char] -> m ()
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Multi-octect length not supported"
Int -> m Int
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Int -> m Int) -> Int -> m Int
forall a b. (a -> b) -> a -> b
$ Word8 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word8
l
ByteString
bs <- Int -> m ByteString
forall (m :: * -> *). MonadGet m => Int -> m ByteString
getByteString (Int -> m ByteString) -> Int -> m ByteString
forall a b. (a -> b) -> a -> b
$ Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
2
case Ctx -> ByteString -> Maybe Sig
decodeStrictSig Ctx
ctx ByteString
bs of
Just Sig
s -> Sig -> m Sig
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Sig
s
Maybe Sig
Nothing -> [Char] -> m Sig
forall a. [Char] -> m a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Invalid signature"
marshalPut :: forall (m :: * -> *). MonadPut m => Ctx -> Sig -> m ()
marshalPut Ctx
ctx Sig
s = ByteString -> m ()
forall (m :: * -> *). MonadPut m => ByteString -> m ()
putByteString (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ Ctx -> Sig -> ByteString
exportSig Ctx
ctx Sig
s
instance MarshalJSON Ctx Sig where
marshalValue :: Ctx -> Sig -> Value
marshalValue Ctx
ctx = Text -> Value
String (Text -> Value) -> (Sig -> Text) -> Sig -> Value
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
encodeHex (ByteString -> Text) -> (Sig -> ByteString) -> Sig -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> Sig -> ByteString
exportSig Ctx
ctx
marshalEncoding :: Ctx -> Sig -> Encoding
marshalEncoding Ctx
ctx = ByteString -> Encoding
hexEncoding (ByteString -> Encoding) -> (Sig -> ByteString) -> Sig -> Encoding
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> ByteString
L.fromStrict (ByteString -> ByteString)
-> (Sig -> ByteString) -> Sig -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> Sig -> ByteString
exportSig Ctx
ctx
unmarshalValue :: Ctx -> Value -> Parser Sig
unmarshalValue Ctx
ctx =
[Char] -> (Text -> Parser Sig) -> Value -> Parser Sig
forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"Sig" ((Text -> Parser Sig) -> Value -> Parser Sig)
-> (Text -> Parser Sig) -> Value -> Parser Sig
forall a b. (a -> b) -> a -> b
$ \Text
t ->
case Text -> Maybe ByteString
decodeHex Text
t Maybe ByteString -> (ByteString -> Maybe Sig) -> Maybe Sig
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Ctx -> ByteString -> Maybe Sig
importSig Ctx
ctx of
Maybe Sig
Nothing -> [Char] -> Parser Sig
forall a. [Char] -> Parser a
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char] -> Parser Sig) -> [Char] -> Parser Sig
forall a b. (a -> b) -> a -> b
$ [Char]
"Could not decode signature: " [Char] -> [Char] -> [Char]
forall a. Semigroup a => a -> a -> a
<> Text -> [Char]
T.unpack Text
t
Just Sig
s -> Sig -> Parser Sig
forall a. a -> Parser a
forall (m :: * -> *) a. Monad m => a -> m a
return Sig
s
isCanonicalHalfOrder :: Ctx -> Sig -> Bool
isCanonicalHalfOrder :: Ctx -> Sig -> Bool
isCanonicalHalfOrder Ctx
ctx = Maybe Sig -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe Sig -> Bool) -> (Sig -> Maybe Sig) -> Sig -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Ctx -> Sig -> Maybe Sig
normalizeSig Ctx
ctx
decodeStrictSig :: Ctx -> ByteString -> Maybe Sig
decodeStrictSig :: Ctx -> ByteString -> Maybe Sig
decodeStrictSig Ctx
ctx ByteString
bs = do
Sig
g <- Ctx -> ByteString -> Maybe Sig
importSig Ctx
ctx ByteString
bs
let compact :: CompactSig
compact = Ctx -> Sig -> CompactSig
exportCompactSig Ctx
ctx Sig
g
let zero :: ByteString
zero = Int -> Word8 -> ByteString
B.replicate Int
32 Word8
0
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> ByteString
B.take Int
32 CompactSig
compact.get ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
zero
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ (Int -> ByteString -> ByteString
B.take Int
32 (ByteString -> ByteString)
-> (ByteString -> ByteString) -> ByteString -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> ByteString -> ByteString
B.drop Int
32) CompactSig
compact.get ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
zero
Bool -> Maybe ()
forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Bool -> Maybe ()) -> Bool -> Maybe ()
forall a b. (a -> b) -> a -> b
$ Ctx -> Sig -> Bool
isCanonicalHalfOrder Ctx
ctx Sig
g
Sig -> Maybe Sig
forall a. a -> Maybe a
forall (m :: * -> *) a. Monad m => a -> m a
return Sig
g