{-# LANGUAGE CPP #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE ConstraintKinds #-}
module Raaz.Hash.Internal
(
Hash(..)
, hash, hashFile, hashSource
, hash', hashFile', hashSource'
, HashI(..), SomeHashI(..), HashM
, truncatedI
, HashMemory(..), extractLength, updateLength
, completeHashing
) where
#if !MIN_VERSION_base(4,8,0)
import Control.Applicative
#endif
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.Monoid
import Data.Word
import Foreign.Storable
import System.IO
import System.IO.Unsafe (unsafePerformIO)
import Raaz.Core
data HashI h m = HashI
{ HashI h m -> String
hashIName :: String
, HashI h m -> String
hashIDescription :: String
, HashI h m -> Pointer -> BLOCKS h -> MT m ()
compress :: Pointer -> BLOCKS h -> MT m ()
, HashI h m -> Pointer -> BYTES Int -> MT m ()
compressFinal :: Pointer -> BYTES Int -> MT m ()
, HashI h m -> Alignment
compressStartAlignment :: Alignment
}
instance BlockAlgorithm (HashI h m) where
bufferStartAlignment :: HashI h m -> Alignment
bufferStartAlignment = HashI h m -> Alignment
forall h m. HashI h m -> Alignment
compressStartAlignment
type HashM h m = (Initialisable m (), Extractable m h, Primitive h)
data SomeHashI h = forall m . HashM h m =>
SomeHashI (HashI h m)
instance Describable (HashI h m) where
name :: HashI h m -> String
name = HashI h m -> String
forall h m. HashI h m -> String
hashIName
description :: HashI h m -> String
description = HashI h m -> String
forall h m. HashI h m -> String
hashIDescription
instance Describable (SomeHashI h) where
name :: SomeHashI h -> String
name (SomeHashI HashI h m
hI) = HashI h m -> String
forall d. Describable d => d -> String
name HashI h m
hI
description :: SomeHashI h -> String
description (SomeHashI HashI h m
hI) = HashI h m -> String
forall d. Describable d => d -> String
description HashI h m
hI
instance BlockAlgorithm (SomeHashI h) where
bufferStartAlignment :: SomeHashI h -> Alignment
bufferStartAlignment (SomeHashI HashI h m
imp) = HashI h m -> Alignment
forall a. BlockAlgorithm a => a -> Alignment
bufferStartAlignment HashI h m
imp
truncatedI :: (BLOCKS htrunc -> BLOCKS h)
-> (mtrunc -> m)
-> HashI h m -> HashI htrunc mtrunc
truncatedI :: (BLOCKS htrunc -> BLOCKS h)
-> (mtrunc -> m) -> HashI h m -> HashI htrunc mtrunc
truncatedI BLOCKS htrunc -> BLOCKS h
coerce mtrunc -> m
unMtrunc (HashI{String
Alignment
Pointer -> BYTES Int -> MT m ()
Pointer -> BLOCKS h -> MT m ()
compressStartAlignment :: Alignment
compressFinal :: Pointer -> BYTES Int -> MT m ()
compress :: Pointer -> BLOCKS h -> MT m ()
hashIDescription :: String
hashIName :: String
compressStartAlignment :: forall h m. HashI h m -> Alignment
compressFinal :: forall h m. HashI h m -> Pointer -> BYTES Int -> MT m ()
compress :: forall h m. HashI h m -> Pointer -> BLOCKS h -> MT m ()
hashIDescription :: forall h m. HashI h m -> String
hashIName :: forall h m. HashI h m -> String
..})
= HashI :: forall h m.
String
-> String
-> (Pointer -> BLOCKS h -> MT m ())
-> (Pointer -> BYTES Int -> MT m ())
-> Alignment
-> HashI h m
HashI { hashIName :: String
hashIName = String
hashIName
, hashIDescription :: String
hashIDescription = String
hashIDescription
, compress :: Pointer -> BLOCKS htrunc -> MT mtrunc ()
compress = Pointer -> BLOCKS htrunc -> MT mtrunc ()
comp
, compressFinal :: Pointer -> BYTES Int -> MT mtrunc ()
compressFinal = Pointer -> BYTES Int -> MT mtrunc ()
compF
, compressStartAlignment :: Alignment
compressStartAlignment = Alignment
compressStartAlignment
}
where comp :: Pointer -> BLOCKS htrunc -> MT mtrunc ()
comp Pointer
ptr = (mtrunc -> m) -> MT m () -> MT mtrunc ()
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory mtrunc -> m
unMtrunc (MT m () -> MT mtrunc ())
-> (BLOCKS htrunc -> MT m ()) -> BLOCKS htrunc -> MT mtrunc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pointer -> BLOCKS h -> MT m ()
compress Pointer
ptr (BLOCKS h -> MT m ())
-> (BLOCKS htrunc -> BLOCKS h) -> BLOCKS htrunc -> MT m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BLOCKS htrunc -> BLOCKS h
coerce
compF :: Pointer -> BYTES Int -> MT mtrunc ()
compF Pointer
ptr = (mtrunc -> m) -> MT m () -> MT mtrunc ()
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory mtrunc -> m
unMtrunc (MT m () -> MT mtrunc ())
-> (BYTES Int -> MT m ()) -> BYTES Int -> MT mtrunc ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pointer -> BYTES Int -> MT m ()
compressFinal Pointer
ptr
class ( Primitive h
, EndianStore h
, Encodable h
, Eq h
, Implementation h ~ SomeHashI h
) => Hash h where
additionalPadBlocks :: h -> BLOCKS h
hash :: ( Hash h, Recommendation h, PureByteSource src )
=> src
-> h
hash :: src -> h
hash = IO h -> h
forall a. IO a -> a
unsafePerformIO (IO h -> h) -> (src -> IO h) -> src -> h
forall b c a. (b -> c) -> (a -> b) -> a -> c
. src -> IO h
forall h src.
(Hash h, Recommendation h, ByteSource src) =>
src -> IO h
hashSource
{-# INLINEABLE hash #-}
{-# SPECIALIZE hash :: (Hash h, Recommendation h) => B.ByteString -> h #-}
{-# SPECIALIZE hash :: (Hash h, Recommendation h) => L.ByteString -> h #-}
hashFile :: ( Hash h, Recommendation h)
=> FilePath
-> IO h
hashFile :: String -> IO h
hashFile String
fileName = String -> IOMode -> (Handle -> IO h) -> IO h
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
fileName IOMode
ReadMode Handle -> IO h
forall h src.
(Hash h, Recommendation h, ByteSource src) =>
src -> IO h
hashSource
{-# INLINEABLE hashFile #-}
hashSource :: ( Hash h, Recommendation h, ByteSource src )
=> src
-> IO h
hashSource :: src -> IO h
hashSource = h -> src -> IO h
forall h src.
(Hash h, Recommendation h, ByteSource src) =>
h -> src -> IO h
go h
forall a. HasCallStack => a
undefined
where go :: (Hash h, Recommendation h, ByteSource src) => h -> src -> IO h
go :: h -> src -> IO h
go h
h = Implementation h -> src -> IO h
forall h src.
(Hash h, ByteSource src) =>
Implementation h -> src -> IO h
hashSource' (Implementation h -> src -> IO h)
-> Implementation h -> src -> IO h
forall a b. (a -> b) -> a -> b
$ h -> Implementation h
forall p. Recommendation p => p -> Implementation p
recommended h
h
{-# INLINEABLE hashSource #-}
{-# SPECIALIZE hashSource :: (Hash h, Recommendation h) => Handle -> IO h #-}
hash' :: ( PureByteSource src
, Hash h
)
=> Implementation h
-> src
-> h
hash' :: Implementation h -> src -> h
hash' Implementation h
imp = IO h -> h
forall a. IO a -> a
unsafePerformIO (IO h -> h) -> (src -> IO h) -> src -> h
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Implementation h -> src -> IO h
forall h src.
(Hash h, ByteSource src) =>
Implementation h -> src -> IO h
hashSource' Implementation h
imp
{-# INLINEABLE hash' #-}
hashFile' :: Hash h
=> Implementation h
-> FilePath
-> IO h
hashFile' :: Implementation h -> String -> IO h
hashFile' Implementation h
imp String
fileName = String -> IOMode -> (Handle -> IO h) -> IO h
forall r. String -> IOMode -> (Handle -> IO r) -> IO r
withBinaryFile String
fileName IOMode
ReadMode ((Handle -> IO h) -> IO h) -> (Handle -> IO h) -> IO h
forall a b. (a -> b) -> a -> b
$ Implementation h -> Handle -> IO h
forall h src.
(Hash h, ByteSource src) =>
Implementation h -> src -> IO h
hashSource' Implementation h
imp
{-# INLINEABLE hashFile' #-}
hashSource' :: (Hash h, ByteSource src)
=> Implementation h
-> src
-> IO h
hashSource' :: Implementation h -> src -> IO h
hashSource' (SomeHashI impl) src
src =
MT m h -> IO h
forall (mT :: * -> * -> *) mem a.
(MemoryThread mT, Memory mem) =>
mT mem a -> IO a
insecurely (MT m h -> IO h) -> MT m h -> IO h
forall a b. (a -> b) -> a -> b
$ () -> MT m ()
forall m v. Initialisable m v => v -> MT m ()
initialise () MT m () -> MT m h -> MT m h
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> HashI h m -> src -> MT m h
forall h src m.
(Hash h, ByteSource src, HashM h m) =>
HashI h m -> src -> MT m h
completeHashing HashI h m
impl src
src
completeHashing :: (Hash h, ByteSource src, HashM h m)
=> HashI h m
-> src
-> MT m h
completeHashing :: HashI h m -> src -> MT m h
completeHashing imp :: HashI h m
imp@(HashI{String
Alignment
Pointer -> BYTES Int -> MT m ()
Pointer -> BLOCKS h -> MT m ()
compressStartAlignment :: Alignment
compressFinal :: Pointer -> BYTES Int -> MT m ()
compress :: Pointer -> BLOCKS h -> MT m ()
hashIDescription :: String
hashIName :: String
compressStartAlignment :: forall h m. HashI h m -> Alignment
compressFinal :: forall h m. HashI h m -> Pointer -> BYTES Int -> MT m ()
compress :: forall h m. HashI h m -> Pointer -> BLOCKS h -> MT m ()
hashIDescription :: forall h m. HashI h m -> String
hashIName :: forall h m. HashI h m -> String
..}) src
src =
PointerAction (MT m) h h
allocate PointerAction (MT m) h h -> PointerAction (MT m) h h
forall a b. (a -> b) -> a -> b
$ \ Pointer
ptr -> let
comp :: MT m ()
comp = Pointer -> BLOCKS h -> MT m ()
compress Pointer
ptr BLOCKS h
bufSize
finish :: BYTES Int -> MT m h
finish BYTES Int
bytes = Pointer -> BYTES Int -> MT m ()
compressFinal Pointer
ptr BYTES Int
bytes MT m () -> MT m h -> MT m h
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MT m h
forall m v. Extractable m v => MT m v
extract
in MT m ()
-> (BYTES Int -> MT m h) -> src -> BLOCKS h -> Pointer -> MT m h
forall (m :: * -> *) chunkSize src a b.
(MonadIO m, LengthUnit chunkSize, ByteSource src) =>
m a -> (BYTES Int -> m b) -> src -> chunkSize -> Pointer -> m b
processChunks MT m ()
comp BYTES Int -> MT m h
finish src
src BLOCKS h
bufSize Pointer
ptr
where bufSize :: BLOCKS h
bufSize = BYTES Int -> BLOCKS h
forall src dest. (LengthUnit src, LengthUnit dest) => src -> dest
atLeast BYTES Int
l1Cache BLOCKS h -> BLOCKS h -> BLOCKS h
forall a. Semigroup a => a -> a -> a
<> Int -> BLOCKS h
forall a. Enum a => Int -> a
toEnum Int
1
totalSize :: BLOCKS h
totalSize = BLOCKS h
bufSize BLOCKS h -> BLOCKS h -> BLOCKS h
forall a. Semigroup a => a -> a -> a
<> h -> BLOCKS h
forall h. Hash h => h -> BLOCKS h
additionalPadBlocks h
forall a. HasCallStack => a
undefined
allocate :: PointerAction (MT m) h h
allocate = PointerAction IO h h -> PointerAction (MT m) h h
forall a b mem. PointerAction IO a b -> PointerAction (MT mem) a b
liftPointerAction (PointerAction IO h h -> PointerAction (MT m) h h)
-> PointerAction IO h h -> PointerAction (MT m) h h
forall a b. (a -> b) -> a -> b
$ Implementation h -> BLOCKS h -> PointerAction IO h h
forall prim b.
Primitive prim =>
Implementation prim -> BLOCKS prim -> (Pointer -> IO b) -> IO b
allocBufferFor (HashI h m -> SomeHashI h
forall h m. HashM h m => HashI h m -> SomeHashI h
SomeHashI HashI h m
imp) BLOCKS h
totalSize
data HashMemory h =
HashMemory
{ HashMemory h -> MemoryCell h
hashCell :: MemoryCell h
, HashMemory h -> MemoryCell (BITS Word64)
messageLengthCell :: MemoryCell (BITS Word64)
}
instance Storable h => Memory (HashMemory h) where
memoryAlloc :: Alloc (HashMemory h)
memoryAlloc = MemoryCell h -> MemoryCell (BITS Word64) -> HashMemory h
forall h. MemoryCell h -> MemoryCell (BITS Word64) -> HashMemory h
HashMemory (MemoryCell h -> MemoryCell (BITS Word64) -> HashMemory h)
-> TwistRF AllocField (BYTES Int) (MemoryCell h)
-> TwistRF
AllocField (BYTES Int) (MemoryCell (BITS Word64) -> HashMemory h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TwistRF AllocField (BYTES Int) (MemoryCell h)
forall m. Memory m => Alloc m
memoryAlloc TwistRF
AllocField (BYTES Int) (MemoryCell (BITS Word64) -> HashMemory h)
-> TwistRF AllocField (BYTES Int) (MemoryCell (BITS Word64))
-> Alloc (HashMemory h)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TwistRF AllocField (BYTES Int) (MemoryCell (BITS Word64))
forall m. Memory m => Alloc m
memoryAlloc
unsafeToPointer :: HashMemory h -> Pointer
unsafeToPointer = MemoryCell h -> Pointer
forall m. Memory m => m -> Pointer
unsafeToPointer (MemoryCell h -> Pointer)
-> (HashMemory h -> MemoryCell h) -> HashMemory h -> Pointer
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HashMemory h -> MemoryCell h
forall h. HashMemory h -> MemoryCell h
hashCell
instance Storable h => Initialisable (HashMemory h) h where
initialise :: h -> MT (HashMemory h) ()
initialise h
h = do
(HashMemory h -> MemoryCell h)
-> MT (MemoryCell h) () -> MT (HashMemory h) ()
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory HashMemory h -> MemoryCell h
forall h. HashMemory h -> MemoryCell h
hashCell (MT (MemoryCell h) () -> MT (HashMemory h) ())
-> MT (MemoryCell h) () -> MT (HashMemory h) ()
forall a b. (a -> b) -> a -> b
$ h -> MT (MemoryCell h) ()
forall m v. Initialisable m v => v -> MT m ()
initialise h
h
(HashMemory h -> MemoryCell (BITS Word64))
-> MT (MemoryCell (BITS Word64)) () -> MT (HashMemory h) ()
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory HashMemory h -> MemoryCell (BITS Word64)
forall h. HashMemory h -> MemoryCell (BITS Word64)
messageLengthCell (MT (MemoryCell (BITS Word64)) () -> MT (HashMemory h) ())
-> MT (MemoryCell (BITS Word64)) () -> MT (HashMemory h) ()
forall a b. (a -> b) -> a -> b
$ BITS Word64 -> MT (MemoryCell (BITS Word64)) ()
forall m v. Initialisable m v => v -> MT m ()
initialise (BITS Word64
0 :: BITS Word64)
instance Storable h => Extractable (HashMemory h) h where
extract :: MT (HashMemory h) h
extract = (HashMemory h -> MemoryCell h)
-> MT (MemoryCell h) h -> MT (HashMemory h) h
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory HashMemory h -> MemoryCell h
forall h. HashMemory h -> MemoryCell h
hashCell MT (MemoryCell h) h
forall m v. Extractable m v => MT m v
extract
extractLength :: MT (HashMemory h) (BITS Word64)
= (HashMemory h -> MemoryCell (BITS Word64))
-> MT (MemoryCell (BITS Word64)) (BITS Word64)
-> MT (HashMemory h) (BITS Word64)
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory HashMemory h -> MemoryCell (BITS Word64)
forall h. HashMemory h -> MemoryCell (BITS Word64)
messageLengthCell MT (MemoryCell (BITS Word64)) (BITS Word64)
forall m v. Extractable m v => MT m v
extract
{-# INLINE extractLength #-}
updateLength :: LengthUnit u => u -> MT (HashMemory h) ()
{-# INLINE updateLength #-}
updateLength :: u -> MT (HashMemory h) ()
updateLength u
u = (HashMemory h -> MemoryCell (BITS Word64))
-> MT (MemoryCell (BITS Word64)) () -> MT (HashMemory h) ()
forall (mT :: * -> * -> *) mem submem a.
MemoryThread mT =>
(mem -> submem) -> mT submem a -> mT mem a
onSubMemory HashMemory h -> MemoryCell (BITS Word64)
forall h. HashMemory h -> MemoryCell (BITS Word64)
messageLengthCell (MT (MemoryCell (BITS Word64)) () -> MT (HashMemory h) ())
-> MT (MemoryCell (BITS Word64)) () -> MT (HashMemory h) ()
forall a b. (a -> b) -> a -> b
$ (BITS Word64 -> BITS Word64) -> MT (MemoryCell (BITS Word64)) ()
forall mem a b (mT :: * -> * -> *).
(Initialisable mem a, Extractable mem b, MemoryThread mT) =>
(b -> a) -> mT mem ()
modify (BITS Word64
nBits BITS Word64 -> BITS Word64 -> BITS Word64
forall a. Num a => a -> a -> a
+)
where nBits :: BITS Word64
nBits :: BITS Word64
nBits = u -> BITS Word64
forall u. LengthUnit u => u -> BITS Word64
inBits u
u