diff --git a/OpenSSL/Digest.hs b/OpenSSL/Digest.hs deleted file mode 100644 --- a/OpenSSL/Digest.hs +++ /dev/null @@ -1,237 +0,0 @@ -{-# LANGUAGE ForeignFunctionInterface #-} - -{- | - Module : OpenSSL.Digest - Copyright : (c) 2014 by Peter Simons - License : BSD3 - - Maintainer : simons@cryp.to - Stability : provisional - Portability : portable - - This module proivdes a high-level API to the message - digest algorithms found in OpenSSL's @crypto@ library. - Link with @-lcrypto@ when using this module. - - Here is a short example program which runs all available - digests on a string: - - > example :: (Enum a) => [a] -> IO [String] - > example input = mapM hash [minBound .. maxBound] - > where - > hash f = fmap (fmt f) (digest f (toWord input)) - > fmt f = shows f . (": \t"++) . (>>=toHex) - > toWord = map (toEnum . fromEnum) - - And when called, the function prints: - - > *Digest> example "open sesame" >>= putStr . unlines - > Null: - > MD5: 54ef36ec71201fdf9d1423fd26f97f6b - > SHA: 2ccefef64c76ac0d42ca1657457977675890c42f - > SHA1: 5bcaff7f22ff533ca099b3408ead876c0ebba9a7 - > DSS: 5bcaff7f22ff533ca099b3408ead876c0ebba9a7 - > DSS1: 5bcaff7f22ff533ca099b3408ead876c0ebba9a7 - > RIPEMD160: bdb2bba6ec93bd566dc1181cadbc92176aa78382 - > MDC2: 112db2200ce1e9db3c2d132aea4ef7d0 - > SHA224: 1ee0f9d93a873a67fe781852d716cb3e5904e015aafaa4d1ff1a81bc - > SHA256: 41ef4bb0b23661e66301aac36066912dac037827b4ae63a7b1165a5aa93ed4eb - > SHA384: ae2a5d6649035c00efe2bc1b5c97f4d5ff97fa2df06f273afa0231c425e8aff30e4cc1db5e5756e8d2245a1514ad1a2d - > SHA512: 8470cdd3bf1ef85d5f092bce5ae5af97ce50820481bf43b2413807fec37e2785b533a65d4c7d71695b141d81ebcd4b6c4def4284e6067f0b400000001b230205 --} - -module OpenSSL.Digest where - -import Control.Exception ( bracket ) -import Foreign -import Foreign.C -import Control.Monad.State -import Numeric ( showHex ) - --- * High-level API - --- |The message digest algorithms we support. - -data MessageDigest - = Null -- ^ 0 bit - | MD5 -- ^ 128 bit - | SHA -- ^ 160 bit - | SHA1 -- ^ 160 bit - | DSS -- ^ other name for SHA1 - | DSS1 -- ^ other name for SHA1 - | RIPEMD160 -- ^ 160 bit - | MDC2 -- ^ 128 bit - | SHA224 -- ^ 224 bit - | SHA256 -- ^ 256 bit - | SHA384 -- ^ 384 bit - | SHA512 -- ^ 512 bit - deriving (Show, Eq, Enum, Bounded) - --- |A convenience wrapper which computes the given digest --- over a list of 'Word8'. Unlike the monadic interface, --- this function does not allow the computation to be --- restarted. - -digest :: MessageDigest -> [Word8] -> IO [Word8] -digest mdType xs = - mkDigest mdType $ evalStateT (update xs >> final) - --- |A monadic interface to the digest computation. - -type Digest a = StateT DigestState IO a - --- |The internal EVP context. - -newtype DigestState = DST (Ptr OpaqueContext) - --- |Run an 'IO' computation with an initialized --- 'DigestState'. All resources will be freed when the --- computation returns. - -mkDigest :: MessageDigest -> (DigestState -> IO a) -> IO a -mkDigest mdType f = - bracket ctxCreate ctxDestroy $ \ctx -> do - when (ctx == nullPtr) (fail "Digest.mkDigest: ctxCreate failed") - md <- toMDEngine mdType - when (md == nullPtr) (fail ("Digest.mkDigest: can't access "++show mdType)) - rc <- digestInit ctx md - when (rc == 0) (fail ("Digest.mkDigest: can't initialize "++show mdType)) - f (DST ctx) - --- |Update the internal state with a block of data. This --- function is just a wrapper for 'update'', which creates --- an array in memory using 'withArray'. - -update :: [Word8] -> Digest () -update xs = do - st <- get - liftIO $ - withArray xs $ \p -> - evalStateT (update' (p, length xs)) st - --- |Update the internal state with a block of data from --- memory. This is the /faster/ version of 'update'. - -update' :: (Ptr Word8, Int) -> Digest () -update' (p,n) = do - DST ctx <- get - rc <- liftIO $ digestUpdate ctx p (toEnum (fromEnum n)) - when (rc == 0) (fail "Digest.update failed") - --- |Wrap up the computation, add padding, do whatever has to --- be done, and return the final hash. The length of the --- result depends on the chosen 'MessageDigest'. Do not call --- more than once! - -final :: Digest [Word8] -final = do - DST ctx <- get - liftIO $ - allocaArray maxMDSize $ \p -> - allocaArray (sizeOf (undefined :: CUInt)) $ \i -> do - rc <- digestFinal ctx p i - when (rc == 0) (fail "Digest.Final failed") - i' <- peek i - peekArray (fromEnum i') p - --- * Low-level API - --- |The EVP context used by OpenSSL is opaque for us; we --- only access it through a 'Ptr'. - -data OpaqueContext = OpaqueContext -type Context = Ptr OpaqueContext - --- |The message digest engines are opaque for us as well. - -data OpaqueMDEngine = OpaqueMDEngine -type MDEngine = Ptr OpaqueMDEngine - --- |Maximum size of all message digests supported by --- OpenSSL. Allocate a buffer of this size for 'digestFinal' --- if you want to stay generic. - -maxMDSize :: Int -maxMDSize = 36 - --- |Create an EVP context. May be 'nullPtr'. - -foreign import ccall unsafe "EVP_MD_CTX_create" ctxCreate :: - IO Context - --- |Initialize an EVP context. - -foreign import ccall unsafe "EVP_MD_CTX_init" ctxInit :: - Context -> IO () - --- |Destroy an EVP context and free the allocated resources. - -foreign import ccall unsafe "EVP_MD_CTX_destroy" ctxDestroy :: - Context -> IO () - --- |Set the message digest engine for 'digestUpdate' calls. --- Returns @\/=0@ in case of an error. - -foreign import ccall unsafe "EVP_DigestInit" digestInit :: - Context -> MDEngine -> IO CInt - --- |Update the internal context with a block of input. --- Returns @\/=0@ in case of an error. - -foreign import ccall unsafe "EVP_DigestUpdate" digestUpdate :: - Context -> Ptr Word8 -> CUInt -> IO CInt - --- |Wrap up the digest computation and return the final --- digest. Do not call repeatedly on the same context! --- Returns @\/=0@ in case of an error. The pointer to the --- unsigned integer may be 'nullPtr'. If it is not, --- 'digestFinal' will store the length of the computed --- digest there. - -foreign import ccall unsafe "EVP_DigestFinal" digestFinal :: - Context -> Ptr Word8 -> Ptr CUInt -> IO CInt - --- ** Message Digest Engines - -foreign import ccall unsafe "EVP_dss" mdDSS :: IO MDEngine -foreign import ccall unsafe "EVP_dss1" mdDSS1 :: IO MDEngine -foreign import ccall unsafe "EVP_md5" mdMD5 :: IO MDEngine -foreign import ccall unsafe "EVP_md_null" mdNull :: IO MDEngine -foreign import ccall unsafe "EVP_mdc2" mdMDC2 :: IO MDEngine -foreign import ccall unsafe "EVP_ripemd160" mdRIPEMD160 :: IO MDEngine -foreign import ccall unsafe "EVP_sha" mdSHA :: IO MDEngine -foreign import ccall unsafe "EVP_sha1" mdSHA1 :: IO MDEngine -foreign import ccall unsafe "EVP_sha224" mdSHA224 :: IO MDEngine -foreign import ccall unsafe "EVP_sha256" mdSHA256 :: IO MDEngine -foreign import ccall unsafe "EVP_sha384" mdSHA384 :: IO MDEngine -foreign import ccall unsafe "EVP_sha512" mdSHA512 :: IO MDEngine - --- |Map a 'MessageDigest' type into the the corresponding --- 'MDEngine'. - -toMDEngine :: MessageDigest -> IO MDEngine -toMDEngine Null = mdNull -toMDEngine MD5 = mdMD5 -toMDEngine SHA = mdSHA -toMDEngine SHA1 = mdSHA1 -toMDEngine DSS = mdDSS -toMDEngine DSS1 = mdDSS1 -toMDEngine RIPEMD160 = mdRIPEMD160 -toMDEngine MDC2 = mdMDC2 -toMDEngine SHA224 = mdSHA224 -toMDEngine SHA256 = mdSHA256 -toMDEngine SHA384 = mdSHA384 -toMDEngine SHA512 = mdSHA512 - --- * Helper Functions - --- |Neat helper to print digests with: --- @ --- \\ws :: [Word8] -> ws >>= toHex --- @ - -toHex :: Word8 -> String -toHex w = case showHex w "" of - w1:w2:[] -> w1:w2:[] - w2:[] -> '0':w2:[] - _ -> error "showHex returned []" diff --git a/OpenSSL/Digest/ByteString.hs b/OpenSSL/Digest/ByteString.hs deleted file mode 100644 --- a/OpenSSL/Digest/ByteString.hs +++ /dev/null @@ -1,38 +0,0 @@ -{- | - Module : OpenSSL.Digest.ByteString - Copyright : (c) 2010 by Peter Simons - License : BSD3 - - Maintainer : simons@cryp.to - Stability : provisional - Portability : portable - - Wrappers for "OpenSSL.Digest" that supports 'ByteString'. - -} - -module OpenSSL.Digest.ByteString where - -import OpenSSL.Digest hiding ( update ) -import Control.Monad.State ( evalStateT, lift, get ) -import Foreign.Ptr ( castPtr ) -import Data.Word ( Word8 ) -import Data.ByteString ( ByteString ) -import Data.ByteString.Unsafe ( unsafeUseAsCStringLen ) - --- |A convenience wrapper which computes the given digest type of a --- 'ByteString'. Unlike the monadic interface, this function does not --- allow the computation to be restarted. - -digest :: MessageDigest -> ByteString -> IO [Word8] -digest mdType xs = - mkDigest mdType $ evalStateT (update xs >> final) - --- |Update the internal state with a block of data. - -update :: ByteString -> Digest Int -update bs = do - DST ctx <- get - l <- lift $ - unsafeUseAsCStringLen bs $ \(ptr, len) -> - digestUpdate ctx (castPtr ptr) (fromIntegral len) - return (fromEnum l) diff --git a/OpenSSL/Digest/ByteString/Lazy.hs b/OpenSSL/Digest/ByteString/Lazy.hs deleted file mode 100644 --- a/OpenSSL/Digest/ByteString/Lazy.hs +++ /dev/null @@ -1,32 +0,0 @@ -{- | - Module : OpenSSL.Digest.ByteString.Lazy - Copyright : (c) 2010 by Peter Simons - License : BSD3 - - Maintainer : simons@cryp.to - Stability : provisional - Portability : portable - - Wrappers for "OpenSSL.Digest" that supports lazy 'ByteString'. - -} - -module OpenSSL.Digest.ByteString.Lazy where - -import OpenSSL.Digest hiding ( update ) -import Data.Word ( Word8 ) -import Control.Monad.State ( evalStateT ) -import qualified OpenSSL.Digest.ByteString as BS ( update ) -import Data.ByteString.Lazy ( ByteString, toChunks ) - --- |A convenience wrapper which computes the given digest type of a --- 'ByteString'. Unlike the monadic interface, this function does not --- allow the computation to be restarted. - -digest :: MessageDigest -> ByteString -> IO [Word8] -digest mdType xs = - mkDigest mdType $ evalStateT (update xs >> final) - --- |Update the internal state with a block of data. - -update :: ByteString -> Digest Int -update = fmap sum . mapM BS.update . toChunks diff --git a/hopenssl.cabal b/hopenssl.cabal --- a/hopenssl.cabal +++ b/hopenssl.cabal @@ -1,31 +1,55 @@ -Name: hopenssl -Version: 1.7 -Copyright: (c) 2004-2013 Peter Simons -License: BSD3 -License-File: LICENSE -Author: Peter Simons , - Jesper Louis Andersen , - Markus Rothe -Maintainer: Peter Simons -Homepage: http://github.com/peti/hopenssl -Category: Foreign, Cryptography -Synopsis: FFI bindings to OpenSSL's EVP digest interface -Description: Foreign-function bindings to the OpenSSL library - . Currently provides - access to the messages digests MD5, DSS, DSS1, - RIPEMD160, and several variants of SHA through - the EVP digest interface. -Cabal-Version: >= 1.6 -Build-Type: Simple -Tested-With: GHC >= 6.10.4 && <= 7.8.3 +name: hopenssl +version: 2 +copyright: (c) 2004-2017 Peter Simons +license: BSD3 +license-file: LICENSE +author: Peter Simons, Markus Rothe +maintainer: Peter Simons +homepage: http://github.com/peti/hopenssl +category: Foreign, Cryptography +synopsis: FFI bindings to OpenSSL's EVP digest interface +description: Foreign-function bindings to the + . Currently + provides access to the messages digests MD5, DSS, DSS1, + RIPEMD160, and several variants of SHA through the EVP + digest interface. +cabal-version: >= 1.8 +build-type: Simple +tested-with: GHC > 7.6 && < 8.1 -Source-Repository head - Type: git - Location: git://github.com/peti/hopenssl.git +source-repository head + type: git + location: git://github.com/peti/hopenssl.git -Library - Build-Depends: base >= 3 && < 5, mtl, bytestring - Extensions: ForeignFunctionInterface - Extra-Libraries: crypto - Includes: "openssl/evp.h" - Exposed-Modules: OpenSSL.Digest, OpenSSL.Digest.ByteString, OpenSSL.Digest.ByteString.Lazy +library + build-depends: base >= 3 && < 5, bytestring + hs-source-dirs: src + other-extensions: ForeignFunctionInterface, EmptyDataDecls, DeriveDataTypeable, + FlexibleInstances, TypeSynonymInstances + extra-libraries: crypto + includes: "openssl/evp.h" + exposed-modules: OpenSSL.Digest + OpenSSL.EVP.Digest + +test-suite check-low-level-digest-api + type: exitcode-stdio-1.0 + main-is: CheckLowLevelDigestAPI.hs + other-modules: OpenSesame + hs-source-dirs: test + build-depends: base >= 3 && < 5, hopenssl, HUnit + ghc-options: -threaded + +test-suite check-high-level-digest-api + type: exitcode-stdio-1.0 + main-is: CheckHighLevelDigestAPI.hs + other-modules: OpenSesame + hs-source-dirs: test + build-depends: base >= 3 && < 5, hopenssl, HUnit + ghc-options: -threaded + +test-suite doctests + type: exitcode-stdio-1.0 + main-is: doctests.hs + hs-source-dirs: test + build-depends: base, hopenssl, doctest + ghc-options: -threaded diff --git a/src/OpenSSL/Digest.hs b/src/OpenSSL/Digest.hs new file mode 100644 --- /dev/null +++ b/src/OpenSSL/Digest.hs @@ -0,0 +1,201 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} + +{- | + Maintainer: simons@cryp.to + Stability: provisional + Portability: portable + + This module provides a generic high-level API to the message digest + algorithms found in OpenSSL's @crypto@ library. There are two functions of + particular interest: 'digestByName' and 'digest'. The former can be used to + retrieve a 'DigestDescription', i.e. an OpenSSL object that implements a + particular algorithm. That type can then be used to compute actual message + digests with the latter function: + + >>> import Data.ByteString.Char8 ( pack ) + >>> digest (digestByName "md5") (pack "Hello, world.") + "\b\n\239\131\155\149\250\207s\236Y\147u\233-G" + + Neat pretty-printing can be achieved with 'toHex', which converts the binary + representation of a message digest into the common hexadecimal one: + + >>> toHex $ digest (digestByName "md5") (pack "Hello, world.") + "080aef839b95facf73ec599375e92d47" + >>> toHex $ digest (digestByName "sha1") (pack "Hello, world.") + "2ae01472317d1935a84797ec1983ae243fc6aa28" + + The precise set of available digest algorithms provided by OpenSSL depends + on the version of the library installed into the system, obviously, but it's + reasonable to expect the following algorithms to be present: MD5, RIPEMD160, + SHA1, SHA224, SHA256, SHA384, and SHA512. If an algorithm is not available, + 'digestByName' will throw an 'DigestAlgorithmNotAvailableInOpenSSL' + exception. If you don't like exceptions, use the tamer 'digestByName'' + variant: + + >>> digestByName' "i bet this algorithm won't exist" + Nothing + + 'DigestDescription' is an instance of 'IsString', so with the proper GHC + extensions enabled it's possible to simplify the call to 'digest' even + further: + + >>> :set -XOverloadedStrings + >>> toHex $ digest "sha256" (pack "The 'Through the Universe' podcast rules.") + "73624694a9435095c8fdaad711273a23c02226196c452f817cfd86f965895614" + + Last but not least, 'digest' is actually a class method of 'Digestable', + which collects things we can compute digests of. The defaults are + conservative, i.e. we support all things that correspond roughly to C's + construct of "void pointer plus a length". @digest@ can use with any of the + following signatures: + + >>> let shape1 = digest :: DigestDescription -> (Ptr (), CSize) -> MessageDigest + >>> let shape2 = digest :: DigestDescription -> (Ptr Word8, CSize) -> MessageDigest + >>> let shape3 = digest :: DigestDescription -> (Ptr Word8, CUInt) -> MessageDigest + >>> let shape4 = digest :: DigestDescription -> (Ptr (), Int) -> MessageDigest + >>> let shape5 = digest :: DigestDescription -> StrictByteString -> MessageDigest + >>> let shape6 = digest :: DigestDescription -> LazyByteString -> MessageDigest + + 'StrictByteString' and 'LazyByteString' are also instances of 'IsString' and + therefore subject to implicit construction from string literals: + + >>> shape5 "sha256" "hello" == shape6 "sha256" "hello" + True + + Note that this code offers no overloaded 'digest' version for 'String', + because that function would produce non-deterministic results for Unicode + characters. There is an instance for @[Word8]@, though, so strings can be + hashed after a proper encoding has been applied. For those who don't care + about determinism, there is the following specialized function: + + >>> toHex $ digestString "md5" "no Digestable instance for this sucker" + "a74827f849005794565f83fbd68ad189" + + If you don't mind orphaned instances, however, feel free to shoot yourself + in the foot: + + >>> :set -XFlexibleInstances + >>> instance Digestable String where updateChunk ctx str = withCStringLen str (updateChunk ctx) + >>> toHex $ digest "sha256" ("now we can hash strings" :: String) + "7f2989f173125810aa917c4ffe0e26ae1b5f7fb852274829c210297a43dfc7f9" +-} + +module OpenSSL.Digest + ( -- * Generic digest API + MessageDigest, digest, Digestable(..), digestByName, digestByName', DigestDescription + , -- * Special instances + digestString + , -- * Helper Types and Functions + toHex, StrictByteString, LazyByteString + ) + where + +import OpenSSL.EVP.Digest hiding ( toHex ) + +import Control.Exception +import qualified Data.ByteString as Strict ( ByteString, packCStringLen, concatMap ) +import Data.ByteString.Char8 as Strict8 ( pack ) +import qualified Data.ByteString.Lazy as Lazy ( ByteString, toChunks ) +import Data.ByteString.Unsafe ( unsafeUseAsCStringLen ) +import Foreign +import Foreign.C +import Numeric ( showHex ) +import System.IO.Unsafe as IO + +-- $setup +-- >>> import Data.Maybe + +-- Generic Class API ---------------------------------------------------------- + +-- |A message digest is essentially an array of 'Word8' octets. + +type MessageDigest = StrictByteString + +-- | Compute the given message digest of any 'Digestable' thing, i.e. any type +-- that can be converted /efficiently/ and /unambiguously/ into a continuous +-- memory buffer or a sequence of continuous memory buffers. Note that 'String' +-- does /not/ have that property, because there . The actual +-- binary representation chosen for Unicode characters during that process is +-- determined by the system's locale and is therefore non-deterministic. + +digest :: Digestable a => DigestDescription -> a -> MessageDigest +digest algo input = + IO.unsafePerformIO $ + bracket createContext destroyContext $ \ctx -> do + initDigest algo ctx + updateChunk ctx input + let mdSize = fromIntegral (_digestSize (getDigestDescription algo)) + allocaArray mdSize $ \md -> do + finalizeDigest ctx md + Strict.packCStringLen (castPtr md, mdSize) + +class Digestable a where + updateChunk :: DigestContext -> a -> IO () + +instance Digestable (Ptr a, CSize) where + {-# INLINE updateChunk #-} + updateChunk ctx = uncurry (updateDigest ctx) + +instance Digestable (Ptr a, CUInt) where + {-# INLINE updateChunk #-} + updateChunk ctx = updateChunk ctx . fmap (fromIntegral :: CUInt -> CSize) + +instance Digestable (Ptr a, CInt) where + {-# INLINE updateChunk #-} + updateChunk ctx = updateChunk ctx . fmap (fromIntegral :: CInt -> CSize) + +instance Digestable (Ptr a, Int) where + {-# INLINE updateChunk #-} + updateChunk ctx = updateChunk ctx . fmap (fromIntegral :: Int -> CSize) + +instance Digestable [Word8] where + {-# INLINE updateChunk #-} + updateChunk ctx buf = withArrayLen buf $ \len ptr -> updateChunk ctx (ptr,len) + +instance Digestable StrictByteString where + {-# INLINE updateChunk #-} + updateChunk ctx str = unsafeUseAsCStringLen str (updateChunk ctx) + +instance Digestable LazyByteString where + {-# INLINE updateChunk #-} + updateChunk ctx = mapM_ (updateChunk ctx) . Lazy.toChunks + +-- |We do /not/ define a 'Digestable' instance for 'String', because there is +-- no one obviously correct way to encode Unicode characters for purposes of +-- calculating a digest. We have, however, this specialized function which +-- computes a digest over a @String@ by means of 'withCStrinLen'. This means +-- that the representation of Unicode characters depends on the process locale +-- a.k.a. it's non-deterministc! +-- +-- >>> toHex $ digestString (digestByName "sha1") "Hello, world." +-- "2ae01472317d1935a84797ec1983ae243fc6aa28" + +digestString :: DigestDescription -> String -> MessageDigest +digestString algo str = IO.unsafePerformIO $ + withCStringLen str (return . digest algo) + +-- Helper functions ----------------------------------------------------------- + +-- | Synonym for the strict 'Strict.ByteString' variant to improve readability. + +type StrictByteString = Strict.ByteString + +-- | Synonym for the lazy 'Lazy.ByteString' variant to improve readability. + +type LazyByteString = Lazy.ByteString + +-- | Pretty-print a given message digest from binary into hexadecimal +-- representation. +-- +-- >>> toHex (Data.ByteString.pack [0..15]) +-- "000102030405060708090a0b0c0d0e0f" + +toHex :: MessageDigest -> StrictByteString +toHex = Strict.concatMap f + where + f :: Word8 -> StrictByteString + f w = case showHex w "" of + [w1,w2] -> pack [w1, w2] + [w2] -> pack ['0', w2] + _ -> error "showHex returned []" diff --git a/src/OpenSSL/EVP/Digest.hsc b/src/OpenSSL/EVP/Digest.hsc new file mode 100644 --- /dev/null +++ b/src/OpenSSL/EVP/Digest.hsc @@ -0,0 +1,260 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE DeriveDataTypeable #-} + +{- | + Maintainer: simons@cryp.to + Stability: provisional + Portability: portable + + Computing message digests with OpenSSL's EVP interface involves the + following types: + + * Every digest algorithm has an description, 'OpaqueDigestDescription' that + can be looked up by name. We can do very few things with that type. We + can use it to retrieve the size of the algorithm's output, '_digestSize' + + * TODO: complete this when I know what the high-level API looks like. + +-} + +module OpenSSL.EVP.Digest where + +import Control.Concurrent.MVar +import Control.Exception +import Control.Monad +import Data.Maybe +import Data.String ( IsString(..) ) +import Data.Typeable ( Typeable ) +import Foreign +import Foreign.C +import Numeric ( showHex ) +import System.IO.Unsafe as IO + +#include "openssl/evp.h" + +#if __GLASGOW_HASKELL__ < 800 +# let alignment t = "%lu", (unsigned long)offsetof(struct {char x__; t (y__); }, y__) +#endif + +-- * Low-level API + +------------------------------------------------------------------------------- +-- ** OpenSSL Library Initialization +------------------------------------------------------------------------------- + +-- | Initialize the OpenSSL EVP engine and register all known digest types in +-- the internal data structures. This function must be called before +-- '_digestByName' can succeed. Calling it multiple times is probably not +-- harmful, but it certainly unnecessary and should be avoided. Users of +-- 'digestByName'' and 'digestByName' don't have to worry about this. + +foreign import ccall unsafe "openssl/evp.h OpenSSL_add_all_digests" _addAllDigests :: IO () + +------------------------------------------------------------------------------- +-- ** Accessing the Supported Digest Types +------------------------------------------------------------------------------- + +data OpaqueDigestDescription + +-- | Look up a 'Digest' by name. Be sure to call '_addAllDigests' before you +-- use this function. + +foreign import ccall unsafe "openssl/evp.h EVP_get_digestbyname" _digestByName :: CString -> Ptr OpaqueDigestDescription + +-- | Return the size of the digest the given algorithm will produce. + +foreign import ccall unsafe "openssl/evp.h EVP_MD_size" _digestSize :: Ptr OpaqueDigestDescription -> CInt + +-- | Return the block size the the given algorithm operates with. + +foreign import ccall unsafe "openssl/evp.h EVP_MD_block_size" _digestBlockSize :: Ptr OpaqueDigestDescription -> CInt + +-- | The largest possible digest size of any of the algorithms supported by +-- this library. So if you want to store a digest without bothering to retrieve +-- the appropriate size with '_digestSize' first, allocate a buffer of that +-- size. + +maxDigestSize :: Int +maxDigestSize = #{const EVP_MAX_MD_SIZE} + +-- | We don't support choosing specific engines. Always pass 'nullPtr' where +-- such a thing is expected to get the default engine for the given algorithm. + +data OpaqueDigestEngine + +------------------------------------------------------------------------------- +-- ** Digest Contexts +------------------------------------------------------------------------------- + +-- | A context in which -- when initialized -- digest computations can be run. +-- There is a 'Storable' solely for the benefit of being able to create that +-- type with 'alloca' and '_init' instead of having to use '_create', which +-- uses the heap. Anyway, that instance does not define 'peek' nor 'poke' since +-- those make no sense. + +data OpaqueDigestContext + +instance Storable OpaqueDigestContext where + sizeOf _ = #{size EVP_MD_CTX} + alignment _ = #{alignment EVP_MD_CTX} + peek _ = error "Don't do this. OpaqueDigestContext is, like, opaque." + poke _ _ = error "Don't do this. OpaqueDigestContext is, like, opaque." + +-- | Allocate an (initialized) 'OpaqueDigestContext' for use in a digest +-- computation on the heap. Release its underlying memory after use with +-- '_destroy'. + +foreign import ccall unsafe "openssl/evp.h EVP_MD_CTX_create" _createContext :: IO (Ptr OpaqueDigestContext) + +-- | Initialize an 'OpaqueDigestContext' for use in a digest computation. The +-- type can be allocated on the stack with 'alloca' or on the heap with +-- '_create'. + +foreign import ccall unsafe "openssl/evp.h EVP_MD_CTX_init" _initContext :: Ptr OpaqueDigestContext -> IO () + +-- | Release all resources associated with a digest computation's context, but +-- don't release the underlying digest context structure. This allows the context +-- to be re-initiaized for use another computation. + +foreign import ccall unsafe "openssl/evp.h EVP_MD_CTX_cleanup" _cleanupContext :: Ptr OpaqueDigestContext -> IO CInt + +-- | Release all resources associated with a digest computation's context and the +-- context structure itself. Use this only for context's acquired with '_create'. + +foreign import ccall unsafe "openssl/evp.h EVP_MD_CTX_destroy" _destroyContext :: Ptr OpaqueDigestContext -> IO () + +------------------------------------------------------------------------------- +-- ** State of a Digest Computation +------------------------------------------------------------------------------- + +-- | Configure the given /initialized/ digest context to use the given message +-- digest algorithm. The third parameter allows developers to choose a specific +-- engine for that digest, too, but these bindings don't support choosing any +-- specific engine, so pass 'nullPtr' here to the default choice determined by +-- OpenSSL. + +foreign import ccall unsafe "openssl/evp.h EVP_DigestInit_ex" _initDigest :: Ptr OpaqueDigestContext -> Ptr OpaqueDigestDescription -> Ptr OpaqueDigestEngine -> IO CInt + +-- | Hash the given block of memory and update the digest state accordingly. +-- Naturally, this function can be called many times. Then use +-- '_finalizeDigest' to retrieve the actual hash value. + +foreign import ccall unsafe "openssl/evp.h EVP_DigestUpdate" _updateDigest :: Ptr OpaqueDigestContext -> Ptr a -> CSize -> IO CInt + +-- | Finalize the digest calculation and return the result in the 'Word8' array +-- passed as an argument. Naturally, that array is expected to be large enough +-- to contain the digest. '_digestSize' or 'maxDigestSize' are your friends. If +-- the 'CUInt' pointer is not 'nullPtr', then the actual size of the generated +-- digest is written into that integer. This function does /not/ clean up the +-- digest context; this has to be done with an explicit call to +-- '_cleanupContext' or '_destroyContext'. However, it does invalidate the +-- digest state so that no further calls of '_digestUpdate' can be made without +-- re-initializing the state with '_initDigest' first. + +foreign import ccall unsafe "openssl/evp.h EVP_DigestFinal_ex" _finalizeDigest :: Ptr OpaqueDigestContext -> Ptr Word8 -> Ptr CUInt -> IO CInt + +------------------------------------------------------------------------------- +-- * High-level interface +------------------------------------------------------------------------------- + +newtype DigestDescription = DigestDescription { getDigestDescription :: Ptr OpaqueDigestDescription } + deriving (Show, Eq) + +digestByName :: String -> DigestDescription +digestByName algo = + fromMaybe (throw (DigestAlgorithmNotAvailableInOpenSSL algo)) + (digestByName' algo) + +digestByName' :: String -> Maybe DigestDescription +digestByName' algo = if ptr == nullPtr then Nothing else Just (DigestDescription ptr) + where ptr = IO.unsafePerformIO $ withCString algo $ \name -> do + modifyMVar_ isDigestEngineInitialized $ \isInitialized -> + unless isInitialized _addAllDigests >> return True + return (_digestByName name) + +newtype DigestContext = DigestContext { getDigestContext :: Ptr OpaqueDigestContext } + +digestContext :: Ptr OpaqueDigestContext -> DigestContext +digestContext ptr + | ptr == nullPtr = throw AttemptToConstructDigestContextFromNullPointer + | otherwise = DigestContext ptr + +initContext :: DigestContext -> IO () +initContext (DigestContext ctx) = _initContext ctx + +createContext :: IO DigestContext +createContext = + fmap DigestContext (throwIfNull "OpenSSL.EVP.Digest.createContext failed" _createContext) + +-- | Simplified variant of '_initDigest' that (a) always chooses the default +-- digest engine and (b) reports failure by means of an exception. + +initDigest :: DigestDescription -> DigestContext -> IO () +initDigest (DigestDescription algo) (DigestContext ctx) = + throwIfZero "OpenSSL.EVP.Digest.initDigest" (_initDigest ctx algo nullPtr) + +cleanupContext :: DigestContext -> IO () +cleanupContext (DigestContext ctx) = + throwIfZero "OpenSSL.EVP.Digest.cleanupContext" (_cleanupContext ctx) + +destroyContext :: DigestContext -> IO () +destroyContext (DigestContext ctx) = _destroyContext ctx + +updateDigest :: DigestContext -> Ptr a -> CSize -> IO () +updateDigest (DigestContext ctx) ptr len = + throwIfZero "OpenSSL.EVP.Digest.updateDigest" (_updateDigest ctx ptr len) + +finalizeDigest :: DigestContext -> Ptr Word8 -> IO () +finalizeDigest (DigestContext ctx) ptr = + throwIfZero "OpenSSL.EVP.Digest.finalizeDigest" (_finalizeDigest ctx ptr nullPtr) + +-- * Helper Types and Functions + +-- | Most OpenSSL functions return an approximation of @Bool@ to signify +-- failure. This wrapper makes it easier to move the error handling to the +-- exception layer where appropriate. + +throwIfZero :: String -> IO CInt -> IO () +throwIfZero fname = + throwIf_ (==0) (const (showString fname " failed with error code 0")) + +-- |Neat helper to pretty-print digests into the common hexadecimal notation: +-- +-- >>> [0..15] >>= toHex +-- "000102030405060708090a0b0c0d0e0f" + +toHex :: Word8 -> String +toHex w = case showHex w "" of + [w1,w2] -> [w1, w2] + [w2] -> ['0', w2] + _ -> "showHex returned []" + +{-# NOINLINE isDigestEngineInitialized #-} +isDigestEngineInitialized :: MVar Bool +isDigestEngineInitialized = IO.unsafePerformIO $ newMVar False + +-- | This instance allows the compiler to translate the string @"sha256"@ into +-- @digestByName "sha256"@ whenever a 'String' is passed in a location that +-- expects a 'DigestDescription'. If that digest engine does not exist, then an +-- exception is thrown. This feature requires the @OverloadedStrings@ extension +-- enabled. + +instance IsString DigestDescription where + fromString = digestByName + +-- | A custom exception type which is thrown by 'digestByName' in case the +-- requested digest algorithm is not available in the OpenSSL system library. + +newtype DigestAlgorithmNotAvailableInOpenSSL = DigestAlgorithmNotAvailableInOpenSSL String + deriving (Show, Typeable) + +instance Exception DigestAlgorithmNotAvailableInOpenSSL + +-- | A custom exception type thrown by 'digestContext' if the function is used +-- to construct a 'DigestContext' from a 'nullPtr'. + +data AttemptToConstructDigestContextFromNullPointer = AttemptToConstructDigestContextFromNullPointer + deriving (Show, Typeable) + +instance Exception AttemptToConstructDigestContextFromNullPointer diff --git a/test/CheckHighLevelDigestAPI.hs b/test/CheckHighLevelDigestAPI.hs new file mode 100644 --- /dev/null +++ b/test/CheckHighLevelDigestAPI.hs @@ -0,0 +1,18 @@ +module Main ( main ) where + +import OpenSSL.Digest +import OpenSesame + +import Test.HUnit + +main :: IO () +main = runTestTT (TestList tests) >> return () + +tests :: [Test] +tests = map (uncurry (mkTest "open sesame")) opensesame + +mkTest :: String -> String -> String -> Test +mkTest input algoName expect = TestCase $ + case digestByName' algoName of + Nothing -> return () + Just algo -> assertEqual algoName expect (show (toHex (digestString algo input))) diff --git a/test/CheckLowLevelDigestAPI.hs b/test/CheckLowLevelDigestAPI.hs new file mode 100644 --- /dev/null +++ b/test/CheckLowLevelDigestAPI.hs @@ -0,0 +1,34 @@ +module Main ( main ) where + +import OpenSSL.EVP.Digest +import OpenSesame + +import Control.Exception +import Foreign +import Foreign.C.String +import Test.HUnit + +main :: IO () +main = runTestTT (TestList tests) >> return () + +tests :: [Test] +tests = map (uncurry (mkTest "open sesame")) opensesame + +mkTest :: String -> String -> String -> Test +mkTest input algoName expect = TestCase $ + case digestByName' algoName of + Nothing -> return () + Just algo -> digest algo input >>= assertEqual algoName expect + +digest :: DigestDescription -> String -> IO String +digest algo input = do + let digestSize = _digestSize (getDigestDescription algo) + md <- alloca $ \ctx' -> do + let ctx = digestContext ctx' + bracket_ (initContext ctx) (cleanupContext ctx) $ do + initDigest algo ctx + withCStringLen input $ \(ptr,len) -> updateDigest ctx ptr (fromIntegral len) + allocaArray (fromIntegral digestSize) $ \md -> do + finalizeDigest ctx md + peekArray (fromIntegral digestSize) md + return (md >>= toHex) diff --git a/test/OpenSesame.hs b/test/OpenSesame.hs new file mode 100644 --- /dev/null +++ b/test/OpenSesame.hs @@ -0,0 +1,15 @@ +module OpenSesame where + +opensesame :: [(String, String)] +opensesame = [ ("MD5", "54ef36ec71201fdf9d1423fd26f97f6b") + , ("SHA", "2ccefef64c76ac0d42ca1657457977675890c42f") + , ("SHA1", "5bcaff7f22ff533ca099b3408ead876c0ebba9a7") + , ("DSS", "5bcaff7f22ff533ca099b3408ead876c0ebba9a7") + , ("DSS1", "5bcaff7f22ff533ca099b3408ead876c0ebba9a7") + , ("RIPEMD160", "bdb2bba6ec93bd566dc1181cadbc92176aa78382") + , ("MDC2", "112db2200ce1e9db3c2d132aea4ef7d0") + , ("SHA224", "1ee0f9d93a873a67fe781852d716cb3e5904e015aafaa4d1ff1a81bc") + , ("SHA256", "41ef4bb0b23661e66301aac36066912dac037827b4ae63a7b1165a5aa93ed4eb") + , ("SHA384", "ae2a5d6649035c00efe2bc1b5c97f4d5ff97fa2df06f273afa0231c425e8aff30e4cc1db5e5756e8d2245a1514ad1a2d") + , ("SHA512", "8470cdd3bf1ef85d5f092bce5ae5af97ce50820481bf43b2413807fec37e2785b533a65d4c7d71695b141d81ebcd4b6c4def4284e6067f0b9ddc318b1b230205") + ] diff --git a/test/doctests.hs b/test/doctests.hs new file mode 100644 --- /dev/null +++ b/test/doctests.hs @@ -0,0 +1,12 @@ +module Main (main) where + +import Test.DocTest +import System.Environment +import Data.Maybe + +main :: IO () +main = do + distDir <- fromMaybe "dist" `fmap` lookupEnv "HASKELL_DIST_DIR" + let hscFilesDir = distDir ++ "/build" + packageDB = distDir ++ "/package.conf.inplace" + doctest [ "-i" ++ hscFilesDir, "-package-db=" ++ packageDB, "-package=hopenssl", "src" ]