This repository has been archived by the owner on Sep 20, 2023. It is now read-only.
-
Notifications
You must be signed in to change notification settings - Fork 24
/
SHA512.hs
129 lines (102 loc) · 4.02 KB
/
SHA512.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
{-# LANGUAGE ForeignFunctionInterface, CPP, MultiParamTypeClasses #-}
-- |
-- Module : Crypto.Hash.SHA512
-- License : BSD-style
-- Maintainer : Vincent Hanquez <vincent@snarc.org>
-- Stability : experimental
-- Portability : unknown
--
-- A module containing SHA512 bindings
--
module Crypto.Hash.SHA512
( Ctx(..)
, SHA512
-- * Incremental hashing Functions
, init -- :: Ctx
, init_t -- :: Int -> Ctx
, update -- :: Ctx -> ByteString -> Ctx
, finalize -- :: Ctx -> ByteString
-- * Single Pass hashing
, hash -- :: ByteString -> ByteString
, hashlazy -- :: ByteString -> ByteString
) where
import Prelude hiding (init)
import Foreign
import Foreign.C.String
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as L
import Data.ByteString (ByteString)
import Data.ByteString.Unsafe (unsafeUseAsCString, unsafeUseAsCStringLen)
import Data.ByteString.Internal (create, memcpy)
#ifdef HAVE_CRYPTOAPI
import Control.Monad (liftM)
import Data.Serialize (Serialize(..))
import Data.Serialize.Get (getByteString)
import Data.Serialize.Put (putByteString)
import Data.Tagged (Tagged(..))
import qualified Crypto.Classes as C (Hash(..))
instance C.Hash Ctx SHA512 where
outputLength = Tagged (64 * 8)
blockLength = Tagged (128 * 8)
initialCtx = init
updateCtx = update
finalize ctx bs = Digest . finalize $ update ctx bs
instance Serialize SHA512 where
get = liftM Digest (getByteString digestSize)
put (Digest d) = putByteString d
#endif
data Ctx = Ctx !ByteString
data SHA512 = Digest !ByteString
deriving (Eq,Ord,Show)
digestSize, sizeCtx :: Int
digestSize = 64
sizeCtx = 256
instance Storable Ctx where
sizeOf _ = sizeCtx
alignment _ = 16
poke ptr (Ctx b) = unsafeUseAsCString b (\cs -> memcpy (castPtr ptr) (castPtr cs) (fromIntegral sizeCtx))
peek ptr = create sizeCtx (\bptr -> memcpy bptr (castPtr ptr) (fromIntegral sizeCtx)) >>= return . Ctx
foreign import ccall unsafe "sha512.h sha512_init"
c_sha512_init :: Ptr Ctx -> IO ()
foreign import ccall unsafe "sha512.h sha512_init_t"
c_sha512_init_t :: Ptr Ctx -> Int -> IO ()
foreign import ccall "sha512.h sha512_update"
c_sha512_update :: Ptr Ctx -> CString -> Word32 -> IO ()
foreign import ccall unsafe "sha512.h sha512_finalize"
c_sha512_finalize :: Ptr Ctx -> CString -> IO ()
allocInternal :: (Ptr Ctx -> IO a) -> IO a
allocInternal = alloca
allocInternalFrom :: Ctx -> (Ptr Ctx -> IO a) -> IO a
allocInternalFrom ctx f = allocInternal $ \ptr -> (poke ptr ctx >> f ptr)
updateInternalIO :: Ptr Ctx -> ByteString -> IO ()
updateInternalIO ptr d =
unsafeUseAsCStringLen d (\(cs, len) -> c_sha512_update ptr cs (fromIntegral len))
finalizeInternalIO :: Ptr Ctx -> IO ByteString
finalizeInternalIO ptr =
allocaBytes digestSize (\cs -> c_sha512_finalize ptr cs >> B.packCStringLen (cs, digestSize))
{-# NOINLINE init #-}
-- | init a context
init :: Ctx
init = unsafePerformIO $ allocInternal $ \ptr -> do (c_sha512_init ptr >> peek ptr)
{-# NOINLINE init_t #-}
-- | init a context using FIPS 180-4 for truncated SHA512
init_t :: Int -> Ctx
init_t t = unsafePerformIO $ allocInternal $ \ptr -> do (c_sha512_init_t ptr t >> peek ptr)
{-# NOINLINE update #-}
-- | update a context with a bytestring
update :: Ctx -> ByteString -> Ctx
update ctx d = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do updateInternalIO ptr d >> peek ptr
{-# NOINLINE finalize #-}
-- | finalize the context into a digest bytestring
finalize :: Ctx -> ByteString
finalize ctx = unsafePerformIO $ allocInternalFrom ctx $ \ptr -> do finalizeInternalIO ptr
{-# NOINLINE hash #-}
-- | hash a strict bytestring into a digest bytestring
hash :: ByteString -> ByteString
hash d = unsafePerformIO $ allocInternal $ \ptr -> do
c_sha512_init ptr >> updateInternalIO ptr d >> finalizeInternalIO ptr
{-# NOINLINE hashlazy #-}
-- | hash a lazy bytestring into a digest bytestring
hashlazy :: L.ByteString -> ByteString
hashlazy l = unsafePerformIO $ allocInternal $ \ptr -> do
c_sha512_init ptr >> mapM_ (updateInternalIO ptr) (L.toChunks l) >> finalizeInternalIO ptr