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
130
131
132
133
134
135
|
{-# LANGUAGE CApiFFI #-}
{-# OPTIONS_GHC -Wno-missing-methods #-}
module Data.Digest.Evp
( Algo
, Digest(Digest)
, hash
) where
import Control.Exception (bracket_)
import Control.Monad (void)
import Data.Bits (Bits((.&.)), shiftR)
import Data.ByteString (ByteString)
import qualified Data.ByteString as ByteString
import qualified Data.ByteString.Unsafe as ByteString
import Data.Char (intToDigit)
import Data.Word (Word8)
import Foreign
(Ptr, Storable(alignment, peek, sizeOf), alloca, allocaArray,
nullPtr, throwIf_)
import Foreign.C.Types
import System.IO.Unsafe (unsafePerformIO)
import Unsafe.Coerce (unsafeCoerce)
#include <openssl/digest.h>
-- First, we build basic bindings to the BoringSSL EVP interface.
-- | The BoringSSL @ENGINE@ type.
data Engine
-- | The BoringSSL @EVP_MD@ type, representing a hash algorithm.
data EvpMd
-- | A convenience alias for @Ptr EvpMd@.
type Algo = Ptr EvpMd
-- | The BoringSSL @EVP_MD_CTX@ type, representing the state of a pending
-- hashing operation.
data EvpMdCtx
instance Storable EvpMdCtx where
sizeOf _ = #size EVP_MD_CTX
alignment _ = #alignment EVP_MD_CTX
-- Imported functions from BoringSSL. See
-- https://commondatastorage.googleapis.com/chromium-boringssl-docs/digest.h.html
-- for documentation.
foreign import ccall "openssl/digest.h EVP_MD_CTX_init"
evpMdCtxInit :: Ptr EvpMdCtx -> IO ()
foreign import ccall "openssl/digest.h EVP_MD_CTX_cleanup"
evpMdCtxCleanup' :: Ptr EvpMdCtx -> IO CInt
foreign import ccall "openssl/digest.h EVP_DigestInit_ex"
evpDigestInitEx' :: Ptr EvpMdCtx -> Ptr EvpMd -> Ptr Engine -> IO CInt
foreign import capi "openssl/digest.h value EVP_MAX_MD_SIZE"
evpMaxMdSize :: CSize
foreign import ccall "openssl/digest.h EVP_DigestUpdate"
evpDigestUpdate' :: Ptr EvpMdCtx -> Ptr a -> CSize -> IO CInt
foreign import ccall "openssl/digest.h EVP_DigestFinal_ex"
evpDigestFinalEx' :: Ptr EvpMdCtx -> Ptr CUChar -> Ptr CUInt -> IO CInt
-- Some of these functions return 'CInt' even though they can never fail. Wrap
-- them to prevent warnings.
evpMdCtxCleanup :: Ptr EvpMdCtx -> IO ()
evpMdCtxCleanup = void . evpMdCtxCleanup'
evpDigestUpdate :: Ptr EvpMdCtx -> Ptr a -> CSize -> IO ()
evpDigestUpdate ctx md bytes = void $ evpDigestUpdate' ctx md bytes
evpDigestFinalEx :: Ptr EvpMdCtx -> Ptr CUChar -> Ptr CUInt -> IO ()
evpDigestFinalEx ctx mdOut outSize = void $ evpDigestFinalEx' ctx mdOut outSize
-- Convert functions that can in fact fail to throw exceptions instead.
evpDigestInitEx :: Ptr EvpMdCtx -> Ptr EvpMd -> Ptr Engine -> IO ()
evpDigestInitEx ctx md engine =
throwIf_ (/= 1) (const "BoringSSL failure") $ evpDigestInitEx' ctx md engine
-- Now we can build a memory-safe abstraction layer.
-- | Memory-safe wrapper for 'EvpMdCtx'.
withMdCtx :: (Ptr EvpMdCtx -> IO a) -> IO a
withMdCtx f =
alloca $ \ctx -> bracket_ (evpMdCtxInit ctx) (evpMdCtxCleanup ctx) (f ctx)
-- Finally, we're ready to actually implement the hashing interface.
-- | The result of a hash operation.
newtype Digest =
Digest ByteString
deriving (Eq, Ord)
instance Show Digest where
show (Digest d) = ByteString.foldr showHexPadded [] d
where
showHexPadded b xs =
hexit (b `shiftR` 4 .&. 0x0f) : hexit (b .&. 0x0f) : xs
hexit = intToDigit . fromIntegral :: Word8 -> Char
hash :: Algo -> ByteString -> Digest
hash md bytes =
-- We'd like to use 'unsafeLocalState' (i.e., 'unsafeDupablePerformIO') here,
-- but 'unsafeDupablePerformIO' runs computation in a context where it can be
-- arbitrarily terminated--i.e., where the cleanup in 'withMdCtx' is not
-- guaranteed to run. See
-- https://hackage.haskell.org/package/base/docs/System-IO-Unsafe.html#v:unsafeDupablePerformIO.
unsafePerformIO $
withMdCtx $ \ctx -> do
evpDigestInitEx ctx md noEngine
-- evpDigestUpdate treats its @buf@ argument as @const@, so the sharing
-- inherent in 'ByteString.unsafeUseAsCStringLen' is fine.
ByteString.unsafeUseAsCStringLen bytes $ \(buf, len) ->
evpDigestUpdate ctx buf (fromIntegral len)
d <-
allocaArray (fromIntegral evpMaxMdSize) $ \mdOut ->
alloca $ \pOutSize -> do
evpDigestFinalEx ctx mdOut pOutSize
outSize <- fromIntegral <$> peek pOutSize
-- 'mdOut' is a 'Ptr CUChar'. However, to make life more interesting,
-- 'CString' is a 'Ptr CChar', and 'CChar' is signed. This is
-- especially unfortunate given that all we really want to do is
-- convert to a 'ByteString', which is unsigned. To work around it,
-- we're going to cheat and let Haskell reinterpret-cast 'mdOut' to
-- 'Ptr CChar' before it does its 'ByteString' ingestion.
ByteString.packCStringLen (unsafeCoerce mdOut, outSize)
return (Digest d)
where
noEngine = nullPtr :: Ptr Engine
|
