module OpenSSL.EVP.Digest
( Digest
, EVP_MD
, withMDPtr
, getDigestByName
, getDigestNames
, DigestCtx
, EVP_MD_CTX
, withDigestCtxPtr
, digestStrictly
, digestLazily
, digest
, digestBS
, digestBS'
, digestLBS
, hmacBS
, pkcs5_pbkdf2_hmac_sha1
)
where
import Control.Monad
import Data.ByteString.Internal (createAndTrim, create)
import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
import qualified Data.ByteString.Char8 as B8
import qualified Data.ByteString.Lazy.Char8 as L8
import Foreign
import Foreign.C
import OpenSSL.Objects
import OpenSSL.Utils
newtype Digest = Digest (Ptr EVP_MD)
data EVP_MD
foreign import ccall unsafe "EVP_get_digestbyname"
_get_digestbyname :: CString -> IO (Ptr EVP_MD)
withMDPtr :: Digest -> (Ptr EVP_MD -> IO a) -> IO a
withMDPtr (Digest mdPtr) f = f mdPtr
getDigestByName :: String -> IO (Maybe Digest)
getDigestByName name
= withCString name $ \ namePtr ->
do ptr <- _get_digestbyname namePtr
if ptr == nullPtr then
return Nothing
else
return $ Just $ Digest ptr
getDigestNames :: IO [String]
getDigestNames = getObjNames MDMethodType True
newtype DigestCtx = DigestCtx (ForeignPtr EVP_MD_CTX)
data EVP_MD_CTX
foreign import ccall unsafe "EVP_MD_CTX_init"
_ctx_init :: Ptr EVP_MD_CTX -> IO ()
foreign import ccall unsafe "&EVP_MD_CTX_cleanup"
_ctx_cleanup :: FunPtr (Ptr EVP_MD_CTX -> IO ())
newCtx :: IO DigestCtx
newCtx = do ctx <- mallocForeignPtrBytes ((24))
withForeignPtr ctx _ctx_init
addForeignPtrFinalizer _ctx_cleanup ctx
return $ DigestCtx ctx
withDigestCtxPtr :: DigestCtx -> (Ptr EVP_MD_CTX -> IO a) -> IO a
withDigestCtxPtr (DigestCtx ctx) = withForeignPtr ctx
foreign import ccall unsafe "EVP_DigestInit"
_DigestInit :: Ptr EVP_MD_CTX -> Ptr EVP_MD -> IO CInt
foreign import ccall unsafe "EVP_DigestUpdate"
_DigestUpdate :: Ptr EVP_MD_CTX -> Ptr CChar -> CSize -> IO CInt
foreign import ccall unsafe "EVP_DigestFinal"
_DigestFinal :: Ptr EVP_MD_CTX -> Ptr CChar -> Ptr CUInt -> IO CInt
digestInit :: Digest -> IO DigestCtx
digestInit (Digest md)
= do ctx <- newCtx
withDigestCtxPtr ctx $ \ ctxPtr ->
_DigestInit ctxPtr md >>= failIf_ (/= 1)
return ctx
digestUpdateBS :: DigestCtx -> B8.ByteString -> IO ()
digestUpdateBS ctx bs
= withDigestCtxPtr ctx $ \ ctxPtr ->
unsafeUseAsCStringLen bs $ \ (buf, len) ->
_DigestUpdate ctxPtr buf (fromIntegral len) >>= failIf (/= 1) >> return ()
digestFinal :: DigestCtx -> IO String
digestFinal ctx
= withDigestCtxPtr ctx $ \ ctxPtr ->
allocaArray (64) $ \ bufPtr ->
alloca $ \ bufLenPtr ->
do _DigestFinal ctxPtr bufPtr bufLenPtr >>= failIf_ (/= 1)
bufLen <- liftM fromIntegral $ peek bufLenPtr
peekCStringLen (bufPtr, bufLen)
digestFinalBS :: DigestCtx -> IO B8.ByteString
digestFinalBS ctx =
withDigestCtxPtr ctx $ \ctxPtr ->
createAndTrim (64) $ \bufPtr ->
alloca $ \bufLenPtr ->
do _DigestFinal ctxPtr (castPtr bufPtr) bufLenPtr >>= failIf_ (/= 1)
liftM fromIntegral $ peek bufLenPtr
digestStrictly :: Digest -> B8.ByteString -> IO DigestCtx
digestStrictly md input
= do ctx <- digestInit md
digestUpdateBS ctx input
return ctx
digestLazily :: Digest -> L8.ByteString -> IO DigestCtx
digestLazily md lbs
= do ctx <- digestInit md
mapM_ (digestUpdateBS ctx) $ L8.toChunks lbs
return ctx
digest :: Digest -> String -> String
digest md input
= digestLBS md $ L8.pack input
digestBS :: Digest -> B8.ByteString -> String
digestBS md input
= unsafePerformIO
(digestStrictly md input >>= digestFinal)
digestBS' :: Digest -> B8.ByteString -> B8.ByteString
digestBS' md input
= unsafePerformIO
(digestStrictly md input >>= digestFinalBS)
digestLBS :: Digest -> L8.ByteString -> String
digestLBS md input
= unsafePerformIO
(digestLazily md input >>= digestFinal)
foreign import ccall unsafe "HMAC"
_HMAC :: Ptr EVP_MD -> Ptr CChar -> CInt -> Ptr CChar -> CSize
-> Ptr CChar -> Ptr CUInt -> IO ()
hmacBS :: Digest
-> B8.ByteString
-> B8.ByteString
-> B8.ByteString
hmacBS (Digest md) key input =
unsafePerformIO $
allocaArray (64) $ \bufPtr ->
alloca $ \bufLenPtr ->
unsafeUseAsCStringLen key $ \(keydata, keylen) ->
unsafeUseAsCStringLen input $ \(inputdata, inputlen) ->
do _HMAC md keydata (fromIntegral keylen) inputdata (fromIntegral inputlen) bufPtr bufLenPtr
bufLen <- liftM fromIntegral $ peek bufLenPtr
B8.packCStringLen (bufPtr, bufLen)
pkcs5_pbkdf2_hmac_sha1 :: B8.ByteString
-> B8.ByteString
-> Int
-> Int
-> B8.ByteString
pkcs5_pbkdf2_hmac_sha1 pass salt iter dkeylen =
unsafePerformIO $
unsafeUseAsCStringLen pass $ \(passdata, passlen) ->
unsafeUseAsCStringLen salt $ \(saltdata, saltlen) ->
create dkeylen $ \dkeydata ->
_PKCS5_PBKDF2_HMAC_SHA1
passdata (fromIntegral passlen)
saltdata (fromIntegral saltlen)
(fromIntegral iter) (fromIntegral dkeylen) (castPtr dkeydata)
>> return ()
foreign import ccall unsafe "PKCS5_PBKDF2_HMAC_SHA1" _PKCS5_PBKDF2_HMAC_SHA1 :: Ptr CChar -> CInt
-> Ptr CChar -> CInt
-> CInt -> CInt -> Ptr CChar
-> IO CInt