module Network.Haskoin.Crypto.Hash
( CheckSum32
, hash512
, hash256
, hashSha1
, hash160
, hash512BS
, hash256BS
, hashSha1BS
, hash160BS
, doubleHash256
, doubleHash256BS
, chksum32
, hmac512
, hmac512BS
, hmac256
, hmac256BS
, hmacDRBGNew
, hmacDRBGUpd
, hmacDRBGRsd
, hmacDRBGGen
, WorkingState
, murmurHash3
, split512
, join512
, decodeCompact
, encodeCompact
, txHash
, cbHash
, headerHash
) where
import Control.Monad (replicateM)
import Crypto.Hash
( Digest
, SHA512
, SHA256
, SHA1
, RIPEMD160
, hash
)
import Crypto.MAC.HMAC (hmac)
import Data.Word (Word16, Word32)
import Data.Byteable (toBytes)
import Data.Binary (Binary, get)
import Data.Binary.Get (getWord32le)
import Data.Bits
( shiftL
, shiftR
, rotateL
, xor
, (.&.), (.|.)
)
import qualified Data.ByteString as BS
( ByteString
, null
, append
, cons
, concat
, take
, empty
, length
, replicate
, drop
)
import Network.Haskoin.Util
import Network.Haskoin.Crypto.BigWord
import Network.Haskoin.Protocol.Types
type CheckSum32 = Word32
run512 :: BS.ByteString -> BS.ByteString
run512 = (toBytes :: Digest SHA512 -> BS.ByteString) . hash
run256 :: BS.ByteString -> BS.ByteString
run256 = (toBytes :: Digest SHA256 -> BS.ByteString) . hash
run160 :: BS.ByteString -> BS.ByteString
run160 = (toBytes :: Digest RIPEMD160 -> BS.ByteString) . hash
runSha1 :: BS.ByteString -> BS.ByteString
runSha1 = (toBytes :: Digest SHA1 -> BS.ByteString) . hash
hash512 :: BS.ByteString -> Word512
hash512 bs = runGet' get (run512 bs)
hash512BS :: BS.ByteString -> BS.ByteString
hash512BS bs = run512 bs
hash256 :: BS.ByteString -> Word256
hash256 bs = runGet' get (run256 bs)
hash256BS :: BS.ByteString -> BS.ByteString
hash256BS bs = run256 bs
hashSha1 :: BS.ByteString -> Word160
hashSha1 bs = runGet' get (runSha1 bs)
hashSha1BS :: BS.ByteString -> BS.ByteString
hashSha1BS bs = runSha1 bs
hash160 :: BS.ByteString -> Word160
hash160 bs = runGet' get (run160 bs)
hash160BS :: BS.ByteString -> BS.ByteString
hash160BS bs = run160 bs
doubleHash256 :: BS.ByteString -> Word256
doubleHash256 bs = runGet' get (run256 $ run256 bs)
doubleHash256BS :: BS.ByteString -> BS.ByteString
doubleHash256BS bs = run256 $ run256 bs
chksum32 :: BS.ByteString -> CheckSum32
chksum32 bs = fromIntegral $ (doubleHash256 bs) `shiftR` 224
hmac512 :: BS.ByteString -> BS.ByteString -> Word512
hmac512 key = decode' . (hmac512BS key)
hmac512BS :: BS.ByteString -> BS.ByteString -> BS.ByteString
hmac512BS key msg = hmac hash512BS 128 key msg
hmac256 :: BS.ByteString -> BS.ByteString -> Word256
hmac256 key = decode' . (hmac256BS key)
hmac256BS :: BS.ByteString -> BS.ByteString -> BS.ByteString
hmac256BS key msg = hmac hash256BS 64 key msg
split512 :: Word512 -> (Word256, Word256)
split512 i = (fromIntegral $ i `shiftR` 256, fromIntegral i)
join512 :: (Word256, Word256) -> Word512
join512 (a,b) =
((fromIntegral a :: Word512) `shiftL` 256) + (fromIntegral b :: Word512)
decodeCompact :: Word32 -> Integer
decodeCompact c =
if neg then (res) else res
where
size = fromIntegral $ c `shiftR` 24
neg = (c .&. 0x00800000) /= 0
wrd = c .&. 0x007fffff
res | size <= 3 = (toInteger wrd) `shiftR` (8*(3 size))
| otherwise = (toInteger wrd) `shiftL` (8*(size 3))
encodeCompact :: Integer -> Word32
encodeCompact i
| i < 0 = c3 .|. 0x00800000
| otherwise = c3
where
posi = abs i
s1 = BS.length $ integerToBS posi
c1 | s1 < 3 = posi `shiftL` (8*(3 s1))
| otherwise = posi `shiftR` (8*(s1 3))
(s2,c2) | c1 .&. 0x00800000 /= 0 = (s1 + 1, c1 `shiftR` 8)
| otherwise = (s1, c1)
c3 = fromIntegral $ c2 .|. ((toInteger s2) `shiftL` 24)
txHash :: Tx -> TxHash
txHash = fromIntegral . doubleHash256 . encode'
cbHash :: CoinbaseTx -> TxHash
cbHash = fromIntegral . doubleHash256 . encode'
headerHash :: BlockHeader -> BlockHash
headerHash = fromIntegral . doubleHash256 . encode'
type WorkingState = (BS.ByteString, BS.ByteString, Word16)
type AdditionalInput = BS.ByteString
type ProvidedData = BS.ByteString
type EntropyInput = BS.ByteString
type Nonce = BS.ByteString
type PersString = BS.ByteString
hmacDRBGUpd :: ProvidedData -> BS.ByteString -> BS.ByteString
-> (BS.ByteString, BS.ByteString)
hmacDRBGUpd info k0 v0
| BS.null info = (k1,v1)
| otherwise = (k2,v2)
where
k1 = hmac256BS k0 $ v0 `BS.append` (0 `BS.cons` info)
v1 = hmac256BS k1 v0
k2 = hmac256BS k1 $ v1 `BS.append` (1 `BS.cons` info)
v2 = hmac256BS k2 v1
hmacDRBGNew :: EntropyInput -> Nonce -> PersString -> WorkingState
hmacDRBGNew seed nonce info
| (BS.length seed + BS.length nonce) * 8 < 384 = error $
"Entropy + nonce input length must be at least 384 bit"
| (BS.length seed + BS.length nonce) * 8 > 1000 = error $
"Entropy + nonce input length can not be greater than 1000 bit"
| BS.length info * 8 > 256 = error $
"Maximum personalization string length is 256 bit"
| otherwise = (k1,v1,1)
where
s = BS.concat [seed, nonce, info]
k0 = BS.replicate 32 0
v0 = BS.replicate 32 1
(k1,v1) = hmacDRBGUpd s k0 v0
hmacDRBGRsd :: WorkingState -> EntropyInput -> AdditionalInput -> WorkingState
hmacDRBGRsd (k,v,_) seed info
| BS.length seed * 8 < 256 = error $
"Entropy input length must be at least 256 bit"
| BS.length seed * 8 > 1000 = error $
"Entropy input length can not be greater than 1000 bit"
| otherwise = (k0,v0,1)
where
s = seed `BS.append` info
(k0,v0) = hmacDRBGUpd s k v
hmacDRBGGen :: WorkingState -> Word16 -> AdditionalInput
-> (WorkingState, Maybe BS.ByteString)
hmacDRBGGen (k0,v0,c0) bytes info
| bytes * 8 > 7500 = error "Maximum bits per request is 7500"
| c0 > 10000 = ((k0,v0,c0), Nothing)
| otherwise = ((k2,v3,c1), Just res)
where
(k1,v1) | BS.null info = (k0,v0)
| otherwise = hmacDRBGUpd info k0 v0
(tmp,v2) = go (fromIntegral bytes) k1 v1 BS.empty
res = BS.take (fromIntegral bytes) tmp
(k2,v3) = hmacDRBGUpd info k1 v2
c1 = c0 + 1
go l k v acc | BS.length acc >= l = (acc,v)
| otherwise = let vn = hmac256BS k v
in go l k vn (acc `BS.append` vn)
murmurHash3 :: Word32 -> BS.ByteString -> Word32
murmurHash3 nHashSeed bs = h8
where
nBlocks = BS.length bs `div` 4
nTail = BS.length bs `mod` 4
blocks = runGet' (replicateM nBlocks getWord32le) bs
bsTail = BS.drop (nBlocks*4) bs `BS.append` BS.replicate (4nTail) 0
h1 = foldl mix nHashSeed blocks
t1 = runGet' getWord32le bsTail
t2 = t1 * c1
t3 = t2 `rotateL` 15
t4 = t3 * c2
h2 = h1 `xor` t4
h3 = h2 `xor` (fromIntegral $ BS.length bs)
h4 = h3 `xor` (h3 `shiftR` 16)
h5 = h4 * 0x85ebca6b
h6 = h5 `xor` (h5 `shiftR` 13)
h7 = h6 * 0xc2b2ae35
h8 = h7 `xor` (h7 `shiftR` 16)
mix r1 k1 = r4
where
k2 = k1 * c1
k3 = k2 `rotateL` 15
k4 = k3 * c2
r2 = r1 `xor` k4
r3 = r2 `rotateL` 13
r4 = r3*5 + 0xe6546b64
c1 = 0xcc9e2d51
c2 = 0x1b873593