{-# LANGUAGE OverloadedStrings #-}
module Haskoin.Crypto.Signature (
putSig,
getSig,
signHash,
verifyHashSig,
isCanonicalHalfOrder,
decodeStrictSig,
exportSig,
) where
import Control.Monad (guard, unless, when)
import Crypto.Secp256k1
import Data.Binary (Binary (..))
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Bytes.Get
import Data.Bytes.Put
import Data.Bytes.Serial
import Data.Maybe (fromMaybe, isNothing)
import Data.Serialize (Serialize (..))
import Haskoin.Crypto.Hash
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 ()
serialize
where
e :: a
e = [Char] -> a
forall a. HasCallStack => [Char] -> a
error [Char]
"Could not convert 32-byte hash to secp256k1 message"
signHash :: SecKey -> Hash256 -> Sig
signHash :: SecKey -> Hash256 -> Sig
signHash SecKey
k = SecKey -> Msg -> Sig
signMsg SecKey
k (Msg -> Sig) -> (Hash256 -> Msg) -> Hash256 -> Sig
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hash256 -> Msg
hashToMsg
verifyHashSig :: Hash256 -> Sig -> PubKey -> Bool
verifyHashSig :: Hash256 -> Sig -> PubKey -> Bool
verifyHashSig Hash256
h Sig
s PubKey
p = PubKey -> Sig -> Msg -> Bool
verifySig 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 (Sig -> Maybe Sig
normalizeSig Sig
s)
getSig :: MonadGet m => m Sig
getSig :: m Sig
getSig = do
Int
l <-
m Int -> m Int
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 (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, Show 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 (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 (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Multi-octect length not supported"
Int -> m Int
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 ByteString -> Maybe Sig
decodeStrictSig ByteString
bs of
Just Sig
s -> Sig -> m Sig
forall (m :: * -> *) a. Monad m => a -> m a
return Sig
s
Maybe Sig
Nothing -> [Char] -> m Sig
forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Invalid signature"
putSig :: MonadPut m => Sig -> m ()
putSig :: Sig -> m ()
putSig Sig
s = ByteString -> m ()
forall (m :: * -> *). MonadPut m => ByteString -> m ()
putByteString (ByteString -> m ()) -> ByteString -> m ()
forall a b. (a -> b) -> a -> b
$ Sig -> ByteString
exportSig Sig
s
isCanonicalHalfOrder :: Sig -> Bool
isCanonicalHalfOrder :: Sig -> Bool
isCanonicalHalfOrder = 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
. Sig -> Maybe Sig
normalizeSig
decodeStrictSig :: ByteString -> Maybe Sig
decodeStrictSig :: ByteString -> Maybe Sig
decodeStrictSig ByteString
bs = do
Sig
g <- ByteString -> Maybe Sig
importSig ByteString
bs
let compact :: CompactSig
compact = Sig -> CompactSig
exportCompactSig Sig
g
let zero :: ByteString
zero = Int -> Word8 -> ByteString
BS.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
BS.take Int
32 (CompactSig -> ByteString
getCompactSig CompactSig
compact) 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
BS.take Int
32 (Int -> ByteString -> ByteString
BS.drop Int
32 (CompactSig -> ByteString
getCompactSig CompactSig
compact)) 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
$ Sig -> Bool
isCanonicalHalfOrder Sig
g
Sig -> Maybe Sig
forall (m :: * -> *) a. Monad m => a -> m a
return Sig
g