{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UnboxedTuples #-}
{-# LANGUAGE UndecidableInstances #-}

-- |
-- 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
( SipHashKey(..)
, SipHash(..)
, sipHash

-- * SipHash-c-d
, sipHashCD
, sipHash24
, sipHash13
, sipHash48

-- * Incremental SipHash
, SipHashContext
, sipHashInitialize
, sipHashUpdate
, sipHashFinalize

-- * Utils
, module Data.Hash.Class.Pure.Salted
) where

import Control.Monad

import Data.Bits
import Data.Type.Equality
import Data.Word

import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable

import GHC.TypeNats

-- internal modules

import Data.Hash.Class.Pure.Salted

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

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

-- | 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
    :: forall c d
    . SipHashParam c
    => SipHashParam d
    => SipHashKey
    -> Ptr Word8
    -> Int
    -> IO (SipHash c d)
sipHashCD :: SipHashKey -> Ptr Word8 -> Int -> IO (SipHash c d)
sipHashCD SipHashKey
key Ptr Word8
ptr Int
n = SipHashContext c d -> SipHash c d
forall (c :: Nat) (d :: Nat).
(SipHashParam c, SipHashParam d) =>
SipHashContext c d -> SipHash c d
sipHashFinalize
    (SipHashContext c d -> SipHash c d)
-> IO (SipHashContext c d) -> IO (SipHash c d)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SipHashContext c d -> Ptr Word8 -> Int -> IO (SipHashContext c d)
forall (c :: Nat) (d :: Nat).
SipHashParam c =>
SipHashContext c d -> Ptr Word8 -> Int -> IO (SipHashContext c d)
sipHashUpdate (SipHashKey -> SipHashContext c d
forall (c :: Nat) (d :: Nat). SipHashKey -> SipHashContext c d
sipHashInitialize SipHashKey
key) Ptr Word8
ptr Int
n
{-# INLINE sipHashCD #-}

-- | SipHash-2-4
--
-- The first and second argument is the 128 bit key, represented as two 64 bit
-- words.
--
sipHash24 :: SipHashKey -> Ptr Word8 -> Int -> IO (SipHash 2 4)
sipHash24 :: SipHashKey -> Ptr Word8 -> Int -> IO (SipHash 2 4)
sipHash24 = SipHashKey -> Ptr Word8 -> Int -> IO (SipHash 2 4)
forall (c :: Nat) (d :: Nat).
(SipHashParam c, SipHashParam d) =>
SipHashKey -> Ptr Word8 -> Int -> IO (SipHash c d)
sipHashCD
{-# INLINE sipHash24 #-}

-- | SipHash-1-3
--
-- The first and second argument is the 128 bit key, represented as two 64 bit
-- words.
--
sipHash13 :: SipHashKey -> Ptr Word8 -> Int -> IO (SipHash 1 3)
sipHash13 :: SipHashKey -> Ptr Word8 -> Int -> IO (SipHash 1 3)
sipHash13 = SipHashKey -> Ptr Word8 -> Int -> IO (SipHash 1 3)
forall (c :: Nat) (d :: Nat).
(SipHashParam c, SipHashParam d) =>
SipHashKey -> Ptr Word8 -> Int -> IO (SipHash c d)
sipHashCD
{-# INLINE sipHash13 #-}

-- | SipHash-4-8
--
-- The first and second argument is the 128 bit key, represented as two 64 bit
-- words.
--
sipHash48 :: SipHashKey -> Ptr Word8 -> Int -> IO (SipHash 4 8)
sipHash48 :: SipHashKey -> Ptr Word8 -> Int -> IO (SipHash 4 8)
sipHash48 = SipHashKey -> Ptr Word8 -> Int -> IO (SipHash 4 8)
forall (c :: Nat) (d :: Nat).
(SipHashParam c, SipHashParam d) =>
SipHashKey -> Ptr Word8 -> Int -> IO (SipHash c d)
sipHashCD
{-# INLINE sipHash48 #-}

-- -------------------------------------------------------------------------- --
-- Class

instance (SipHashParam c, SipHashParam d) => IncrementalHash (SipHash c d) where
    type Context (SipHash c d) = SipHashContext c d
    update :: Context (SipHash c d)
-> Ptr Word8 -> Int -> IO (Context (SipHash c d))
update = Context (SipHash c d)
-> Ptr Word8 -> Int -> IO (Context (SipHash c d))
forall (c :: Nat) (d :: Nat).
SipHashParam c =>
SipHashContext c d -> Ptr Word8 -> Int -> IO (SipHashContext c d)
sipHashUpdate
    finalize :: Context (SipHash c d) -> SipHash c d
finalize = Context (SipHash c d) -> SipHash c d
forall (c :: Nat) (d :: Nat).
(SipHashParam c, SipHashParam d) =>
SipHashContext c d -> SipHash c d
sipHashFinalize

    {-# INLINE update #-}
    {-# INLINE finalize #-}

instance (SipHashParam c, SipHashParam d) => Hash (SipHash c d) where
    type Salt (SipHash c d) = SipHashKey
    initialize :: Salt (SipHash c d) -> Context (SipHash c d)
initialize = Salt (SipHash c d) -> Context (SipHash c d)
forall (c :: Nat) (d :: Nat). SipHashKey -> SipHashContext c d
sipHashInitialize
    {-# INLINE initialize #-}

-- -------------------------------------------------------------------------- --
-- Incremental Version of SipHash

-- | SipHash with @c@ compression rounds and @d@ finalization rounds.
--
-- cf. http://cr.yp.to/siphash/siphash-20120918.pdf
--
newtype SipHash (c :: Nat) (d :: Nat) = SipHash Word64
    deriving (Int -> SipHash c d -> ShowS
[SipHash c d] -> ShowS
SipHash c d -> String
(Int -> SipHash c d -> ShowS)
-> (SipHash c d -> String)
-> ([SipHash c d] -> ShowS)
-> Show (SipHash c d)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall (c :: Nat) (d :: Nat). Int -> SipHash c d -> ShowS
forall (c :: Nat) (d :: Nat). [SipHash c d] -> ShowS
forall (c :: Nat) (d :: Nat). SipHash c d -> String
showList :: [SipHash c d] -> ShowS
$cshowList :: forall (c :: Nat) (d :: Nat). [SipHash c d] -> ShowS
show :: SipHash c d -> String
$cshow :: forall (c :: Nat) (d :: Nat). SipHash c d -> String
showsPrec :: Int -> SipHash c d -> ShowS
$cshowsPrec :: forall (c :: Nat) (d :: Nat). Int -> SipHash c d -> ShowS
Show, SipHash c d -> SipHash c d -> Bool
(SipHash c d -> SipHash c d -> Bool)
-> (SipHash c d -> SipHash c d -> Bool) -> Eq (SipHash c d)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall (c :: Nat) (d :: Nat). SipHash c d -> SipHash c d -> Bool
/= :: SipHash c d -> SipHash c d -> Bool
$c/= :: forall (c :: Nat) (d :: Nat). SipHash c d -> SipHash c d -> Bool
== :: SipHash c d -> SipHash c d -> Bool
$c== :: forall (c :: Nat) (d :: Nat). SipHash c d -> SipHash c d -> Bool
Eq, Eq (SipHash c d)
Eq (SipHash c d)
-> (SipHash c d -> SipHash c d -> Ordering)
-> (SipHash c d -> SipHash c d -> Bool)
-> (SipHash c d -> SipHash c d -> Bool)
-> (SipHash c d -> SipHash c d -> Bool)
-> (SipHash c d -> SipHash c d -> Bool)
-> (SipHash c d -> SipHash c d -> SipHash c d)
-> (SipHash c d -> SipHash c d -> SipHash c d)
-> Ord (SipHash c d)
SipHash c d -> SipHash c d -> Bool
SipHash c d -> SipHash c d -> Ordering
SipHash c d -> SipHash c d -> SipHash c d
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
forall (c :: Nat) (d :: Nat). Eq (SipHash c d)
forall (c :: Nat) (d :: Nat). SipHash c d -> SipHash c d -> Bool
forall (c :: Nat) (d :: Nat).
SipHash c d -> SipHash c d -> Ordering
forall (c :: Nat) (d :: Nat).
SipHash c d -> SipHash c d -> SipHash c d
min :: SipHash c d -> SipHash c d -> SipHash c d
$cmin :: forall (c :: Nat) (d :: Nat).
SipHash c d -> SipHash c d -> SipHash c d
max :: SipHash c d -> SipHash c d -> SipHash c d
$cmax :: forall (c :: Nat) (d :: Nat).
SipHash c d -> SipHash c d -> SipHash c d
>= :: SipHash c d -> SipHash c d -> Bool
$c>= :: forall (c :: Nat) (d :: Nat). SipHash c d -> SipHash c d -> Bool
> :: SipHash c d -> SipHash c d -> Bool
$c> :: forall (c :: Nat) (d :: Nat). SipHash c d -> SipHash c d -> Bool
<= :: SipHash c d -> SipHash c d -> Bool
$c<= :: forall (c :: Nat) (d :: Nat). SipHash c d -> SipHash c d -> Bool
< :: SipHash c d -> SipHash c d -> Bool
$c< :: forall (c :: Nat) (d :: Nat). SipHash c d -> SipHash c d -> Bool
compare :: SipHash c d -> SipHash c d -> Ordering
$ccompare :: forall (c :: Nat) (d :: Nat).
SipHash c d -> SipHash c d -> Ordering
$cp1Ord :: forall (c :: Nat) (d :: Nat). Eq (SipHash c d)
Ord)

-- | The 'Word46' constructor parameters represent the 128 bit key in little
-- endian encoding.
--
data SipHashKey = SipHashKey {-# UNPACK #-} !Word64 {-# UNPACK #-} !Word64
    deriving (Int -> SipHashKey -> ShowS
[SipHashKey] -> ShowS
SipHashKey -> String
(Int -> SipHashKey -> ShowS)
-> (SipHashKey -> String)
-> ([SipHashKey] -> ShowS)
-> Show SipHashKey
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SipHashKey] -> ShowS
$cshowList :: [SipHashKey] -> ShowS
show :: SipHashKey -> String
$cshow :: SipHashKey -> String
showsPrec :: Int -> SipHashKey -> ShowS
$cshowsPrec :: Int -> SipHashKey -> ShowS
Show, SipHashKey -> SipHashKey -> Bool
(SipHashKey -> SipHashKey -> Bool)
-> (SipHashKey -> SipHashKey -> Bool) -> Eq SipHashKey
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SipHashKey -> SipHashKey -> Bool
$c/= :: SipHashKey -> SipHashKey -> Bool
== :: SipHashKey -> SipHashKey -> Bool
$c== :: SipHashKey -> SipHashKey -> Bool
Eq, Eq SipHashKey
Eq SipHashKey
-> (SipHashKey -> SipHashKey -> Ordering)
-> (SipHashKey -> SipHashKey -> Bool)
-> (SipHashKey -> SipHashKey -> Bool)
-> (SipHashKey -> SipHashKey -> Bool)
-> (SipHashKey -> SipHashKey -> Bool)
-> (SipHashKey -> SipHashKey -> SipHashKey)
-> (SipHashKey -> SipHashKey -> SipHashKey)
-> Ord SipHashKey
SipHashKey -> SipHashKey -> Bool
SipHashKey -> SipHashKey -> Ordering
SipHashKey -> SipHashKey -> SipHashKey
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 :: SipHashKey -> SipHashKey -> SipHashKey
$cmin :: SipHashKey -> SipHashKey -> SipHashKey
max :: SipHashKey -> SipHashKey -> SipHashKey
$cmax :: SipHashKey -> SipHashKey -> SipHashKey
>= :: SipHashKey -> SipHashKey -> Bool
$c>= :: SipHashKey -> SipHashKey -> Bool
> :: SipHashKey -> SipHashKey -> Bool
$c> :: SipHashKey -> SipHashKey -> Bool
<= :: SipHashKey -> SipHashKey -> Bool
$c<= :: SipHashKey -> SipHashKey -> Bool
< :: SipHashKey -> SipHashKey -> Bool
$c< :: SipHashKey -> SipHashKey -> Bool
compare :: SipHashKey -> SipHashKey -> Ordering
$ccompare :: SipHashKey -> SipHashKey -> Ordering
$cp1Ord :: Eq SipHashKey
Ord)

-- | Internal mutable SipHashContext.
--
-- The first four arguments are the internal state values \(v_{0..3}\) and the
-- last argument represents the pending bytes from an incomplete word of the
-- last chunk of input.
--
data SipHashContext (c :: Nat) (d :: Nat) = SipHashContext
    {-# UNPACK #-} !Word64
    {-# UNPACK #-} !Word64
    {-# UNPACK #-} !Word64
    {-# UNPACK #-} !Word64
    {-# UNPACK #-} !Word64
        -- ^ the most significant byte keeps track of the total number of input
        -- bytes modulo 256. The remaining bytes are the currently pending input
        -- bytes (i.e. the last \(totalInput `mod` 8\) many bytes of the input).

-- | Initialize a new SipHashContext
--
sipHashInitialize :: SipHashKey -> SipHashContext c d
sipHashInitialize :: SipHashKey -> SipHashContext c d
sipHashInitialize (SipHashKey Word64
k0 Word64
k1) = Word64
-> Word64 -> Word64 -> Word64 -> Word64 -> SipHashContext c d
forall (c :: Nat) (d :: Nat).
Word64
-> Word64 -> Word64 -> Word64 -> Word64 -> SipHashContext c d
SipHashContext
    (Word64
0x736f6d6570736575 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
k0)
    (Word64
0x646f72616e646f6d Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
k1)
    (Word64
0x6c7967656e657261 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
k0)
    (Word64
0x7465646279746573 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
k1)
    Word64
0x0
{-# INLINE sipHashInitialize #-}

-- | Incrementally add input bytes to an SipHash computation and update
-- the internal context.
--
sipHashUpdate
    :: forall (c :: Nat) (d :: Nat)
    . SipHashParam c
    => SipHashContext c d
    -> Ptr Word8
    -> Int
    -> IO (SipHashContext c d)
sipHashUpdate :: SipHashContext c d -> Ptr Word8 -> Int -> IO (SipHashContext c d)
sipHashUpdate (SipHashContext Word64
s0 Word64
s1 Word64
s2 Word64
s3 Word64
r) Ptr Word8
ptr8 Int
len
    | Word64
0 <- Word64
rlen Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`rem` Word64
8 = Word64
-> Word64
-> Word64
-> Word64
-> Ptr Word64
-> Word64
-> IO (SipHashContext c d)
loop Word64
s0 Word64
s1 Word64
s2 Word64
s3 Ptr Word64
ptr64 Word64
len64

    -- Consume the first input word using any possibly pending input bytes from
    -- previous updates.
    --
    | Word64
a <- Word64
rlen Word64 -> Word64 -> Word64
forall a. Integral a => a -> a -> a
`rem` Word64
8 = do
        let !missing :: Word64
missing = Word64
8 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
a

        -- get enough bytes to fill up next word (if there are less than 8 - a
        -- bytes the most significant bytes are set to 0)
        !Word64
m <- Ptr Word64 -> Word64 -> IO Word64
ptrToWord64 Ptr Word64
ptr64 (Word64 -> IO Word64) -> Word64 -> IO Word64
forall a b. (a -> b) -> a -> b
$ Word64 -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
missing

        -- add new bytes to get full word64. Input is parsed as little endian,
        -- so new bytes are more significant than pending bytes.
        let !m' :: Word64
m' = (Word64
0x00ffffffffffffff Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
r {- pending bytes -}) Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
m

        if Word64
len64 Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
missing
          then
            -- nothing left to do
            SipHashContext c d -> IO (SipHashContext c d)
forall (m :: * -> *) a. Monad m => a -> m a
return (SipHashContext c d -> IO (SipHashContext c d))
-> SipHashContext c d -> IO (SipHashContext c d)
forall a b. (a -> b) -> a -> b
$ Word64
-> Word64 -> Word64 -> Word64 -> Word64 -> SipHashContext c d
forall (c :: Nat) (d :: Nat).
Word64
-> Word64 -> Word64 -> Word64 -> Word64 -> SipHashContext c d
SipHashContext Word64
s0 Word64
s1 Word64
s2 Word64
s3 (Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftL (Word64
rlen Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
len64) Int
56 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
m')
          else do
            -- compute c round with first word
            let (# Word64
v0', Word64
v1', Word64
v2', Word64
v3' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
forall (n :: Nat).
SipHashParam n =>
Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds @c Word64
s0 Word64
s1 Word64
s2 (Word64
s3 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
m')
            Word64
-> Word64
-> Word64
-> Word64
-> Ptr Word64
-> Word64
-> IO (SipHashContext c d)
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
ptr64 (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
missing)) (Word64
len64 Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
missing)
  where
    len64 :: Word64
len64 = Int -> Word64
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
len
    {-# INLINE len64 #-}

    !ptr64 :: Ptr Word64
ptr64 = Ptr Word8 -> Ptr Word64
forall a b. Ptr a -> Ptr b
castPtr Ptr Word8
ptr8
    {-# INLINE ptr64 #-}

    !rlen :: Word64
rlen = Word64
0xff00000000000000 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.&. Word64
r
    {-# INLINE rlen #-}


    -- Assumes that there are no pending bytes.
    loop :: Word64
-> Word64
-> Word64
-> Word64
-> Ptr Word64
-> Word64
-> IO (SipHashContext c d)
loop !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 !Ptr Word64
p !Word64
l
        | Word64
l Word64 -> Word64 -> Bool
forall a. Ord a => a -> a -> Bool
< Word64
8 = do
            !Word64
m <- Ptr Word64 -> Word64 -> IO Word64
ptrToWord64 Ptr Word64
p Word64
l
            SipHashContext c d -> IO (SipHashContext c d)
forall (m :: * -> *) a. Monad m => a -> m a
return (SipHashContext c d -> IO (SipHashContext c d))
-> SipHashContext c d -> IO (SipHashContext c d)
forall a b. (a -> b) -> a -> b
$ Word64
-> Word64 -> Word64 -> Word64 -> Word64 -> SipHashContext c d
forall (c :: Nat) (d :: Nat).
Word64
-> Word64 -> Word64 -> Word64 -> Word64 -> SipHashContext c d
SipHashContext Word64
v0 Word64
v1 Word64
v2 Word64
v3 (Word64 -> Int -> Word64
forall a. Bits a => a -> Int -> a
shiftL (Word64
rlen Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
+ Word64
len64) Int
56 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
.|. Word64
m)
        | Bool
otherwise = do
            -- TODO enforce little endian encoding
            !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' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
forall (n :: Nat).
SipHashParam n =>
Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds @c 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
-> Word64
-> IO (SipHashContext c d)
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) (Word64
l Word64 -> Word64 -> Word64
forall a. Num a => a -> a -> a
- Word64
8)
    {-# INLINE loop #-}
{-# INLINE sipHashUpdate #-}

sipHashFinalize
    :: forall (c :: Nat) (d :: Nat)
    . SipHashParam c
    => SipHashParam d
    => SipHashContext c d
    -> SipHash c d
sipHashFinalize :: SipHashContext c d -> SipHash c d
sipHashFinalize (SipHashContext Word64
v0 Word64
v1 Word64
v2 Word64
v3 Word64
m) =
    Word64 -> SipHash c d
forall (c :: Nat) (d :: Nat). Word64 -> SipHash c d
SipHash (Word64 -> SipHash c d) -> Word64 -> SipHash c d
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
    (# !Word64
v0', !Word64
v1', !Word64
v2', !Word64
v3' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
forall (n :: Nat).
SipHashParam n =>
Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds @c Word64
v0 Word64
v1 Word64
v2 (Word64
v3 Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
m)
    (# !Word64
v0'', !Word64
v1'', !Word64
v2'', !Word64
v3'' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
forall (n :: Nat).
SipHashParam n =>
Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds @d (Word64
v0' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
m) Word64
v1' (Word64
v2' Word64 -> Word64 -> Word64
forall a. Bits a => a -> a -> a
`xor` Word64
0xff) Word64
v3'
{-# INLINE sipHashFinalize #-}

ptrToWord64 :: Ptr Word64 -> Word64 -> IO Word64
ptrToWord64 :: Ptr Word64 -> Word64 -> IO Word64
ptrToWord64 Ptr Word64
_ Word64
0 = Word64 -> IO Word64
forall (f :: * -> *) a. Applicative f => a -> f a
pure Word64
0
ptrToWord64 !Ptr Word64
p Word64
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 Word64
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 Word64
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 !Word64
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 (Word64 -> Int
forall a b. (Integral a, Num b) => a -> b
fromIntegral Word64
i)
    Ptr Word64 -> IO Word64
forall a. Storable a => Ptr a -> IO a
peek Ptr Word64
p'
{-# INLINE ptrToWord64 #-}

class SipHashParam (n :: Nat) where
    rounds :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)

instance SipHashRounds n (SlowRounds n) => SipHashParam (n :: Nat) where
    rounds :: Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds = SipHashRounds n (SlowRounds n) =>
Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
forall (n :: Nat) (x :: Bool).
SipHashRounds n x =>
Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ @n @(SlowRounds n)
    {-# INLINE rounds #-}

-- -------------------------------------------------------------------------- --
-- SipHash Rounds

-- Decide wether to pick an fast specialized routes implementation or a somewhat
-- less efficient generic implementation.
--
type SlowRounds r = CmpNat r 8 == 'GT

-- TODO: create benchmark to check how well inlining works for recursive type class function calls,
-- It's possibly, that we don't need all these specializations but inlining gets the job done all by
-- itself.

class SipHashRounds (n :: Nat) (x :: Bool) where
    rounds_ :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)

instance SipHashRounds 1 'False where
    rounds_ :: Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0 Word64
v1 Word64
v2 Word64
v3
    {-# INLINE rounds_ #-}

instance SipHashRounds 2 'False where
    rounds_ :: Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 =
        let (# !Word64
v0', !Word64
v1', !Word64
v2', !Word64
v3' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0 Word64
v1 Word64
v2 Word64
v3
        in Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0' Word64
v1' Word64
v2' Word64
v3'
    {-# INLINE rounds_ #-}

instance SipHashRounds 3 'False where
    rounds_ :: Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 =
        let (# !Word64
v0', !Word64
v1', !Word64
v2', !Word64
v3' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0 Word64
v1 Word64
v2 Word64
v3
            (# !Word64
v0'', !Word64
v1'', !Word64
v2'', !Word64
v3'' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0' Word64
v1' Word64
v2' Word64
v3'
        in Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0'' Word64
v1'' Word64
v2'' Word64
v3''
    {-# INLINE rounds_ #-}

instance SipHashRounds 4 'False where
    rounds_ :: Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 =
        let (# !Word64
v0', !Word64
v1', !Word64
v2', !Word64
v3' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0 Word64
v1 Word64
v2 Word64
v3
            (# !Word64
v0'', !Word64
v1'', !Word64
v2'', !Word64
v3'' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0' Word64
v1' Word64
v2' Word64
v3'
            (# !Word64
v0''', !Word64
v1''', !Word64
v2''', !Word64
v3''' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0'' Word64
v1'' Word64
v2'' Word64
v3''
        in Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0''' Word64
v1''' Word64
v2''' Word64
v3'''
    {-# INLINE rounds_ #-}

instance SipHashRounds 5 'False where
    rounds_ :: Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 = case Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
forall (n :: Nat) (x :: Bool).
SipHashRounds n x =>
Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ @4 @'False Word64
v0 Word64
v1 Word64
v2 Word64
v3 of
        (# Word64
v0', Word64
v1', Word64
v2', Word64
v3' #) -> Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
forall (n :: Nat) (x :: Bool).
SipHashRounds n x =>
Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ @1 @'False Word64
v0' Word64
v1' Word64
v2' Word64
v3'
    {-# INLINE rounds_ #-}

instance SipHashRounds 6 'False where
    rounds_ :: Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 = case Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
forall (n :: Nat) (x :: Bool).
SipHashRounds n x =>
Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ @4 @'False Word64
v0 Word64
v1 Word64
v2 Word64
v3 of
        (# Word64
v0', Word64
v1', Word64
v2', Word64
v3' #) -> Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
forall (n :: Nat) (x :: Bool).
SipHashRounds n x =>
Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ @2 @'False Word64
v0' Word64
v1' Word64
v2' Word64
v3'
    {-# INLINE rounds_ #-}

instance SipHashRounds 7 'False where
    rounds_ :: Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 = case Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
forall (n :: Nat) (x :: Bool).
SipHashRounds n x =>
Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ @4 @'False Word64
v0 Word64
v1 Word64
v2 Word64
v3 of
        (# Word64
v0', Word64
v1', Word64
v2', Word64
v3' #) -> Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
forall (n :: Nat) (x :: Bool).
SipHashRounds n x =>
Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ @3 @'False Word64
v0' Word64
v1' Word64
v2' Word64
v3'
    {-# INLINE rounds_ #-}

instance SipHashRounds 8 'False where
    rounds_ :: Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 =
        let (# !Word64
v0', !Word64
v1', !Word64
v2', !Word64
v3' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0 Word64
v1 Word64
v2 Word64
v3
            (# !Word64
v0'', !Word64
v1'', !Word64
v2'', !Word64
v3'' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0' Word64
v1' Word64
v2' Word64
v3'
            (# !Word64
v0''', !Word64
v1''', !Word64
v2''', !Word64
v3''' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0'' Word64
v1'' Word64
v2'' Word64
v3''
            (# !Word64
v0'''', !Word64
v1'''', !Word64
v2'''', !Word64
v3'''' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0''' Word64
v1''' Word64
v2''' Word64
v3'''
            (# !Word64
v0''''', !Word64
v1''''', !Word64
v2''''', !Word64
v3''''' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0'''' Word64
v1'''' Word64
v2'''' Word64
v3''''
            (# !Word64
v0'''''', !Word64
v1'''''', !Word64
v2'''''', !Word64
v3'''''' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0''''' Word64
v1''''' Word64
v2''''' Word64
v3'''''
            (# !Word64
v0''''''', !Word64
v1''''''', !Word64
v2''''''', !Word64
v3''''''' #) = Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0'''''' Word64
v1'''''' Word64
v2'''''' Word64
v3''''''
        in Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
sipRound Word64
v0''''''' Word64
v1''''''' Word64
v2''''''' Word64
v3'''''''
    {-# INLINE rounds_ #-}

instance ((CmpNat n 8 == 'GT) ~ 'True, SipHashRounds (n-8) t) => SipHashRounds n 'True where
    rounds_ :: Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ !Word64
v0 !Word64
v1 !Word64
v2 !Word64
v3 = case Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
forall (n :: Nat) (x :: Bool).
SipHashRounds n x =>
Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ @8 @'False Word64
v0 Word64
v1 Word64
v2 Word64
v3 of
        (# Word64
v0', Word64
v1', Word64
v2', Word64
v3' #) -> Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
forall (n :: Nat) (x :: Bool).
SipHashRounds n x =>
Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
rounds_ @(n - 8) @t Word64
v0' Word64
v1' Word64
v2' Word64
v3'
    {-# INLINE rounds_ #-}

sipRound :: Word64 -> Word64 -> Word64 -> Word64 -> (# Word64, Word64, Word64, Word64 #)
sipRound :: Word64
-> Word64
-> Word64
-> Word64
-> (# Word64, Word64, Word64, Word64 #)
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 #-}