    -- |
    -- 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
    (Int -> SipHash -> ShowS)
    -> (SipHash -> String) -> ([SipHash] -> ShowS) -> Show SipHash
    forall a.
    (Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
    $cshowsPrec :: Int -> SipHash -> ShowS
    showsPrec :: Int -> SipHash -> ShowS
    $cshow :: SipHash -> String
    show :: SipHash -> String
    $cshowList :: [SipHash] -> ShowS
    showList :: [SipHash] -> ShowS
    Show,SipHash -> SipHash -> Bool
    (SipHash -> SipHash -> Bool)
    -> (SipHash -> SipHash -> Bool) -> Eq SipHash
    forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
    $c== :: SipHash -> SipHash -> Bool
    == :: SipHash -> SipHash -> Bool
    $c/= :: SipHash -> SipHash -> Bool
    /= :: SipHash -> SipHash -> Bool
    Eq,Eq SipHash
    Eq SipHash =>
    (SipHash -> SipHash -> Ordering)
    -> (SipHash -> SipHash -> Bool)
    -> (SipHash -> SipHash -> Bool)
    -> (SipHash -> SipHash -> Bool)
    -> (SipHash -> SipHash -> Bool)
    -> (SipHash -> SipHash -> SipHash)
    -> (SipHash -> SipHash -> SipHash)
    -> Ord 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
    $ccompare :: SipHash -> SipHash -> Ordering
    compare :: SipHash -> SipHash -> Ordering
    $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
    >= :: SipHash -> SipHash -> Bool
    $cmax :: SipHash -> SipHash -> SipHash
    max :: SipHash -> SipHash -> SipHash
    $cmin :: SipHash -> SipHash -> SipHash
    min :: SipHash -> SipHash -> SipHash
    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 = InternalState -> Ptr Word8 -> Int -> IO SipHash
    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 a -> a -> Bool
    forall a. Ord a => a -> a -> Bool
    > a
    7     = Ptr (LE Word64) -> IO (LE Word64)
    forall a. Storable a => Ptr a -> IO a
    peek (Ptr b -> Ptr (LE Word64)
    forall a b. Ptr a -> Ptr b
    castPtr Ptr b
    ptr) IO (LE Word64) -> (LE Word64 -> IO SipHash) -> IO SipHash
    forall a b. IO a -> (a -> IO b) -> IO b
    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 (LE Word64 -> Word64
    forall a. ByteSwap a => LE a -> a
    fromLE LE Word64
    v)) (Ptr b
    ptr Ptr b -> Int -> Ptr b
    forall a b. Ptr a -> Int -> Ptr b
    `plusPtr` Int
    8) (a
    la -> a -> a
    forall a. Num a => a -> a -> a
    -a
    8)
                | Bool
    otherwise = do
                    let !lengthBlock :: Word64
    lengthBlock = (Int -> Word64
    forall a b. (Integral a, Num b) => a -> b
    fromIntegral Int
    totalLen Word64 -> Word64 -> Word64
    forall a. Integral a => a -> a -> a
    `mod` Word64
    256) Word64 -> Int -> Word64
    forall a. Bits a => a -> Int -> a
    `unsafeShiftL` Int
    56
                    (InternalState -> SipHash
    finish (InternalState -> SipHash)
    -> (Word64 -> InternalState) -> Word64 -> SipHash
    forall b c a. (b -> c) -> (a -> b) -> a -> c
    . InternalState -> Word64 -> InternalState
    process InternalState
    st) (Word64 -> SipHash) -> IO Word64 -> IO SipHash
    forall a b. (a -> b) -> IO a -> IO b
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
    `fmap` case a
    l of
                        a
    0 -> do Word64 -> IO Word64
    forall a. a -> IO a
    forall (m :: * -> *) a. Monad m => a -> m a
    return Word64
    lengthBlock
                        a
    1 -> do v0 <- Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    0
                                return (lengthBlock .|. to64 v0)
                        a
    2 -> do (v0,v1) <- (Word8 -> Word8 -> (Word8, Word8))
    -> IO Word8 -> IO Word8 -> IO (Word8, Word8)
    forall (m :: * -> *) a1 a2 r.
    Monad m =>
    (a1 -> a2 -> r) -> m a1 -> m a2 -> m r
    liftM2 (,) (Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    0) (Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    1)
                                return (lengthBlock
                                        .|. (to64 v1 `unsafeShiftL` 8)
                                        .|. to64 v0)
                        a
    3 -> do (v0,v1,v2) <- (Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8))
    -> IO Word8 -> IO Word8 -> IO Word8 -> IO (Word8, Word8, Word8)
    forall (m :: * -> *) a1 a2 a3 r.
    Monad m =>
    (a1 -> a2 -> a3 -> r) -> m a1 -> m a2 -> m a3 -> m r
    liftM3 (,,) (Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    0) (Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    1) (Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    2)
                                return (    lengthBlock
                                        .|. (to64 v2 `unsafeShiftL` 16)
                                        .|. (to64 v1 `unsafeShiftL` 8)
                                        .|. to64 v0)
                        a
    4 -> do (v0,v1,v2,v3) <- (Word8 -> Word8 -> Word8 -> Word8 -> (Word8, Word8, Word8, Word8))
    -> IO Word8
    -> IO Word8
    -> IO Word8
    -> IO Word8
    -> IO (Word8, Word8, Word8, Word8)
    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 (,,,) (Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    0) (Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    1) (Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    2)
                                                              (Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    3)
                                return (    lengthBlock
                                        .|. (to64 v3 `unsafeShiftL` 24)
                                        .|. (to64 v2 `unsafeShiftL` 16)
                                        .|. (to64 v1 `unsafeShiftL` 8)
                                        .|. to64 v0)
                        a
    5 -> do (v0,v1,v2,v3,v4) <- (Word8
     -> Word8
     -> Word8
     -> Word8
     -> Word8
     -> (Word8, Word8, Word8, Word8, Word8))
    -> IO Word8
    -> IO Word8
    -> IO Word8
    -> IO Word8
    -> IO Word8
    -> IO (Word8, Word8, Word8, Word8, Word8)
    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 (,,,,) (Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    0) (Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    1) (Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    2)
                                                                  (Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    3) (Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    4)
                                return (    lengthBlock
                                        .|. (to64 v4 `unsafeShiftL` 32)
                                        .|. (to64 v3 `unsafeShiftL` 24)
                                        .|. (to64 v2 `unsafeShiftL` 16)
                                        .|. (to64 v1 `unsafeShiftL` 8)
                                        .|. to64 v0)
                        a
    6 -> do v0 <- Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    0
                                v1 <- peekByteOff ptr 1
                                v2 <- peekByteOff ptr 2
                                v3 <- peekByteOff ptr 3
                                v4 <- peekByteOff ptr 4
                                v5 <- peekByteOff ptr 5
                                return (    lengthBlock
                                        .|. (to64 v5 `unsafeShiftL` 40)
                                        .|. (to64 v4 `unsafeShiftL` 32)
                                        .|. (to64 v3 `unsafeShiftL` 24)
                                        .|. (to64 v2 `unsafeShiftL` 16)
                                        .|. (to64 v1 `unsafeShiftL` 8)
                                        .|. to64 v0)
                        a
    7 -> do v0 <- Ptr b -> Int -> IO Word8
    forall b. Ptr b -> Int -> IO Word8
    forall a b. Storable a => Ptr b -> Int -> IO a
    peekByteOff Ptr b
    ptr Int
    0
                                v1 <- peekByteOff ptr 1
                                v2 <- peekByteOff ptr 2
                                v3 <- peekByteOff ptr 3
                                v4 <- peekByteOff ptr 4
                                v5 <- peekByteOff ptr 5
                                v6 <- peekByteOff ptr 6
                                return (    lengthBlock
                                        .|. (to64 v6 `unsafeShiftL` 48)
                                        .|. (to64 v5 `unsafeShiftL` 40)
                                        .|. (to64 v4 `unsafeShiftL` 32)
                                        .|. (to64 v3 `unsafeShiftL` 24)
                                        .|. (to64 v2 `unsafeShiftL` 16)
                                        .|. (to64 v1 `unsafeShiftL` 8)
                                        .|. to64 v0)
                        a
    _ -> String -> IO Word64
    forall a. HasCallStack => String -> a
    error String
    "siphash: internal error: cannot happens"

            {-# INLINE to64 #-}
            to64 :: Word8 -> Word64
            to64 :: Word8 -> Word64
    to64 = Word8 -> Word64
    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 (InternalState -> InternalState) -> InternalState -> InternalState
    forall a b. (a -> b) -> a -> b
    $! InternalState -> InternalState
    runRoundsCompression (InternalState -> InternalState) -> InternalState -> InternalState
    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 Word64 -> Word64 -> Word64
    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 Word64 -> Word64 -> Word64
    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 (InternalState -> SipHash) -> InternalState -> SipHash
    forall a b. (a -> b) -> a -> b
    $! InternalState -> InternalState
    runRoundsDigest (InternalState -> InternalState) -> InternalState -> InternalState
    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 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)
                      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 -> Word64 -> Word64
    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 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
                   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 Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    2    = InternalState -> InternalState
    doRound (InternalState -> InternalState) -> InternalState -> InternalState
    forall a b. (a -> b) -> a -> b
    $! InternalState -> InternalState
    doRound InternalState
    st
                | Bool
    otherwise = Int -> InternalState -> InternalState
    forall {t}. (Eq t, Num t) => t -> InternalState -> InternalState
    loopRounds Int
    c InternalState
    st

            {-# INLINE runRoundsDigest #-}
            runRoundsDigest :: InternalState -> InternalState
    runRoundsDigest InternalState
    st
                | Int
    d Int -> Int -> Bool
    forall a. Eq a => a -> a -> Bool
    == Int
    4    = InternalState -> InternalState
    doRound (InternalState -> InternalState) -> InternalState -> InternalState
    forall a b. (a -> b) -> a -> b
    $! InternalState -> InternalState
    doRound (InternalState -> InternalState) -> InternalState -> InternalState
    forall a b. (a -> b) -> a -> b
    $! InternalState -> InternalState
    doRound (InternalState -> InternalState) -> InternalState -> InternalState
    forall a b. (a -> b) -> a -> b
    $! InternalState -> InternalState
    doRound InternalState
    st
                | Bool
    otherwise = Int -> InternalState -> InternalState
    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
    nt -> t -> t
    forall 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 Word64 -> Word64 -> Word64
    forall a. Bits a => a -> a -> a
    `xor` Word64
    0x736f6d6570736575)
                                                   (Word64
    k1 Word64 -> Word64 -> Word64
    forall a. Bits a => a -> a -> a
    `xor` Word64
    0x646f72616e646f6d)
                                                   (Word64
    k0 Word64 -> Word64 -> Word64
    forall a. Bits a => a -> a -> a
    `xor` Word64
    0x6c7967656e657261)
                                                   (Word64
    k1 Word64 -> Word64 -> Word64
    forall a. Bits a => a -> a -> a
    `xor` Word64
    0x7465646279746573)