module Network.Haskoin.Crypto.Keys
( PubKey(..)
, isValidPubKey
, isPubKeyU
, derivePubKey
, pubKeyAddr
, addPubKeys
, PrvKey(..)
, isValidPrvKey
, makePrvKey
, makePrvKeyU
, fromPrvKey
, isPrvKeyU
, addPrvKeys
, putPrvKey
, getPrvKey
, getPrvKeyU
, fromWIF
, toWIF
, curveG
) where
import Data.Binary (Binary, get, put)
import Data.Binary.Get (Get, getWord8)
import Data.Binary.Put (Put, putWord8)
import Control.Monad (when, unless, guard)
import Control.Applicative ((<$>),(<*>))
import Data.Maybe (isJust, fromJust)
import qualified Data.ByteString as BS
( head, tail
, last, init
, cons, snoc
, length
)
import Network.Haskoin.Crypto.Curve (pairG, curveN)
import Network.Haskoin.Crypto.Ring
( FieldN, FieldP
, isIntegerValidKey
, quadraticResidue
, toMod256
, toFieldN
)
import Network.Haskoin.Crypto.Point
( Point( InfPoint )
, makePoint
, mulPoint
, addPoint
, getAffine
, validatePoint
, isInfPoint
, curveA, curveB
)
import Network.Haskoin.Crypto.Base58
( Address(..)
, encodeBase58Check
, decodeBase58Check
)
import Network.Haskoin.Crypto.Hash
( Hash256
, hash160
, hash256BS
)
import Network.Haskoin.Util
( runPut'
, bsToInteger
, encode'
, stringToBS
, bsToString
)
import Network.Haskoin.Util.Network
curveG :: Point
curveG = fromJust $ makePoint (fromInteger $ fst pairG)
(fromInteger $ snd pairG)
data PubKey
= PubKey { pubKeyPoint :: !Point }
| PubKeyU { pubKeyPoint :: !Point }
deriving Show
instance Eq PubKey where
(PubKey InfPoint) == (PubKeyU InfPoint) = True
(PubKeyU InfPoint) == (PubKey InfPoint) = True
(PubKey a) == (PubKey b) = a == b
(PubKeyU a) == (PubKeyU b) = a == b
_ == _ = False
isValidPubKey :: PubKey -> Bool
isValidPubKey = validatePoint . pubKeyPoint
addPubKeys :: PubKey -> Hash256 -> Maybe PubKey
addPubKeys pub i
| isPubKeyU pub = error "Add: HDW only supports compressed formats"
| toInteger i < curveN =
let pt1 = mulPoint (toFieldN i) curveG
pt2 = addPoint (pubKeyPoint pub) pt1
in if isInfPoint pt2 then Nothing
else Just $ PubKey pt2
| otherwise = Nothing
isPubKeyU :: PubKey -> Bool
isPubKeyU (PubKey _) = False
isPubKeyU (PubKeyU _) = True
derivePubKey :: PrvKey -> PubKey
derivePubKey k = case k of
(PrvKey d) -> PubKey $ mulPoint d curveG
(PrvKeyU d) -> PubKeyU $ mulPoint d curveG
instance Binary PubKey where
get = go =<< getWord8
where
go 0 = fail "InfPoint is not a valid public key"
go 4 = getUncompressed
go y | y == 2 || y == 3 = getCompressed (even y)
| otherwise = fail "Get: Invalid public key encoding"
put pk = case getAffine (pubKeyPoint pk) of
Nothing -> putWord8 0x00
Just (x,y) -> case pk of
PubKey _ -> putWord8 (if even y then 2 else 3) >> put x
PubKeyU _ -> putWord8 4 >> put x >> put y
getUncompressed :: Get PubKey
getUncompressed = do
p <- makePoint <$> get <*> get
unless (isJust p) (fail "Get: Point not on the curve")
return $ PubKeyU $ fromJust $ p
getCompressed :: Bool -> Get PubKey
getCompressed e = do
x <- get :: Get FieldP
let a = x ^ (3 :: Integer) + (curveA * x) + curveB
ys = filter matchSign (quadraticResidue a)
when (null ys) (fail $ "No ECC point for x = " ++ (show x))
let p = makePoint x (head ys)
unless (isJust p) (fail "Get: Point not on the curve")
return $ PubKey $ fromJust $ p
where
matchSign a = (even a) == e
pubKeyAddr :: PubKey -> Address
pubKeyAddr = PubKeyAddress . hash160 . hash256BS . encode'
data PrvKey
= PrvKey { prvKeyFieldN :: !FieldN }
| PrvKeyU { prvKeyFieldN :: !FieldN }
deriving (Eq, Show)
isValidPrvKey :: Integer -> Bool
isValidPrvKey = isIntegerValidKey
makePrvKey :: Integer -> Maybe PrvKey
makePrvKey i
| isValidPrvKey i = Just $ PrvKey $ fromInteger i
| otherwise = Nothing
makePrvKeyU :: Integer -> Maybe PrvKey
makePrvKeyU i
| isValidPrvKey i = Just $ PrvKeyU $ fromInteger i
| otherwise = Nothing
fromPrvKey :: PrvKey -> Integer
fromPrvKey = fromIntegral . prvKeyFieldN
addPrvKeys :: PrvKey -> Hash256 -> Maybe PrvKey
addPrvKeys key i
| isPrvKeyU key = error "Add: HDW only supports compressed formats"
| toInteger i < curveN =
let r = (prvKeyFieldN key) + (toFieldN i)
in makePrvKey $ toInteger r
| otherwise = Nothing
isPrvKeyU :: PrvKey -> Bool
isPrvKeyU (PrvKey _) = False
isPrvKeyU (PrvKeyU _) = True
putPrvKey :: PrvKey -> Put
putPrvKey k | prvKeyFieldN k == 0 = error "Put: 0 is an invalid private key"
| otherwise = put $ toMod256 $ prvKeyFieldN k
getPrvKey :: Get PrvKey
getPrvKey = do
i <- get :: Get Hash256
let res = makePrvKey $ fromIntegral i
unless (isJust res) $ fail "Get: PrivateKey is invalid"
return $ fromJust res
getPrvKeyU :: Get PrvKey
getPrvKeyU = do
i <- get :: Get Hash256
let res = makePrvKeyU $ fromIntegral i
unless (isJust res) $ fail "Get: PrivateKey is invalid"
return $ fromJust res
fromWIF :: String -> Maybe PrvKey
fromWIF str = do
bs <- decodeBase58Check $ stringToBS str
guard (BS.head bs == secretPrefix)
case BS.length bs of
33 -> do
let i = bsToInteger (BS.tail bs)
makePrvKeyU i
34 -> do
guard (BS.last bs == 0x01)
let i = bsToInteger $ BS.tail $ BS.init bs
makePrvKey i
_ -> Nothing
toWIF :: PrvKey -> String
toWIF k = bsToString $ encodeBase58Check $ BS.cons secretPrefix enc
where
enc | isPrvKeyU k = bs
| otherwise = BS.snoc bs 0x01
bs = runPut' $ putPrvKey k