-- |
-- Module      : Data.Memory.Hash.SipHash
-- License     : BSD-style
-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
-- Stability   : experimental
-- Portability : good
--
-- provide the SipHash algorithm.
-- reference: <http://131002.net/siphash/siphash.pdf>
--
{-# 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

-- | SigHash Key
data SipKey = SipKey {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64

-- | Siphash tag value
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

-- | produce a siphash with a key and a memory pointer + length.
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

-- | same as 'hash', except also specifies the number of sipround iterations for compression and digest.
hashWith :: Int       -- ^ siphash C
         -> Int       -- ^ siphash D
         -> SipKey    -- ^ key for the hash
         -> Ptr Word8 -- ^ memory pointer
         -> Int       -- ^ length of the data
         -> 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)