blakesum-0.4: Data/Digest/BLAKE.hs
-- |
-- Module : Data.Digest.SHA3.Candidate.BLAKE
-- Copyright : (c) 2011 Kevin Cantu
--
-- License : BSD-style
-- Maintainer : Kevin Cantu <me@kevincantu.org>
-- Stability : experimental
--
-- BLAKE is one of the finalists in the NIST SHA-3 hash function competition
-- to replace SHA-1 and SHA-2.
module Data.Digest.BLAKE
(
-- * Digests
blake256
, blake512
, blake224
, blake384
-- * Text output
, textDigest
) where
import Data.Bits
import Data.Word
import Data.Int
import Data.List
import qualified Data.ByteString.Lazy as B
import qualified Data.Vector.Storable as V
import qualified Data.Text.Lazy as T
import qualified Text.Printf as P
--import Control.Parallel.Strategies
-- TODO: my function names often suck
-- TODO: wrangle some types into submission
-- TODO: may need to add error handling for excessively long inputs per the BLAKE paper
-- BLAKE-224 initial values
initialValues224 :: V.Vector Word32
initialValues224 =
V.fromList
[ 0xC1059ED8, 0x367CD507,
0x3070DD17, 0xF70E5939,
0xFFC00B31, 0x68581511,
0x64F98FA7, 0xBEFA4FA4 ]
-- BLAKE-256 initial values
initialValues256 :: V.Vector Word32
initialValues256 =
V.fromList
[ 0x6a09e667, 0xbb67ae85,
0x3c6ef372, 0xa54ff53a,
0x510e527f, 0x9b05688c,
0x1f83d9ab, 0x5be0cd19 ]
-- BLAKE-256 constants
constants256 :: V.Vector Word32
constants256 =
V.fromList
[ 0x243f6a88, 0x85a308d3,
0x13198a2e, 0x03707344,
0xa4093822, 0x299f31d0,
0x082efa98, 0xec4e6c89,
0x452821e6, 0x38d01377,
0xbe5466cf, 0x34e90c6c,
0xc0ac29b7, 0xc97c50dd,
0x3f84d5b5, 0xb5470917 ]
-- BLAKE-384 initial values
initialValues384 :: V.Vector Word64
initialValues384 =
V.fromList
[ 0xCBBB9D5DC1059ED8, 0x629A292A367CD507,
0x9159015A3070DD17, 0x152FECD8F70E5939,
0x67332667FFC00B31, 0x8EB44A8768581511,
0xDB0C2E0D64F98FA7, 0x47B5481DBEFA4FA4 ]
-- BLAKE-512 initial values
initialValues512 :: V.Vector Word64
initialValues512 =
V.fromList
[ 0x6A09E667F3BCC908, 0xBB67AE8584CAA73B,
0x3C6EF372FE94F82B, 0xA54FF53A5F1D36F1,
0x510E527FADE682D1, 0x9B05688C2B3E6C1F,
0x1F83D9ABFB41BD6B, 0x5BE0CD19137E2179 ]
-- BLAKE-512 constants
constants512 :: V.Vector Word64
constants512 =
V.fromList
[ 0x243F6A8885A308D3, 0x13198A2E03707344,
0xA4093822299F31D0, 0x082EFA98EC4E6C89,
0x452821E638D01377, 0xBE5466CF34E90C6C,
0xC0AC29B7C97C50DD, 0x3F84D5B5B5470917,
0x9216D5D98979FB1B, 0xD1310BA698DFB5AC,
0x2FFD72DBD01ADFB7, 0xB8E1AFED6A267E96,
0xBA7C9045F12C7F99, 0x24A19947B3916CF7,
0x0801F2E2858EFC16, 0x636920D871574E69 ]
-- BLAKE-256 permutations of {0..15}
sigmaTable :: [ V.Vector Int ]
sigmaTable =
map V.fromList
[[ 0, 1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15 ],
[ 14, 10, 4, 8, 9, 15, 13, 6, 1, 12, 0, 2, 11, 7, 5, 3 ],
[ 11, 8, 12, 0, 5, 2, 15, 13, 10, 14, 3, 6, 7, 1, 9, 4 ],
[ 7, 9, 3, 1, 13, 12, 11, 14, 2, 6, 5, 10, 4, 0, 15, 8 ],
[ 9, 0, 5, 7, 2, 4, 10, 15, 14, 1, 11, 12, 6, 8, 3, 13 ],
[ 2, 12, 6, 10, 0, 11, 8, 3, 4, 13, 7, 5, 15, 14, 1, 9 ],
[ 12, 5, 1, 15, 14, 13, 4, 10, 0, 7, 6, 3, 9, 2, 8, 11 ],
[ 13, 11, 7, 14, 12, 1, 3, 9, 5, 0, 15, 4, 8, 6, 2, 10 ],
[ 6, 15, 14, 9, 11, 3, 0, 8, 12, 2, 13, 7, 1, 4, 10, 5 ],
[ 10, 2, 8, 4, 7, 6, 1, 5, 15, 11, 9, 14, 3, 12, 13, 0 ]]
-- bit shift
-- perform a given Gi within the round function
-- generic bit shifting
bitshift :: (Bits a, V.Storable a)
=> BLAKE a
-> Int -- i for which we're calculating G(i)
-> (a,a,a,a) -- 4 word col/diag
-> V.Vector a -- messageblock
-> Int -- round
-> (a,a,a,a) -- out: row or diagonal
bitshift config ii (a,b,c,d) messageblock rnd =
let
-- configurable...
constants' = constants config
(rot0,rot1,rot2,rot3) = rotations config
-- get sigma
sigma n = sigmaTable !! (rnd `mod` 10) V.! n
messageword n = messageblock V.! sigma n
constant n = constants' V.! sigma n
i2 = 2 * ii
-- compute the rnd
a' = a + b + (messageword (i2) `xor` constant (i2 + 1))
d' = (d `xor` a') `rotateR` rot0
c' = c + d'
b' = (b `xor` c') `rotateR` rot1
a'' = a' + b' + (messageword (i2 + 1) `xor` constant (i2))
d'' = (d' `xor` a'') `rotateR` rot2
c'' = c' + d''
b'' = (b' `xor` c'') `rotateR` rot3
in
-- out
(a'', b'', c'', d'')
-- generic round function
-- apply multiple G computations for a single round
-- TODO:
-- Why is this slower with parallel column and then diagonal calcs? Laziness?
-- With rdeepseq, particularly, this cuts the heap by about 2/3, though!
blakeRound :: (V.Storable a, Bits a)
=> BLAKE a
-> V.Vector a
-> V.Vector a
-> Int
-> V.Vector a
blakeRound config messageblock state rnd =
let
-- perform one G
g (ii,four) = bitshift config ii four messageblock rnd
-- apply G to columns
-- then rotate result back into order
applyColumns [ s0, s1, s2, s3,
s4, s5, s6, s7,
s8, s9,s10,s11,
s12,s13,s14,s15] =
--parMap rdeepseq g
map g
[(0, (s0, s4, s8, s12)),
(1, (s1, s5, s9, s13)),
(2, (s2, s6, s10,s14)),
(3, (s3, s7, s11,s15))]
applyColumns _ = error "applyColumns: fail"
-- apply G to diagonals
-- then rotate result back into order
applyDiagonals [(c00,c01,c02,c03),
(c10,c11,c12,c13),
(c20,c21,c22,c23),
(c30,c31,c32,c33)] =
--parMap rdeepseq g
map g
[(4,(c00, c11, c22, c33)),
(5,(c10, c21, c32, c03)),
(6,(c20, c31, c02, c13)),
(7,(c30, c01, c12, c23))]
applyDiagonals _ = error "applyDiagonals: fail"
-- unwind the diagonal results
manualSpin [(d00,d01,d02,d03),
(d10,d11,d12,d13),
(d20,d21,d22,d23),
(d30,d31,d32,d33)] =
[d00, d10, d20, d30,
d31, d01, d11, d21,
d22, d32, d02, d12,
d13, d23, d33, d03]
manualSpin _ = error "manualSpin: fail"
in
V.fromList $ manualSpin $ applyDiagonals $ applyColumns $ V.toList state
-- initial 16 word state
-- here, my counter 't' contains [high,low] words
-- rather than reverse it in `blocks` below, i changed the numbering here
initialState :: (V.Storable a, Bits a)
=> BLAKE a
-> V.Vector a
-> [a]
-> [a]
-> V.Vector a
initialState config h s t =
let
-- configurable...
constants' = constants config
partialConstants = V.take 8 constants'
counter = V.fromList [t!!1, t!!1, t!!0, t!!0]
stateAndCount = V.fromList s V.++ counter
chainPlusStuff = V.zipWith xor stateAndCount partialConstants
in
h V.++ chainPlusStuff
-- BLAKE-256 compression of one message block
-- rounds is the number of rounds to iterate
-- h is a chain 0-7
-- m is a message block 0-15
-- s is a salt 0-3
-- t is a counter 0-1
-- return h'
compress :: (V.Storable a, Bits a)
=> BLAKE a
-> [a]
-> V.Vector a
-> (V.Vector a, [a])
-> V.Vector a
compress config salt h (m,t) =
let
-- configurable...
rounds' = rounds config
initial = initialState config h salt t
-- e.g., do 14 rounds on this messageblock for 256-bit
-- WARNING: this lazy foldl dramatically reduces heap use...
v = foldl (blakeRound config m) initial [0..rounds'-1]
-- split it in half
(v0,v1) = V.splitAt 8 v
-- salt
s' = V.fromList salt
s'' = s' V.++ s'
in
-- finalize
V.zipWith4 xor4 h
s''
v0
v1
where xor4 a b c d = a `xor` b `xor` c `xor` d
-- convert words to bytes in a ByteString
-- the word array input typically needs a type annotation
toByteString :: (Integral a, Bits a, V.Storable a) => Int -> V.Vector a -> B.ByteString
toByteString size mydata =
let
octets = size `div` 8
g w n = w `shiftR` (n*8)
toBytes w = V.map (g w) $ V.fromList $ reverse [0..octets-1]
in
B.pack $ V.toList $ V.map fromIntegral $ V.concatMap toBytes mydata
-- BLAKE padding
-- blocks of twice the hash size, which is 8 words
-- with a counter per block
-- TODO: I'd rather slice the input instead of making new vectors
blocks :: (Bits a, Integral a, Num a, V.Storable a)
=> BLAKE a
-> B.ByteString
-> [( V.Vector a, [a] )]
blocks config message' =
let
-- configurable...
wordSize' = wordSize config
-- recurse with accumulating counter
loop counter message =
let
-- split bytes at 16 words of type a
(m, ms) = B.splitAt (wordSize' * 2) message
-- block length in bits
len = 8 * B.length m
-- cumulative block length in bits
counter' = (counter :: Integer) + fromIntegral len
counterMSW = fromIntegral $ counter' `shiftR` (fromIntegral wordSize' :: Int)
counterLSW = fromIntegral counter'
splitCounter = [counterMSW, counterLSW]
in
if len < (16 * wordSize') || ms == B.empty
then -- final
let
padded = m `B.append` makePadding config len -- padded message block
final = makeWords wordSize' padded ++ splitCounter -- block including counter
in
case length final of
-- each message block is padded to 16 words
16 -> [( (V.fromList final), splitCounter )]
32 -> [( (V.fromList $ take 16 final), splitCounter ),
( (V.fromList $ drop 16 final), [0,0] )]
_ -> error "we have created a monster! padding --> nonsense"
else -- regular
((V.fromList $ makeWords wordSize' m), splitCounter) : loop counter' ms
in
loop 0 message'
-- how do I make it generic
-- even though ByteString isn't an [a]?
nfoldl :: Int64 -> (B.ByteString -> a) -> B.ByteString -> [a]
nfoldl n fn xs =
let
(x, xs') = B.splitAt n xs
in
case B.length x of
0 -> []
len | len < n -> error "nfoldl: didn't have n remaining"
_ -> fn x : nfoldl n fn xs'
-- turn a ByteString into an integer
growWord :: (Integral a, Bits a) => B.ByteString -> a
growWord = B.foldl' shiftAcc 0
where shiftAcc acc x = (fromIntegral acc `shift` 8) + fromIntegral x
-- turn many ByteStrings into integers
makeWords :: (Bits a, Integral a) => Int64 -> B.ByteString -> [a]
makeWords n ss = nfoldl (n `div` 8) growWord ss
-- pad a last block of message as needed
-- TODO: simplify
makePadding :: BLAKE a
-> Int64 -- block bitlength
-> B.ByteString -- padded space, e.g. 0b1000...00001
makePadding config len =
let
-- configurable...
wordSize' = wordSize config
paddingTerminator' = paddingTerminator config
targetbits = (14 * wordSize') - 2 -- length zero padding will be used to build, 446 or 894
zerobits = (targetbits - len) `mod` (16 * wordSize') -- where len is bytes in this data
zerobytes = (zerobits - 7 - 7) `div` 8 -- the number of 0x00 between the 0x80 and 0x01
zbs = B.take zerobytes (B.repeat 0) -- the bytestring of 0x00
in
case zerobits of
z | z == 6 -> B.singleton $ 0x80 + paddingTerminator' -- one byte -- TODO: THIS CASE IS NOT TESTED?
z | z > 6 -> 0x80 `B.cons` zbs `B.snoc` paddingTerminator' -- more bytes
_ -> error "assumption: adjustment of the input bits should be 0 `mod` 8 "
blake :: (V.Storable a, Bits a, Integral a)
=> BLAKE a
-> B.ByteString
-> B.ByteString
-> B.ByteString
blake config salt message =
let
-- configurable...
initialValues' = initialValues config
wordSize' = wordSize config
fromWtoB' = fromWtoB config
salt' = makeWords wordSize' salt
in
if length salt' /= 4
then error "blake: your salt is not four words"
else fromWtoB' $ foldl' (compress config salt') initialValues' $ blocks config message
-- hold configuration data for different versions of BLAKE
data BLAKE a =
BLAKE { initialValues :: V.Vector a
, constants :: V.Vector a
, rotations :: (Int, Int, Int, Int)
, rounds :: Int
, paddingTerminator :: Word8
, wordSize :: Int64
, fromWtoB :: V.Vector a -> B.ByteString
}
-- | Compute a BLAKE-256 digest from a given salt and message
blake256 :: B.ByteString -- ^ salt, 16 bytes
-> B.ByteString -- ^ message
-> B.ByteString -- ^ digest, 32 bytes
blake256 salt message =
let
config = BLAKE { initialValues = initialValues256
, constants = constants256
, rotations = (16,12,8,7)
, rounds = 14
, paddingTerminator = 0x01
, wordSize = 32
, fromWtoB = toByteString 32 :: V.Vector Word32 -> B.ByteString
}
in
blake config salt message
-- | Compute a BLAKE-512 digest from a given salt and message
blake512 :: B.ByteString -- ^ salt, 32 bytes
-> B.ByteString -- ^ message
-> B.ByteString -- ^ digest, 64 bytes
blake512 salt message =
let
config = BLAKE { initialValues = initialValues512
, constants = constants512
, rotations = (32,25,16,11)
, rounds = 16
, paddingTerminator = 0x01
, wordSize = 64
, fromWtoB = toByteString 64 :: V.Vector Word64 -> B.ByteString
}
in
blake config salt message
-- | Compute a BLAKE-224 digest from a given salt and message
-- (trucates output of a BLAKE-256)
blake224 :: B.ByteString -- ^ salt, 16 bytes
-> B.ByteString -- ^ message
-> B.ByteString -- ^ digest, 28 bytes
blake224 salt message =
let
config = BLAKE { initialValues = initialValues224
, constants = constants256
, rotations = (16,12,8,7)
, rounds = 14
, paddingTerminator = 0x00
, wordSize = 32
, fromWtoB = toByteString 32 :: V.Vector Word32 -> B.ByteString
}
in
B.take 28 $ blake config salt message
-- | Compute a BLAKE-384 digest from a given salt and message
-- (trucates output of a BLAKE-512)
blake384 :: B.ByteString -- ^ salt, 32 bytes
-> B.ByteString -- ^ message
-> B.ByteString -- ^ digest, 48 bytes
blake384 salt message =
let
config = BLAKE { initialValues = initialValues384
, constants = constants512
, rotations = (32,25,16,11)
, rounds = 16
, paddingTerminator = 0x00
, wordSize = 64
, fromWtoB = toByteString 64 :: V.Vector Word64 -> B.ByteString
}
in
B.take 48 $ blake config salt message
-- | Convert a digest (or other ByteString) to hexadecimal digits
--
-- For example, to compute a digest of a message, `0x00`,
-- using BLAKE-512 (faster on 64 bit systems),
-- with a salt of 0, and get the digits in hex:
--
-- > import Data.Digest.BLAKE
-- > import qualified Data.ByteString.Lazy as B
-- >
-- > textDigest $ blake512 (B.take 32 $ B.repeat 0) (B.singleton 0)
textDigest :: B.ByteString -> T.Text
textDigest digest =
T.pack $ (P.printf "%02x") =<< B.unpack digest