{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveDataTypeable #-}
module Data.Memory.Hash.SipHash
( SipKey(..)
, SipHash(..)
, hash
, hashWith
) where
import Data.Memory.Endian
import Data.Memory.Internal.Compat
import Data.Word
import Data.Bits
import Data.Typeable (Typeable)
import Control.Monad
import Foreign.Ptr
import Foreign.Storable
data SipKey = SipKey {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
newtype SipHash = SipHash Word64
deriving (Int -> SipHash -> ShowS
[SipHash] -> ShowS
SipHash -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SipHash] -> ShowS
$cshowList :: [SipHash] -> ShowS
show :: SipHash -> String
$cshow :: SipHash -> String
showsPrec :: Int -> SipHash -> ShowS
$cshowsPrec :: Int -> SipHash -> ShowS
Show,SipHash -> SipHash -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SipHash -> SipHash -> Bool
$c/= :: SipHash -> SipHash -> Bool
== :: SipHash -> SipHash -> Bool
$c== :: SipHash -> SipHash -> Bool
Eq,Eq SipHash
SipHash -> SipHash -> Bool
SipHash -> SipHash -> Ordering
SipHash -> SipHash -> SipHash
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SipHash -> SipHash -> SipHash
$cmin :: SipHash -> SipHash -> SipHash
max :: SipHash -> SipHash -> SipHash
$cmax :: SipHash -> SipHash -> SipHash
>= :: SipHash -> SipHash -> Bool
$c>= :: SipHash -> SipHash -> Bool
> :: SipHash -> SipHash -> Bool
$c> :: SipHash -> SipHash -> Bool
<= :: SipHash -> SipHash -> Bool
$c<= :: SipHash -> SipHash -> Bool
< :: SipHash -> SipHash -> Bool
$c< :: SipHash -> SipHash -> Bool
compare :: SipHash -> SipHash -> Ordering
$ccompare :: SipHash -> SipHash -> Ordering
Ord,Typeable)
data InternalState = InternalState {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
hash :: SipKey -> Ptr Word8 -> Int -> IO SipHash
hash :: SipKey -> Ptr Word8 -> Int -> IO SipHash
hash = Int -> Int -> SipKey -> Ptr Word8 -> Int -> IO SipHash
hashWith Int
2 Int
4
hashWith :: Int
-> Int
-> SipKey
-> Ptr Word8
-> Int
-> IO SipHash
hashWith :: Int -> Int -> SipKey -> Ptr Word8 -> Int -> IO SipHash
hashWith Int
c Int
d SipKey
key Ptr Word8
startPtr Int
totalLen = forall {a} {b}.
(Ord a, Num a) =>
InternalState -> Ptr b -> a -> IO SipHash
runHash (SipKey -> InternalState
initSip SipKey
key) Ptr Word8
startPtr Int
totalLen
where runHash :: InternalState -> Ptr b -> a -> IO SipHash
runHash !InternalState
st !Ptr b
ptr a
l
| a
l forall a. Ord a => a -> a -> Bool
> a
7 = forall a. Storable a => Ptr a -> IO a
peek (forall a b. Ptr a -> Ptr b
castPtr Ptr b
ptr) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \LE Word64
v -> InternalState -> Ptr b -> a -> IO SipHash
runHash (InternalState -> Word64 -> InternalState
process InternalState
st (forall a. ByteSwap a => LE a -> a
fromLE LE Word64
v)) (Ptr b
ptr forall a b. Ptr a -> Int -> Ptr b
`plusPtr` Int
8) (a
lforall a. Num a => a -> a -> a
-a
8)
| Bool
otherwise = do
let !lengthBlock :: Word64
lengthBlock = (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
totalLen forall a. Integral a => a -> a -> a
`mod` Word64
256) forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
56
(InternalState -> SipHash
finish forall b c a. (b -> c) -> (a -> b) -> a -> c
. InternalState -> Word64 -> InternalState
process InternalState
st) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
`fmap` case a
l of
a
0 -> do forall (m :: * -> *) a. Monad m => a -> m a
return Word64
lengthBlock
a
1 -> do Word8
v0 <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
0
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
lengthBlock forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
to64 Word8
v0)
a
2 -> do (Word8
v0,Word8
v1) <- forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
0) (forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
1)
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64
lengthBlock
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v1 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
8)
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
to64 Word8
v0)
a
3 -> do (Word8
v0,Word8
v1,Word8
v2) <- forall (m :: * -> *) a1 a2 a3 r.
Monad m =>
(a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
liftM3 (,,) (forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
0) (forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
1) (forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
2)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Word64
lengthBlock
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v2 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
16)
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v1 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
8)
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
to64 Word8
v0)
a
4 -> do (Word8
v0,Word8
v1,Word8
v2,Word8
v3) <- forall (m :: * -> *) a1 a2 a3 a4 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> r) -> m a1 -> m a2 -> m a3 -> m a4 -> m r
liftM4 (,,,) (forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
0) (forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
1) (forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
2)
(forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
3)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Word64
lengthBlock
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v3 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
24)
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v2 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
16)
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v1 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
8)
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
to64 Word8
v0)
a
5 -> do (Word8
v0,Word8
v1,Word8
v2,Word8
v3,Word8
v4) <- forall (m :: * -> *) a1 a2 a3 a4 a5 r.
Monad m =>
(a1 -> a2 -> a3 -> a4 -> a5 -> r)
-> m a1 -> m a2 -> m a3 -> m a4 -> m a5 -> m r
liftM5 (,,,,) (forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
0) (forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
1) (forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
2)
(forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
3) (forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
4)
forall (m :: * -> *) a. Monad m => a -> m a
return ( Word64
lengthBlock
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v4 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
32)
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v3 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
24)
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v2 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
16)
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v1 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
8)
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
to64 Word8
v0)
a
6 -> do Word8
v0 <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
0
Word8
v1 <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
1
Word8
v2 <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
2
Word8
v3 <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
3
Word8
v4 <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
4
Word8
v5 <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
5
forall (m :: * -> *) a. Monad m => a -> m a
return ( Word64
lengthBlock
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v5 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
40)
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v4 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
32)
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v3 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
24)
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v2 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
16)
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v1 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
8)
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
to64 Word8
v0)
a
7 -> do Word8
v0 <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
0
Word8
v1 <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
1
Word8
v2 <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
2
Word8
v3 <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
3
Word8
v4 <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
4
Word8
v5 <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
5
Word8
v6 <- forall a b. Storable a => Ptr b -> Int -> IO a
peekByteOff Ptr b
ptr Int
6
forall (m :: * -> *) a. Monad m => a -> m a
return ( Word64
lengthBlock
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v6 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
48)
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v5 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
40)
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v4 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
32)
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v3 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
24)
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v2 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
16)
forall a. Bits a => a -> a -> a
.|. (Word8 -> Word64
to64 Word8
v1 forall a. Bits a => a -> Int -> a
`unsafeShiftL` Int
8)
forall a. Bits a => a -> a -> a
.|. Word8 -> Word64
to64 Word8
v0)
a
_ -> forall a. HasCallStack => String -> a
error String
"siphash: internal error: cannot happens"
{-# INLINE to64 #-}
to64 :: Word8 -> Word64
to64 :: Word8 -> Word64
to64 = forall a b. (Integral a, Num b) => a -> b
fromIntegral
{-# INLINE process #-}
process :: InternalState -> Word64 -> InternalState
process InternalState
istate Word64
m = InternalState
newState
where newState :: InternalState
newState = InternalState -> InternalState
postInject forall a b. (a -> b) -> a -> b
$! InternalState -> InternalState
runRoundsCompression forall a b. (a -> b) -> a -> b
$! InternalState -> InternalState
preInject InternalState
istate
preInject :: InternalState -> InternalState
preInject (InternalState Word64
v0 Word64
v1 Word64
v2 Word64
v3) = Word64 -> Word64 -> Word64 -> Word64 -> InternalState
InternalState Word64
v0 Word64
v1 Word64
v2 (Word64
v3 forall a. Bits a => a -> a -> a
`xor` Word64
m)
postInject :: InternalState -> InternalState
postInject (InternalState Word64
v0 Word64
v1 Word64
v2 Word64
v3) = Word64 -> Word64 -> Word64 -> Word64 -> InternalState
InternalState (Word64
v0 forall a. Bits a => a -> a -> a
`xor` Word64
m) Word64
v1 Word64
v2 Word64
v3
{-# INLINE finish #-}
finish :: InternalState -> SipHash
finish InternalState
istate = InternalState -> SipHash
getDigest forall a b. (a -> b) -> a -> b
$! InternalState -> InternalState
runRoundsDigest forall a b. (a -> b) -> a -> b
$! InternalState -> InternalState
preInject InternalState
istate
where getDigest :: InternalState -> SipHash
getDigest (InternalState Word64
v0 Word64
v1 Word64
v2 Word64
v3) = Word64 -> SipHash
SipHash (Word64
v0 forall a. Bits a => a -> a -> a
`xor` Word64
v1 forall a. Bits a => a -> a -> a
`xor` Word64
v2 forall a. Bits a => a -> a -> a
`xor` Word64
v3)
preInject :: InternalState -> InternalState
preInject (InternalState Word64
v0 Word64
v1 Word64
v2 Word64
v3) = Word64 -> Word64 -> Word64 -> Word64 -> InternalState
InternalState Word64
v0 Word64
v1 (Word64
v2 forall a. Bits a => a -> a -> a
`xor` Word64
0xff) Word64
v3
{-# INLINE doRound #-}
doRound :: InternalState -> InternalState
doRound (InternalState Word64
v0 Word64
v1 Word64
v2 Word64
v3) =
let !v0' :: Word64
v0' = Word64
v0 forall a. Num a => a -> a -> a
+ Word64
v1
!v2' :: Word64
v2' = Word64
v2 forall a. Num a => a -> a -> a
+ Word64
v3
!v1' :: Word64
v1' = Word64
v1 forall a. Bits a => a -> Int -> a
`rotateL` Int
13
!v3' :: Word64
v3' = Word64
v3 forall a. Bits a => a -> Int -> a
`rotateL` Int
16
!v1'' :: Word64
v1'' = Word64
v1' forall a. Bits a => a -> a -> a
`xor` Word64
v0'
!v3'' :: Word64
v3'' = Word64
v3' forall a. Bits a => a -> a -> a
`xor` Word64
v2'
!v0'' :: Word64
v0'' = Word64
v0' forall a. Bits a => a -> Int -> a
`rotateL` Int
32
!v2'' :: Word64
v2'' = Word64
v2' forall a. Num a => a -> a -> a
+ Word64
v1''
!v0''' :: Word64
v0''' = Word64
v0'' forall a. Num a => a -> a -> a
+ Word64
v3''
!v1''' :: Word64
v1''' = Word64
v1'' forall a. Bits a => a -> Int -> a
`rotateL` Int
17
!v3''' :: Word64
v3''' = Word64
v3'' forall a. Bits a => a -> Int -> a
`rotateL` Int
21
!v1'''' :: Word64
v1'''' = Word64
v1''' forall a. Bits a => a -> a -> a
`xor` Word64
v2''
!v3'''' :: Word64
v3'''' = Word64
v3''' forall a. Bits a => a -> a -> a
`xor` Word64
v0'''
!v2''' :: Word64
v2''' = Word64
v2'' forall a. Bits a => a -> Int -> a
`rotateL` Int
32
in Word64 -> Word64 -> Word64 -> Word64 -> InternalState
InternalState Word64
v0''' Word64
v1'''' Word64
v2''' Word64
v3''''
{-# INLINE runRoundsCompression #-}
runRoundsCompression :: InternalState -> InternalState
runRoundsCompression InternalState
st
| Int
c forall a. Eq a => a -> a -> Bool
== Int
2 = InternalState -> InternalState
doRound forall a b. (a -> b) -> a -> b
$! InternalState -> InternalState
doRound InternalState
st
| Bool
otherwise = forall {t}. (Eq t, Num t) => t -> InternalState -> InternalState
loopRounds Int
c InternalState
st
{-# INLINE runRoundsDigest #-}
runRoundsDigest :: InternalState -> InternalState
runRoundsDigest InternalState
st
| Int
d forall a. Eq a => a -> a -> Bool
== Int
4 = InternalState -> InternalState
doRound forall a b. (a -> b) -> a -> b
$! InternalState -> InternalState
doRound forall a b. (a -> b) -> a -> b
$! InternalState -> InternalState
doRound forall a b. (a -> b) -> a -> b
$! InternalState -> InternalState
doRound InternalState
st
| Bool
otherwise = forall {t}. (Eq t, Num t) => t -> InternalState -> InternalState
loopRounds Int
d InternalState
st
{-# INLINE loopRounds #-}
loopRounds :: t -> InternalState -> InternalState
loopRounds t
1 !InternalState
v = InternalState -> InternalState
doRound InternalState
v
loopRounds t
n !InternalState
v = t -> InternalState -> InternalState
loopRounds (t
nforall a. Num a => a -> a -> a
-t
1) (InternalState -> InternalState
doRound InternalState
v)
{-# INLINE initSip #-}
initSip :: SipKey -> InternalState
initSip (SipKey Word64
k0 Word64
k1) = Word64 -> Word64 -> Word64 -> Word64 -> InternalState
InternalState (Word64
k0 forall a. Bits a => a -> a -> a
`xor` Word64
0x736f6d6570736575)
(Word64
k1 forall a. Bits a => a -> a -> a
`xor` Word64
0x646f72616e646f6d)
(Word64
k0 forall a. Bits a => a -> a -> a
`xor` Word64
0x6c7967656e657261)
(Word64
k1 forall a. Bits a => a -> a -> a
`xor` Word64
0x7465646279746573)