hopenssl 1.7 → 2

raw patch · 10 files changed

+593/−336 lines, 10 filesdep +HUnitdep +doctestdep +hopenssldep −mtldep ~basePVP ok

version bump matches the API change (PVP)

Dependencies added: HUnit, doctest, hopenssl

Dependencies removed: mtl

Dependency ranges changed: base

API changes (from Hackage documentation)

Files

• OpenSSL/Digest.hs +0/−237
• OpenSSL/Digest/ByteString.hs +0/−38
• OpenSSL/Digest/ByteString/Lazy.hs +0/−32
• hopenssl.cabal +53/−29
• src/OpenSSL/Digest.hs +201/−0
• src/OpenSSL/EVP/Digest.hsc +260/−0
• test/CheckHighLevelDigestAPI.hs +18/−0
• test/CheckLowLevelDigestAPI.hs +34/−0
• test/OpenSesame.hs +15/−0
• test/doctests.hs +12/−0

@@ -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 []"

@@ -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)

@@ -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

@@ -1,31 +1,55 @@-Name:                   hopenssl-Version:                1.7-Copyright:              (c) 2004-2013 Peter Simons-License:                BSD3-License-File:           LICENSE-Author:                 Peter Simons <simons@cryp.to>,-                        Jesper Louis Andersen <jesper.louis.andersen@gmail.com>,-                        Markus Rothe <markus@unixforces.net>-Maintainer:             Peter Simons <simons@cryp.to>-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-                        <http://www.openssl.org/>. 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 <simons@cryp.to>+homepage:               http://github.com/peti/hopenssl+category:               Foreign, Cryptography+synopsis:               FFI bindings to OpenSSL's EVP digest interface+description:            Foreign-function bindings to the+                        <http://www.openssl.org/ 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.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

@@ -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 []"

@@ -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

@@ -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)))

@@ -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)

@@ -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")+             ]

@@ -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" ]