module Data.Digest.BLAKE
(
blake256
, blake512
, blake224
, blake384
, 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
initialValues224 :: V.Vector Word32
initialValues224 =
V.fromList
[ 0xC1059ED8, 0x367CD507,
0x3070DD17, 0xF70E5939,
0xFFC00B31, 0x68581511,
0x64F98FA7, 0xBEFA4FA4 ]
initialValues256 :: V.Vector Word32
initialValues256 =
V.fromList
[ 0x6a09e667, 0xbb67ae85,
0x3c6ef372, 0xa54ff53a,
0x510e527f, 0x9b05688c,
0x1f83d9ab, 0x5be0cd19 ]
constants256 :: V.Vector Word32
constants256 =
V.fromList
[ 0x243f6a88, 0x85a308d3,
0x13198a2e, 0x03707344,
0xa4093822, 0x299f31d0,
0x082efa98, 0xec4e6c89,
0x452821e6, 0x38d01377,
0xbe5466cf, 0x34e90c6c,
0xc0ac29b7, 0xc97c50dd,
0x3f84d5b5, 0xb5470917 ]
initialValues384 :: V.Vector Word64
initialValues384 =
V.fromList
[ 0xCBBB9D5DC1059ED8, 0x629A292A367CD507,
0x9159015A3070DD17, 0x152FECD8F70E5939,
0x67332667FFC00B31, 0x8EB44A8768581511,
0xDB0C2E0D64F98FA7, 0x47B5481DBEFA4FA4 ]
initialValues512 :: V.Vector Word64
initialValues512 =
V.fromList
[ 0x6A09E667F3BCC908, 0xBB67AE8584CAA73B,
0x3C6EF372FE94F82B, 0xA54FF53A5F1D36F1,
0x510E527FADE682D1, 0x9B05688C2B3E6C1F,
0x1F83D9ABFB41BD6B, 0x5BE0CD19137E2179 ]
constants512 :: V.Vector Word64
constants512 =
V.fromList
[ 0x243F6A8885A308D3, 0x13198A2E03707344,
0xA4093822299F31D0, 0x082EFA98EC4E6C89,
0x452821E638D01377, 0xBE5466CF34E90C6C,
0xC0AC29B7C97C50DD, 0x3F84D5B5B5470917,
0x9216D5D98979FB1B, 0xD1310BA698DFB5AC,
0x2FFD72DBD01ADFB7, 0xB8E1AFED6A267E96,
0xBA7C9045F12C7F99, 0x24A19947B3916CF7,
0x0801F2E2858EFC16, 0x636920D871574E69 ]
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 ]]
bitshift :: (Bits a, V.Storable a)
=> BLAKE a
-> Int
-> (a,a,a,a)
-> V.Vector a
-> Int
-> (a,a,a,a)
bitshift config ii (a,b,c,d) messageblock rnd =
let
constants' = constants config
(rot0,rot1,rot2,rot3) = rotations config
sigma n = sigmaTable !! (rnd `mod` 10) V.! n
messageword n = messageblock V.! sigma n
constant n = constants' V.! sigma n
i2 = 2 * ii
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
(a'', b'', c'', d'')
blakeRound :: (V.Storable a, Bits a)
=> BLAKE a
-> V.Vector a
-> V.Vector a
-> Int
-> V.Vector a
blakeRound config messageblock state rnd =
let
g (ii,four) = bitshift config ii four messageblock rnd
applyColumns [ s0, s1, s2, s3,
s4, s5, s6, s7,
s8, s9,s10,s11,
s12,s13,s14,s15] =
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"
applyDiagonals [(c00,c01,c02,c03),
(c10,c11,c12,c13),
(c20,c21,c22,c23),
(c30,c31,c32,c33)] =
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"
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
initialState :: (V.Storable a, Bits a)
=> BLAKE a
-> V.Vector a
-> [a]
-> [a]
-> V.Vector a
initialState config h s t =
let
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
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
rounds' = rounds config
initial = initialState config h salt t
v = foldl (blakeRound config m) initial [0..rounds'1]
(v0,v1) = V.splitAt 8 v
s' = V.fromList salt
s'' = s' V.++ s'
in
V.zipWith4 xor4 h
s''
v0
v1
where xor4 a b c d = a `xor` b `xor` c `xor` d
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..octets1]
in
B.pack $ V.toList $ V.map fromIntegral $ V.concatMap toBytes mydata
blocks :: (Bits a, Integral a, Num a, V.Storable a)
=> BLAKE a
-> B.ByteString
-> [( V.Vector a, [a] )]
blocks config message' =
let
wordSize' = wordSize config
loop counter message =
let
(m, ms) = B.splitAt (wordSize' * 2) message
len = 8 * B.length m
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
let
padded = m `B.append` makePadding config len
final = makeWords wordSize' padded ++ splitCounter
in
case length final of
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
((V.fromList $ makeWords wordSize' m), splitCounter) : loop counter' ms
in
loop 0 message'
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'
growWord :: (Integral a, Bits a) => B.ByteString -> a
growWord = B.foldl' shiftAcc 0
where shiftAcc acc x = (fromIntegral acc `shift` 8) + fromIntegral x
makeWords :: (Bits a, Integral a) => Int64 -> B.ByteString -> [a]
makeWords n ss = nfoldl (n `div` 8) growWord ss
makePadding :: BLAKE a
-> Int64
-> B.ByteString
makePadding config len =
let
wordSize' = wordSize config
paddingTerminator' = paddingTerminator config
targetbits = (14 * wordSize') 2
zerobits = (targetbits len) `mod` (16 * wordSize')
zerobytes = (zerobits 7 7) `div` 8
zbs = B.take zerobytes (B.repeat 0)
in
case zerobits of
z | z == 6 -> B.singleton $ 0x80 + paddingTerminator'
z | z > 6 -> 0x80 `B.cons` zbs `B.snoc` paddingTerminator'
_ -> 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
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
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
}
blake256 :: B.ByteString
-> B.ByteString
-> B.ByteString
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
blake512 :: B.ByteString
-> B.ByteString
-> B.ByteString
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
blake224 :: B.ByteString
-> B.ByteString
-> B.ByteString
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
blake384 :: B.ByteString
-> B.ByteString
-> B.ByteString
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
textDigest :: B.ByteString -> T.Text
textDigest digest =
T.pack $ (P.printf "%02x") =<< B.unpack digest