module Network.Haskoin.Crypto.ECDSA
( SecretT
, Signature(..)
, withSource
, devURandom
, devRandom
, signMsg
, detSignMsg
, unsafeSignMsg
, verifySig
, genPrvKey
, isCanonicalHalfOrder
) where
import System.IO
import Control.Monad (liftM, guard, unless)
import Control.Monad.Trans (MonadTrans, lift)
import Control.Applicative (Applicative, (<*>), (<$>))
import qualified Control.Monad.State as S
( StateT
, evalStateT
, get, put
)
import Data.Maybe (fromJust, fromMaybe)
import Data.Binary (Binary, get, put)
import Data.Binary.Put (putWord8, putByteString)
import Data.Binary.Get (getWord8)
import qualified Data.ByteString as BS
( ByteString
, length
, hGet
, empty
)
import Network.Haskoin.Util
import Network.Haskoin.Crypto.Hash
import Network.Haskoin.Crypto.Keys
import Network.Haskoin.Crypto.Point
import Network.Haskoin.Crypto.BigWord
type SecretState m = (WorkingState, (Int -> m BS.ByteString))
type SecretT m a = S.StateT (SecretState m) m a
withSource :: Monad m => (Int -> m BS.ByteString) -> SecretT m a -> m a
withSource f m = do
seed <- f 32
nonce <- f 16
let ws = hmacDRBGNew seed nonce (stringToBS haskoinUserAgent)
S.evalStateT m (ws,f)
devURandom :: Int -> IO BS.ByteString
devURandom i = withBinaryFile "/dev/urandom" ReadMode $ flip BS.hGet i
devRandom :: Int -> IO BS.ByteString
devRandom i = withBinaryFile "/dev/random" ReadMode $ flip BS.hGet i
nextSecret :: Monad m => SecretT m FieldN
nextSecret = do
(ws,f) <- S.get
let (ws',randM) = hmacDRBGGen ws 32 (stringToBS haskoinUserAgent)
case randM of
(Just rand) -> do
S.put (ws',f)
let randI = bsToInteger rand
if isIntegerValidKey randI
then return $ fromInteger randI
else nextSecret
Nothing -> do
seed <- lift $ f 32
let ws0 = hmacDRBGRsd ws' seed (stringToBS haskoinUserAgent)
S.put (ws0,f)
nextSecret
genPrvKey :: Monad m => SecretT m PrvKey
genPrvKey = liftM (fromJust . makePrvKey . toInteger) nextSecret
genKeyPair :: Monad m => SecretT m (FieldN, Point)
genKeyPair = do
d <- nextSecret
let q = mulPoint d curveG
return (d,q)
data Signature =
Signature { sigR :: !FieldN
, sigS :: !FieldN
}
deriving (Show, Eq)
signMsg :: Monad m => Hash256 -> PrvKey -> SecretT m Signature
signMsg _ (PrvKey 0) = error "signMsg: Invalid private key 0"
signMsg _ (PrvKeyU 0) = error "signMsg: Invalid private key 0"
signMsg h d = do
(k,p) <- genKeyPair
case unsafeSignMsg h (prvKeyFieldN d) (k,p) of
(Just sig) -> return sig
Nothing -> signMsg h d
detSignMsg :: Hash256 -> PrvKey -> Signature
detSignMsg _ (PrvKey 0) = error "detSignMsg: Invalid private key 0"
detSignMsg _ (PrvKeyU 0) = error "detSignMsg: Invalid private key 0"
detSignMsg h d = go $ hmacDRBGNew (runPut' $ putPrvKey d) (encode' h) BS.empty
where
go ws = case hmacDRBGGen ws 32 BS.empty of
(_, Nothing) -> error "detSignMsg: No suitable K value found"
(ws', Just k) ->
let kI = bsToInteger k
p = mulPoint (fromInteger kI) curveG
sigM = unsafeSignMsg h (prvKeyFieldN d) (fromInteger kI,p)
in if isIntegerValidKey kI
then fromMaybe (go ws') sigM
else go ws'
unsafeSignMsg :: Hash256 -> FieldN -> (FieldN, Point) -> Maybe Signature
unsafeSignMsg _ 0 _ = Nothing
unsafeSignMsg h d (k,p) = do
(x,_) <- getAffine p
let r = toFieldN x
guard (r /= 0)
let e = toFieldN h
let s' = (e + r*d)/k
s = if s' > (maxBound `div` 2) then (s') else s'
guard (s /= 0)
return $ Signature r s
verifySig :: Hash256 -> Signature -> PubKey -> Bool
verifySig _ (Signature 0 _) _ = False
verifySig _ (Signature _ 0) _ = False
verifySig h (Signature r s) q = case getAffine p of
Nothing -> False
(Just (x,_)) -> (toFieldN x) == r
where
e = toFieldN h
s' = inverseN s
u1 = e*s'
u2 = r*s'
p = shamirsTrick u1 curveG u2 (pubKeyPoint q)
isCanonicalHalfOrder :: Signature -> Bool
isCanonicalHalfOrder (Signature _ s) = s <= maxBound `div` 2
instance Binary Signature where
get = do
t <- getWord8
unless (t == 0x30) (fail $
"Bad DER identifier byte " ++ (show t) ++ ". Expecting 0x30")
l <- getWord8
unless (l <= 70) (fail $
"Bad DER length " ++ (show t) ++ ". Expecting length <= 70")
isolate (fromIntegral l) $ do
Signature <$> get <*> get
put (Signature 0 _) = error "0 is an invalid r value in a Signature"
put (Signature _ 0) = error "0 is an invalid s value in a Signature"
put (Signature r s) = do
putWord8 0x30
let c = runPut' $ put r >> put s
putWord8 (fromIntegral $ BS.length c)
putByteString c