{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-}

-- |
-- Module     : Data.Hash.SL2
-- License    : MIT
-- Maintainer : Sam Rijs <srijs@airpost.net>
--
-- An algebraic hash function, inspired by the paper "Hashing with SL2" by
-- Tillich and Zemor.
--
-- The hash function is based on matrix multiplication in the special linear group
-- of degree 2, over a Galois field of order 2^127,  with all computations modulo
-- the polynomial x^127 + x^63 + 1.
--
-- This construction gives some nice properties, which traditional "bit-scambling"
-- hash functions don't possess, including it being composable. It holds:
--
-- prop> hash (m1 <> m2) == hash m1 <> hash m2
--
-- All operations in this package are implemented in a very efficient manner using SSE instructions.
--

module Data.Hash.SL2 (Hash, hash, (<+), (+>), (<|), (|>), parse) where

import Prelude hiding (concat)

import Foreign
import Foreign.Ptr
import Foreign.C.Types
import Foreign.C.String
import Foreign.Marshal.Array
import Foreign.Marshal.Utils
import Foreign.ForeignPtr
import System.IO.Unsafe

import Data.ByteString (ByteString)
import Data.ByteString.Unsafe

import Data.Monoid
import Data.Functor
import Data.Foldable

-- Foreign Imports

foreign import ccall "tillich-zemor.h tz_hash_eq"
  tzHashEq :: Ptr () -> Ptr () -> IO CInt

foreign import ccall "tillich-zemor.h tz_hash_unit"
  tzHashUnit :: Ptr () -> IO ()

foreign import ccall "tillich-zemor.h tz_hash_append"
  tzHashAppend :: Ptr () -> Ptr CChar -> CSize -> IO ()

foreign import ccall "tillich-zemor.h tz_hash_prepend"
  tzHashPrepend :: Ptr () -> Ptr CChar -> CSize -> IO ()

foreign import ccall "tillich-zemor.h tz_hash_concat"
  tzHashConcat :: Ptr () -> Ptr () -> Ptr () -> IO ()

foreign import ccall "tillich-zemor.h tz_hash_serialize"
  tzHashSerialize :: Ptr () -> Ptr CChar -> IO ()

foreign import ccall "tillich-zemor.h tz_hash_unserialize"
  tzHashUnserialize :: Ptr () -> Ptr CChar -> IO ()

-- Mutable Helpers

append :: ByteString -> Ptr () -> IO ()
append s p = unsafeUseAsCStringLen s $ \(s', len) -> tzHashAppend p s' (fromIntegral len)

prepend :: ByteString -> Ptr () -> IO ()
prepend s p = unsafeUseAsCStringLen s $ \(s', len) -> tzHashPrepend p s' (fromIntegral len)

-- | Opaque representation of a 512 bit hash.
newtype Hash = H (ForeignPtr ())

-- Foreign Pointer Helpers

tzHashSize = 64
tzHashLen = 86

withHashPtr :: Hash -> (Ptr () -> IO a) -> IO a
withHashPtr (H fp) = withForeignPtr fp

withHashPtr2 :: Hash -> Hash -> (Ptr () -> Ptr () -> IO a) -> IO a
withHashPtr2 a b f = withHashPtr a (withHashPtr b . f)

withHashPtrNew :: (Ptr () -> IO a) -> IO (Hash, a)
withHashPtrNew f = mallocForeignPtrBytes tzHashSize >>= \fp -> (\r -> (H fp, r)) <$> withForeignPtr fp f

withHashPtrCopy :: Hash -> (Ptr () -> IO a) -> IO (Hash, a)
withHashPtrCopy h f = withHashPtr h $ \hp -> withHashPtrNew $ \hp' -> copyBytes hp' hp tzHashSize >> f hp'

-- Instances

instance Show Hash where
  show h = unsafePerformIO $ allocaBytes tzHashLen $ \p -> withHashPtr h (flip tzHashSerialize p) >> peekCStringLen (p, tzHashLen)

instance Eq Hash where
  a == b = toBool $ unsafePerformIO $ withHashPtr2 a b tzHashEq

instance Monoid Hash where
  mempty = fst $ unsafePerformIO $ withHashPtrNew tzHashUnit
  mappend a b = fst $ unsafePerformIO $ withHashPtrNew (withHashPtr2 a b . tzHashConcat)

-- Interface

-- | /O(n)/ Calculate the hash of the 'ByteString'. Alias for @('mempty' '<+')@.
hash :: ByteString -> Hash
hash = (<+) mempty

-- | /O(n)/ Append the hash of the 'ByteString' to the existing 'Hash'.
-- A significantly faster equivalent of @(flip ('<>') . 'hash')@.
infixl 7 <+
(<+) :: Hash -> ByteString -> Hash
(<+) h s = fst $ unsafePerformIO $ withHashPtrCopy h $ append s

-- | /O(n)/ Prepend the hash of the 'ByteString' to the existing 'Hash'.
-- A significantly faster equivalent of @(('<>') . 'hash')@.
infixr 7 +>
(+>) :: ByteString -> Hash -> Hash
(+>) s h = fst $ unsafePerformIO $ withHashPtrCopy h $ prepend s

-- | /O(n)/ Append the hash of every 'ByteString' to the existing 'Hash', from left to right.
-- A significantly faster equivalent of @('foldl' ('<+'))@.
infixl 7 <|
(<|) :: Foldable t => Hash -> t ByteString -> Hash
(<|) h ss = fst $ unsafePerformIO $ withHashPtrCopy h $ \hp -> foldlM (\p s -> p <$ append s p) hp ss

-- | /O(n)/ Prepend the hash of every 'ByteString' to the existing 'Hash', from right to left.
-- A significantly faster equivalent of @('foldr' ('+>'))@.
infixr 7 |>
(|>) :: Foldable t => t ByteString -> Hash -> Hash
(|>) ss h = fst $ unsafePerformIO $ withHashPtrCopy h $ \hp -> foldrM (\s p -> p <$ prepend s p) hp ss

-- | /O(1)/ Parse the representation generated by 'show'.
parse :: String -> Maybe Hash
parse s = (\(h, r) -> h <$ r) $ unsafePerformIO $ withHashPtrNew $ \hp -> withCAStringLen s $ \(s', len) ->
  if len == tzHashLen then Just <$> tzHashUnserialize hp s' else return Nothing