{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE ImportQualifiedPost #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedRecordDot #-}
{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : Haskoin.Crypto.Signature
-- Copyright   : No rights reserved
-- License     : MIT
-- Maintainer  : jprupp@protonmail.ch
-- Stability   : experimental
-- Portability : POSIX
--
-- ECDSA signatures using secp256k1 curve. Uses functions from upstream secp256k1
-- library.
module Haskoin.Crypto.Signature
  ( -- * Signatures
    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)

-- | Convert 256-bit hash into a 'Msg' for signing or verification.
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"

-- | Sign a 256-bit hash using secp256k1 elliptic curve.
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

-- | Verify an ECDSA signature for a 256-bit hash.
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
      -- 0x30 is DER sequence type
      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

-- | Is canonical half order.
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

-- | Decode signature strictly.
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
  -- <http://www.secg.org/sec1-v2.pdf Section 4.1.4>
  -- 4.1.4.1 (r and s can not be zero)
  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