{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE MagicHash #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE UnboxedTuples #-}

-- |
-- Module: Data.Hash.SipHash
-- Copyright: Copyright © 2021 Lars Kuhtz <lakuhtz@gmail.com>
-- License: MIT
-- Maintainer: Lars Kuhtz <lakuhtz@gmail.com>
-- Stability: experimental
--
module Data.Hash.SipHash
( sipHash
, sipHash13
, sipHash24
, sipHash48
, sipHashCD

-- * Utils
, module Data.Hash.Utils
) where

import Control.Monad

import Data.Bits
import Data.Function
import Data.Word

import Foreign.Marshal.Utils
import Foreign.Storable

import GHC.Ptr

import Prelude hiding (drop, length, null, splitAt, take)

-- internal modules

import Data.Hash.Utils

-- -------------------------------------------------------------------------- --
-- SipHash

-- | SipHash, with recommended default parameters of c=2 and c=4.
--
-- The first and second argument is the 128 bit key, represented as two 64 bit
-- words.
--
sipHash
    :: Word64
    -> Word64
    -> Ptr Word8
    -> Int
    -> IO Word64
sipHash :: Word64 -> Word64 -> Ptr Word8 -> Int -> IO Word64
sipHash = Word64 -> Word64 -> Ptr Word8 -> Int -> IO Word64
sipHash24
{-# INLINE sipHash #-}

-- | SipHash-2-4
--
-- The first and second argument is the 128 bit key, represented as two 64 bit
-- words.
--
sipHash24
    :: Word64
    -> Word64
    -> Ptr Word8
    -> Int
    -> IO Word64
sipHash24 :: Word64 -> Word64 -> Ptr Word8 -> Int -> IO Word64
sipHash24 = Round -> Round -> Word64 -> Word64 -> Ptr Word8 -> Int -> IO Word64
sipHashInternal Round
rounds2 Round
rounds4
{-# INLINE sipHash24 #-}

-- | SipHash-1-3
--
-- The first and second argument is the 128 bit key, represented as two 64 bit
-- words.
--
sipHash13
    :: Word64
    -> Word64
    -> Ptr Word8
    -> Int
    -> IO Word64
sipHash13 :: Word64 -> Word64 -> Ptr Word8 -> Int -> IO Word64
sipHash13 = Round -> Round -> Word64 -> Word64 -> Ptr Word8 -> Int -> IO Word64
sipHashInternal Round
rounds1 Round
rounds3
{-# INLINE sipHash13 #-}

-- | SipHash-4-8
--
-- The first and second argument is the 128 bit key, represented as two 64 bit
-- words.
--
sipHash48
    :: Word64
    -> Word64
    -> Ptr Word8
    -> Int
    -> IO Word64
sipHash48 :: Word64 -> Word64 -> Ptr Word8 -> Int -> IO Word64
sipHash48 = Round -> Round -> Word64 -> Word64 -> Ptr Word8 -> Int -> IO Word64
sipHashInternal Round
rounds4 Round
rounds8
{-# INLINE sipHash48 #-}

-- | Generic SipHash with c rounds per block and d finalization rounds.
--
-- The first and second argument is the 128 bit key, represented as two 64 bit
-- words.
--
sipHashCD
    :: Int
    -> Int
    -> Word64
    -> Word64
    -> Ptr Word8
    -> Int
    -> IO Word64
sipHashCD :: Int -> Int -> Word64 -> Word64 -> Ptr Word8 -> Int -> IO Word64
sipHashCD Int
c Int
d = Round -> Round -> Word64 -> Word64 -> Ptr Word8 -> Int -> IO Word64
sipHashInternal (Int -> Round
rounds Int
c) (Int -> Round
rounds Int
d)
{-# INLINE sipHashCD #-}

-- -------------------------------------------------------------------------- --
-- Generic SipHash

data S = S
    {-# UNPACK #-} !Word64
    {-# UNPACK #-} !Word64
    {-# UNPACK #-} !Word64
    {-# UNPACK #-} !Word64

type Round = Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)

sipHashInternal
    :: Round
    -> Round
    -> Word64
    -> Word64
    -> Ptr Word8
    -> Int
    -> IO Word64
sipHashInternal :: Round -> Round -> Word64 -> Word64 -> Ptr Word8 -> Int -> IO Word64
sipHashInternal Round
cRound Round
dRound !Word64
k0 !Word64
k1 !Ptr Word8
ptr !Int
len = do

    -- loop
    (S !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3) <- Word64 -> Word64 -> Word64 -> Word64 -> Ptr Word64 -> Int -> IO S
forall t.
(Ord t, Num t) =>
Word64 -> Word64 -> Word64 -> Word64 -> Ptr Word64 -> t -> IO S
loop Word64
i0 Word64
i1 Word64
i2 Word64
i3 (Ptr Word8 -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr) Int
len

    -- end
    let (!Int
off, !Int
r) = Int -> Int -> (Int, Int)
forall a. Integral a => a -> a -> (a, a)
quotRem Int
len Int
8
    Word64
w <- Ptr Word64 -> Int -> IO Word64
ptrToWord64 (Ptr Word8 -> Int -> Ptr Word64
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word8
ptr (Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
* Int
8)) Int
r
    let !b :: Word64
b = Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftL (Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len) Int
56 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
w
        (# !Word64
v0', !Word64
v1', !Word64
v2', !Word64
v3' #) = Round
cRound Word64
v0 Word64
v1 Word64
v2 (Word64
v3 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
b)
        (# !Word64
v0'', !Word64
v1'', !Word64
v2'', !Word64
v3'' #) = Round
dRound (Word64
v0' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
b) Word64
v1' (Word64
v2' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
0xff) Word64
v3'
    Word64 -> IO Word64
forall (m :: * -> *) a. Monad m => a -> m a
return (Word64 -> IO Word64) -> Word64 -> IO Word64
forall a b. (a -> b) -> a -> b
$! Word64
v0'' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
v1'' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
v2'' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
v3''

  where

    loop :: Word64 -> Word64 -> Word64 -> Word64 -> Ptr Word64 -> t -> IO S
loop !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 !Ptr Word64
p !t
l
        | t
l t -> t -> Bool
forall a. Ord a => a -> a -> Bool
< t
8 = S -> IO S
forall (m :: * -> *) a. Monad m => a -> m a
return (S -> IO S) -> S -> IO S
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64 -> Word64 -> Word64 -> S
S Word64
v0 Word64
v1 Word64
v2 Word64
v3
        | Bool
otherwise = do
            !Word64
m <- Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
peek Ptr Word64
p
            let (# Word64
v0', Word64
v1', Word64
v2', Word64
v3' #) = Round
cRound Word64
v0 Word64
v1 Word64
v2 (Word64
v3 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
m)
            Word64 -> Word64 -> Word64 -> Word64 -> Ptr Word64 -> t -> IO S
loop (Word64
v0' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
m) Word64
v1' Word64
v2' Word64
v3' (Ptr Word64 -> Int -> Ptr Word64
forall a b. Ptr a -> Int -> Ptr b
plusPtr Ptr Word64
p Int
8) (t
l t -> t -> t
forall a. Num a => a -> a -> a
- t
8)

    !i0 :: Word64
i0 = Word64
0x736f6d6570736575 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
k0
    !i1 :: Word64
i1 = Word64
0x646f72616e646f6d Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
k1
    !i2 :: Word64
i2 = Word64
0x6c7967656e657261 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
k0
    !i3 :: Word64
i3 = Word64
0x7465646279746573 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
k1
    {-# INLINE i0 #-}
    {-# INLINE i1 #-}
    {-# INLINE i2 #-}
    {-# INLINE i3 #-}
{-# INLINE sipHashInternal #-}

ptrToWord64 :: Ptr Word64 -> Int -> IO Word64
ptrToWord64 :: Ptr Word64 -> Int -> IO Word64
ptrToWord64 Ptr Word64
_ Int
0 = Word64 -> IO Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
0
ptrToWord64 !Ptr Word64
p Int
1 = Word8 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8 -> Word64) -> IO Word8 -> IO Word64
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Ptr Word8 -> IO Word8
forall a. Storable a => Ptr a -> IO a
peek @Word8 (Ptr Word64 -> Ptr Word8
forall a b. Ptr a -> Ptr b
castPtr Ptr Word64
p)
ptrToWord64 !Ptr Word64
p Int
2 = Word16 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word16 -> Word64) -> IO Word16 -> IO Word64
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Ptr Word16 -> IO Word16
forall a. Storable a => Ptr a -> IO a
peek @Word16 (Ptr Word64 -> Ptr Word16
forall a b. Ptr a -> Ptr b
castPtr Ptr Word64
p)
ptrToWord64 !Ptr Word64
p Int
4 = Word32 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word32 -> Word64) -> IO Word32 -> IO Word64
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Ptr Word32 -> IO Word32
forall a. Storable a => Ptr a -> IO a
peek @Word32 (Ptr Word64 -> Ptr Word32
forall a b. Ptr a -> Ptr b
castPtr Ptr Word64
p)
ptrToWord64 !Ptr Word64
p !Int
i = Word64 -> (Ptr Word64 -> IO Word64) -> IO Word64
forall a b. Storable a => a -> (Ptr a -> IO b) -> IO b
with @Word64 Word64
0 ((Ptr Word64 -> IO Word64) -> IO Word64)
-> (Ptr Word64 -> IO Word64) -> IO Word64
forall a b. (a -> b) -> a -> b
$ \Ptr Word64
p' -> do
        -- using 'with' within unsafeDupablePerformIO is probably safe because
        -- with uses 'alloca', which guarantees that the memory is released
        -- when computation is abondended before being terminated.
    Ptr Word64 -> Ptr Word64 -> Int -> IO ()
forall a. Ptr a -> Ptr a -> Int -> IO ()
copyBytes Ptr Word64
p' Ptr Word64
p Int
i
    Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
peek Ptr Word64
p'
{-# INLINE ptrToWord64 #-}

rounds1 :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)
rounds1 :: Round
rounds1 !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 = Round
sipRound Word64
v0 Word64
v1 Word64
v2 Word64
v3
{-# INLINE rounds1 #-}

rounds2 :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)
rounds2 :: Round
rounds2 !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 =
    let (# !Word64
v0', !Word64
v1', !Word64
v2', !Word64
v3' #) = Round
sipRound Word64
v0 Word64
v1 Word64
v2 Word64
v3
    in Round
sipRound Word64
v0' Word64
v1' Word64
v2' Word64
v3'
{-# INLINE rounds2 #-}

rounds3 :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)
rounds3 :: Round
rounds3 !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 =
    let (# !Word64
v0', !Word64
v1', !Word64
v2', !Word64
v3' #) = Round
sipRound Word64
v0 Word64
v1 Word64
v2 Word64
v3
        (# !Word64
v0'', !Word64
v1'', !Word64
v2'', !Word64
v3'' #) = Round
sipRound Word64
v0' Word64
v1' Word64
v2' Word64
v3'
    in Round
sipRound Word64
v0'' Word64
v1'' Word64
v2'' Word64
v3''
{-# INLINE rounds3 #-}

rounds4 :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)
rounds4 :: Round
rounds4 !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 =
    let (# !Word64
v0', !Word64
v1', !Word64
v2', !Word64
v3' #) = Round
sipRound Word64
v0 Word64
v1 Word64
v2 Word64
v3
        (# !Word64
v0'', !Word64
v1'', !Word64
v2'', !Word64
v3'' #) = Round
sipRound Word64
v0' Word64
v1' Word64
v2' Word64
v3'
        (# !Word64
v0''', !Word64
v1''', !Word64
v2''', !Word64
v3''' #) = Round
sipRound Word64
v0'' Word64
v1'' Word64
v2'' Word64
v3''
    in Round
sipRound Word64
v0''' Word64
v1''' Word64
v2''' Word64
v3'''
{-# INLINE rounds4 #-}

rounds8 :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)
rounds8 :: Round
rounds8 !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 =
    let (# !Word64
v0', !Word64
v1', !Word64
v2', !Word64
v3' #) = Round
sipRound Word64
v0 Word64
v1 Word64
v2 Word64
v3
        (# !Word64
v0'', !Word64
v1'', !Word64
v2'', !Word64
v3'' #) = Round
sipRound Word64
v0' Word64
v1' Word64
v2' Word64
v3'
        (# !Word64
v0''', !Word64
v1''', !Word64
v2''', !Word64
v3''' #) = Round
sipRound Word64
v0'' Word64
v1'' Word64
v2'' Word64
v3''
        (# !Word64
v0'''', !Word64
v1'''', !Word64
v2'''', !Word64
v3'''' #) = Round
sipRound Word64
v0''' Word64
v1''' Word64
v2''' Word64
v3'''
        (# !Word64
v0''''', !Word64
v1''''', !Word64
v2''''', !Word64
v3''''' #) = Round
sipRound Word64
v0'''' Word64
v1'''' Word64
v2'''' Word64
v3''''
        (# !Word64
v0'''''', !Word64
v1'''''', !Word64
v2'''''', !Word64
v3'''''' #) = Round
sipRound Word64
v0''''' Word64
v1''''' Word64
v2''''' Word64
v3'''''
        (# !Word64
v0''''''', !Word64
v1''''''', !Word64
v2''''''', !Word64
v3''''''' #) = Round
sipRound Word64
v0'''''' Word64
v1'''''' Word64
v2'''''' Word64
v3''''''
    in Round
sipRound Word64
v0''''''' Word64
v1''''''' Word64
v2''''''' Word64
v3'''''''
{-# INLINE rounds8 #-}

rounds :: Int -> Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)
rounds :: Int -> Round
rounds Int
1 !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 = Round
rounds1 Word64
v0 Word64
v1 Word64
v2 Word64
v3
rounds Int
2 !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 = Round
rounds2 Word64
v0 Word64
v1 Word64
v2 Word64
v3
rounds Int
3 !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 = Round
rounds3 Word64
v0 Word64
v1 Word64
v2 Word64
v3
rounds Int
4 !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 = Round
rounds4 Word64
v0 Word64
v1 Word64
v2 Word64
v3
rounds Int
8 !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 = Round
rounds8 Word64
v0 Word64
v1 Word64
v2 Word64
v3
rounds !Int
c !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 = case Round
sipRound Word64
v0 Word64
v1 Word64
v2 Word64
v3 of
    (# Word64
v0', Word64
v1', Word64
v2', Word64
v3' #) -> Int -> Round
rounds (Int
c Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) Word64
v0' Word64
v1' Word64
v2' Word64
v3'
{-# INLINE rounds #-}

sipRound :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)
sipRound :: Round
sipRound !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 = (# Word64
v0''', Word64
v1'''', Word64
v2''', Word64
v3'''' #)
    where
    !v0' :: Word64
v0' = Word64
v0 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
v1
    !v2' :: Word64
v2' = Word64
v2 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
v3
    !v1' :: Word64
v1' = Word64
v1 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`rotateL` Int
13
    !v3' :: Word64
v3' = Word64
v3 Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`rotateL` Int
16
    !v1'' :: Word64
v1'' = Word64
v1' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
v0'
    !v3'' :: Word64
v3'' = Word64
v3' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
v2'
    !v0'' :: Word64
v0'' = Word64
v0' Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`rotateL` Int
32
    !v2'' :: Word64
v2'' = Word64
v2' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
v1''
    !v0''' :: Word64
v0''' = Word64
v0'' Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
v3''
    !v1''' :: Word64
v1''' = Word64
v1'' Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`rotateL` Int
17
    !v3''' :: Word64
v3''' = Word64
v3'' Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`rotateL` Int
21
    !v1'''' :: Word64
v1'''' = Word64
v1''' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
v2''
    !v3'''' :: Word64
v3'''' = Word64
v3''' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
v0'''
    !v2''' :: Word64
v2''' = Word64
v2'' Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
`rotateL` Int
32
{-# INLINE sipRound #-}