add template for hash generation and the little program associated with it

gen/Gen.hs

@@ -0,0 +1,68 @@
+module Main where
+
+import System.FilePath
+import System.Directory
+import Control.Applicative
+import Control.Monad
+import Template
+
+readTemplate templateFile = parseTemplate <$> readFile templateFile
+writeTemplate file vars template = writeFile file (renderTemplate template vars)
+
+data GenHashModule = GenHashModule
+    { ghmModuleName   :: String
+    , ghmHeaderFile   :: String
+    , ghmHashName     :: String
+    , ghmContextSize  :: Int
+    , ghmDigestSize   :: Int
+    , ghmBlockLength  :: Int
+    , ghmCustomizable :: Bool
+    } deriving (Show,Eq)
+
+hashModules =
+    [ GenHashModule "MD2"       "md2.h"       "md2"       96  16 16  False
+    , GenHashModule "MD4"       "md4.h"       "md4"       96  16 64  False
+    , GenHashModule "MD5"       "md5.h"       "md5"       96  16 64  False
+    , GenHashModule "SHA1"      "sha1.h"      "sha1"      96  20 64  False
+    , GenHashModule "SHA224"    "sha256.h"    "sha224"    192 28 64  False
+    , GenHashModule "SHA256"    "sha256.h"    "sha256"    192 32 64  False
+    , GenHashModule "SHA384"    "sha512.h"    "sha384"    256 48 128 False
+    , GenHashModule "SHA512"    "sha512.h"    "sha512"    256 64 128 False
+    , GenHashModule "Kekkak"    "kekkak.h"    "kekkak"    360 64 64  True
+    , GenHashModule "SHA3"      "sha3.h"      "sha3"      360 64 64  True
+    , GenHashModule "RIPEMD160" "ripemd.h"    "ripemd160" 128 20 64  False
+    , GenHashModule "Skein256"  "skein256.h"  "skein256"  96  32 32  True
+    , GenHashModule "Skein512"  "skein512.h"  "skein512"  160 64 64  True
+    , GenHashModule "Tiger"     "tiger.h"     "tiger"     96  24 64  False
+    , GenHashModule "Whirlpool" "whirlpool.h" "whirlpool" 168 64 64  False
+    ]
+
+renderHashModules genOpts = do
+    hashTemplate            <- readTemplate "template/hash.hs"
+    hashInternalTemplate    <- readTemplate "template/hash-internal.hs"
+    hashLenTemplate         <- readTemplate "template/hash-len.hs"
+    hashLenInternalTemplate <- readTemplate "template/hash-internal-len.hs"
+    forM_ hashModules $ \ghm -> do
+        let vars = [ ("MODULENAME", ghmModuleName ghm)
+                   , ("HEADER_FILE", ghmHeaderFile ghm)
+                   , ("HASHNAME", ghmHashName ghm)
+                   , ("SIZECTX", show (ghmContextSize ghm))
+                   , ("DIGESTSIZE", show (ghmDigestSize ghm))
+                   , ("SIZECTX8", show (ghmContextSize ghm `div` 8))
+                   , ("BLOCKLEN", show (ghmBlockLength ghm))
+                   ]
+        let mainDir      = "Crypto/Hash"
+            internalDir  = "Crypto/Hash/Internal"
+            mainName     = mainDir </> (ghmModuleName ghm ++ ".hs")
+            internalName = internalDir </> (ghmModuleName ghm ++ ".hs")
+
+        createDirectoryIfMissing True mainDir
+        createDirectoryIfMissing True internalDir
+        if ghmCustomizable ghm
+            then do writeTemplate mainName vars hashLenTemplate
+                    writeTemplate internalName vars hashLenInternalTemplate
+            else do writeTemplate mainName vars hashTemplate
+                    writeTemplate internalName vars hashInternalTemplate
+
+main = do
+    renderHashModules ()

gen/Template.hs

@@ -0,0 +1,65 @@
+-- |
+-- Module      : Template
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : portable
+--
+-- A very simple template engine
+--
+module Template
+    ( Template
+    , parseTemplate
+    , renderTemplate
+    ) where
+
+import Data.Char (isDigit, isAlpha)
+import Data.List (isPrefixOf)
+
+data TAtom = Text String | Var String deriving (Show)
+type Template = [TAtom]
+
+renderTemplate :: Template -> [(String,String)] -> String
+renderTemplate template attrs =
+    concat $ map renderAtom template
+  where
+        renderAtom :: TAtom -> String
+        renderAtom (Text b) = b
+        renderAtom (Var s)  = maybe "" id $ lookup s attrs
+
+parseTemplate :: String -> Template
+parseTemplate content 
+    | null content            = []
+    | isPrefixOf "%%" content = parseVar $ tailMarker content
+    | otherwise               = parseText content
+  where
+        parseText :: String -> Template
+        parseText s
+            | null s    = []
+            | otherwise = Text b : (parseVar $ tailMarker a)
+          where
+                (b, a) = grabUntilMarker s
+
+        parseVar :: String -> Template
+        parseVar s
+            | null s    = []
+            | otherwise =
+                let (b, a) = grabUntilMarker s in
+                if isVariable b
+                    then Var b  : (parseText $ tailMarker a)
+                    else Text b : (parseVar $ tailMarker a)
+
+        isVariable :: String -> Bool
+        isVariable = and . map isVariableChar
+          where isVariableChar :: Char -> Bool
+                isVariableChar c = isAlpha c || isDigit c || c == '_'
+
+        tailMarker ('%':'%':xs) = xs
+        tailMarker s            = s
+            
+        grabUntilMarker = loop
+          where loop []             = ([], [])
+                loop l@('%':'%':xs) = ([], l)
+                loop (x:xs)         =
+                    let (l1,l2) = loop xs
+                     in (x:l1,l2)

gen/template/hash-internal-len.hs

@@ -0,0 +1,104 @@
+{-# LANGUAGE ForeignFunctionInterface, CPP, MultiParamTypeClasses #-}
+
+-- |
+-- Module      : Crypto.Hash.Internal.%%MODULENAME%%
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- A module containing %%MODULENAME%% bindings
+--
+module Crypto.Hash.Internal.%%MODULENAME%%
+    ( Ctx(..)
+    -- * Internal values
+    , sizeCtx
+    -- * Internal IO hash functions
+    , internalInit
+    , internalInitAt
+    , internalUpdate
+    , internalFinalize
+    -- * Context copy and creation
+    , withCtxCopy
+    , withCtxNewThrow
+    , withCtxThrow
+    ) where
+
+import Prelude hiding (init)
+import Foreign.Ptr
+import Foreign.ForeignPtr (withForeignPtr)
+import Foreign.Storable
+import Foreign.Marshal.Alloc
+import Data.ByteString (ByteString)
+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
+import Data.ByteString.Internal (create, toForeignPtr)
+import Data.Word
+
+newtype Ctx = Ctx ByteString
+
+{- return the number of bytes of output for the digest -}
+peekHashlen :: Ptr Ctx -> IO Int
+peekHashlen ptr = peek iptr >>= \v -> return $! fromIntegral v
+    where iptr :: Ptr Word32
+          iptr = castPtr ptr
+
+{-# INLINE sizeCtx #-}
+sizeCtx :: Int
+sizeCtx = %%SIZECTX%%
+
+{-# INLINE withByteStringPtr #-}
+withByteStringPtr :: ByteString -> (Ptr Word8 -> IO a) -> IO a
+withByteStringPtr b f =
+    withForeignPtr fptr $ \ptr -> f (ptr `plusPtr` off)
+    where (fptr, off, _) = toForeignPtr b
+
+{-# INLINE memcopy64 #-}
+memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO ()
+memcopy64 dst src = mapM_ peekAndPoke [0..(%%SIZECTX8%%-1)]
+    where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i
+
+withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx
+withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx
+    where createCtx = create sizeCtx $ \dstPtr ->
+                      withByteStringPtr ctxB $ \srcPtr -> do
+                          memcopy64 (castPtr dstPtr) (castPtr srcPtr)
+                          f (castPtr dstPtr)
+
+withCtxThrow :: Ctx -> (Ptr Ctx -> IO a) -> IO a
+withCtxThrow (Ctx ctxB) f =
+    allocaBytes sizeCtx $ \dstPtr ->
+    withByteStringPtr ctxB $ \srcPtr -> do
+        memcopy64 (castPtr dstPtr) (castPtr srcPtr)
+        f (castPtr dstPtr)
+
+withCtxNew :: (Ptr Ctx -> IO ()) -> IO Ctx
+withCtxNew f = Ctx `fmap` create sizeCtx (f . castPtr)
+
+withCtxNewThrow :: (Ptr Ctx -> IO a) -> IO a
+withCtxNewThrow f = allocaBytes sizeCtx (f . castPtr)
+
+foreign import ccall unsafe "cryptonite_%%HEADER_FILE%% cryptonite_%%HASHNAME%%_init"
+    c_%%HASHNAME%%_init :: Ptr Ctx -> Word32 -> IO ()
+
+foreign import ccall "cryptonite_%%HEADER_FILE%% cryptonite_%%HASHNAME%%_update"
+    c_%%HASHNAME%%_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO ()
+
+foreign import ccall unsafe "cryptonite_%%HEADER_FILE%% cryptonite_%%HASHNAME%%_finalize"
+    c_%%HASHNAME%%_finalize :: Ptr Ctx -> Ptr Word8 -> IO ()
+
+internalInitAt :: Int -> Ptr Ctx -> IO ()
+internalInitAt hashlen ptr = c_%%HASHNAME%%_init ptr (fromIntegral hashlen)
+
+-- | init a context
+internalInit :: Int -> IO Ctx
+internalInit hashlen = withCtxNew (internalInitAt hashlen)
+
+-- | Update a context in place
+internalUpdate :: Ptr Ctx -> ByteString -> IO ()
+internalUpdate ptr d =
+    unsafeUseAsCStringLen d (\(cs, len) -> c_%%HASHNAME%%_update ptr (castPtr cs) (fromIntegral len))
+
+-- | Finalize a context in place
+internalFinalize :: Ptr Ctx -> IO ByteString
+internalFinalize ptr =
+    peekHashlen ptr >>= \digestSize -> create digestSize (c_%%HASHNAME%%_finalize ptr)

gen/template/hash-internal.hs

@@ -0,0 +1,101 @@
+{-# LANGUAGE ForeignFunctionInterface, CPP, MultiParamTypeClasses #-}
+
+-- |
+-- Module      : Crypto.Hash.Internal.%%MODULENAME%%
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- A module containing %%MODULENAME%% bindings
+--
+module Crypto.Hash.Internal.%%MODULENAME%%
+    ( Ctx(..)
+    -- * Internal values
+    , digestSize
+    , sizeCtx
+    -- * Internal IO hash functions
+    , internalInit
+    , internalInitAt
+    , internalUpdate
+    , internalFinalize
+    -- * Context copy and creation
+    , withCtxCopy
+    , withCtxNewThrow
+    , withCtxThrow
+    ) where
+
+import Foreign.Ptr
+import Foreign.ForeignPtr (withForeignPtr)
+import Foreign.Storable
+import Foreign.Marshal.Alloc
+import Data.ByteString (ByteString)
+import Data.ByteString.Unsafe (unsafeUseAsCStringLen)
+import Data.ByteString.Internal (create, toForeignPtr)
+import Data.Word
+
+newtype Ctx = Ctx ByteString
+
+{-# INLINE digestSize #-}
+digestSize :: Int
+digestSize = %%DIGESTSIZE%%
+
+{-# INLINE sizeCtx #-}
+sizeCtx :: Int
+sizeCtx = %%SIZECTX%%
+
+{-# INLINE withByteStringPtr #-}
+withByteStringPtr :: ByteString -> (Ptr Word8 -> IO a) -> IO a
+withByteStringPtr b f =
+    withForeignPtr fptr $ \ptr -> f (ptr `plusPtr` off)
+    where (fptr, off, _) = toForeignPtr b
+
+{-# INLINE memcopy64 #-}
+memcopy64 :: Ptr Word64 -> Ptr Word64 -> IO ()
+memcopy64 dst src = mapM_ peekAndPoke [0..(%%SIZECTX8%%-1)]
+    where peekAndPoke i = peekElemOff src i >>= pokeElemOff dst i
+
+withCtxCopy :: Ctx -> (Ptr Ctx -> IO ()) -> IO Ctx
+withCtxCopy (Ctx ctxB) f = Ctx `fmap` createCtx
+    where createCtx = create sizeCtx $ \dstPtr ->
+                      withByteStringPtr ctxB $ \srcPtr -> do
+                          memcopy64 (castPtr dstPtr) (castPtr srcPtr)
+                          f (castPtr dstPtr)
+
+withCtxThrow :: Ctx -> (Ptr Ctx -> IO a) -> IO a
+withCtxThrow (Ctx ctxB) f =
+    allocaBytes sizeCtx $ \dstPtr ->
+    withByteStringPtr ctxB $ \srcPtr -> do
+        memcopy64 (castPtr dstPtr) (castPtr srcPtr)
+        f (castPtr dstPtr)
+
+withCtxNew :: (Ptr Ctx -> IO ()) -> IO Ctx
+withCtxNew f = Ctx `fmap` create sizeCtx (f . castPtr)
+
+withCtxNewThrow :: (Ptr Ctx -> IO a) -> IO a
+withCtxNewThrow f = allocaBytes sizeCtx (f . castPtr)
+
+foreign import ccall unsafe "cryptonite_%%HEADER_FILE%% cryptonite_%%HASHNAME%%_init"
+    c_%%HASHNAME%%_init :: Ptr Ctx -> IO ()
+
+foreign import ccall "cryptonite_%%HEADER_FILE%% cryptonite_%%HASHNAME%%_update"
+    c_%%HASHNAME%%_update :: Ptr Ctx -> Ptr Word8 -> Word32 -> IO ()
+
+foreign import ccall unsafe "cryptonite_%%HEADER_FILE%% cryptonite_%%HASHNAME%%_finalize"
+    c_%%HASHNAME%%_finalize :: Ptr Ctx -> Ptr Word8 -> IO ()
+
+internalInitAt :: Ptr Ctx -> IO ()
+internalInitAt = c_%%HASHNAME%%_init
+
+-- | init a context
+internalInit :: IO Ctx
+internalInit = withCtxNew internalInitAt
+
+-- | Update a context in place
+internalUpdate :: Ptr Ctx -> ByteString -> IO ()
+internalUpdate ptr d =
+    unsafeUseAsCStringLen d (\(cs, len) -> c_%%HASHNAME%%_update ptr (castPtr cs) (fromIntegral len))
+
+-- | Finalize a context in place
+internalFinalize :: Ptr Ctx -> IO ByteString
+internalFinalize ptr = create digestSize (c_%%HASHNAME%%_finalize ptr)

gen/template/hash-len.hs

@@ -0,0 +1,74 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+-- |
+-- Module      : Crypto.Hash.%%MODULENAME%%
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- module containing the pure functions to work with the
+-- %%MODULENAME%% cryptographic hash.
+--
+-- it is recommended to import this module qualified.
+--
+module Crypto.Hash.%%MODULENAME%%
+    ( Ctx(..)
+
+    -- * Incremental hashing Functions
+    , init     -- :: Int -> Ctx
+    , update   -- :: Ctx -> ByteString -> Ctx
+    , updates  -- :: Ctx -> [ByteString] -> Ctx
+    , finalize -- :: Ctx -> ByteString
+
+    -- * Single Pass hashing
+    , hash     -- :: Int -> ByteString -> ByteString
+    , hashlazy -- :: Int -> ByteString -> ByteString
+    ) where
+
+import Prelude hiding (init)
+import qualified Data.ByteString.Lazy as L
+import Data.ByteString (ByteString)
+import Crypto.Hash.Internal (unsafeDoIO)
+import Crypto.Hash.Internal.%%MODULENAME%%
+
+{-# NOINLINE init #-}
+-- | init a context where
+init :: Int -- ^ algorithm hash size in bits
+     -> Ctx
+init hashlen = unsafeDoIO (internalInit hashlen)
+
+{-# NOINLINE update #-}
+-- | update a context with a bytestring returning the new updated context
+update :: Ctx        -- ^ the context to update
+       -> ByteString -- ^ the data to update with
+       -> Ctx        -- ^ the updated context
+update ctx d = unsafeDoIO $ withCtxCopy ctx $ \ptr -> internalUpdate ptr d
+
+{-# NOINLINE updates #-}
+-- | updates a context with multiples bytestring returning the new updated context
+updates :: Ctx          -- ^ the context to update
+        -> [ByteString] -- ^ a list of data bytestring to update with
+        -> Ctx          -- ^ the updated context
+updates ctx d = unsafeDoIO $ withCtxCopy ctx $ \ptr -> mapM_ (internalUpdate ptr) d
+
+{-# NOINLINE finalize #-}
+-- | finalize the context into a digest bytestring
+finalize :: Ctx -> ByteString
+finalize ctx = unsafeDoIO $ withCtxThrow ctx internalFinalize
+
+{-# NOINLINE hash #-}
+-- | hash a strict bytestring into a digest bytestring
+hash :: Int        -- ^ algorithm hash size in bits
+     -> ByteString -- ^ the data to hash
+     -> ByteString -- ^ the digest output
+hash hashlen d = unsafeDoIO $ withCtxNewThrow $ \ptr -> do
+    internalInitAt hashlen ptr >> internalUpdate ptr d >> internalFinalize ptr
+
+{-# NOINLINE hashlazy #-}
+-- | hash a lazy bytestring into a digest bytestring
+hashlazy :: Int          -- ^ algorithm hash size in bits
+         -> L.ByteString -- ^ the data to hash as a lazy bytestring
+         -> ByteString   -- ^ the digest output
+hashlazy hashlen l = unsafeDoIO $ withCtxNewThrow $ \ptr -> do
+    internalInitAt hashlen ptr >> mapM_ (internalUpdate ptr) (L.toChunks l) >> internalFinalize ptr

gen/template/hash.hs

@@ -0,0 +1,74 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+
+-- |
+-- Module      : Crypto.Hash.%%MODULENAME%%
+-- License     : BSD-style
+-- Maintainer  : Vincent Hanquez <vincent@snarc.org>
+-- Stability   : experimental
+-- Portability : unknown
+--
+-- module containing the pure functions to work with the
+-- %%MODULENAME%% cryptographic hash.
+--
+-- it is recommended to import this module qualified.
+--
+module Crypto.Hash.%%MODULENAME%%
+    ( Ctx(..)
+
+    -- * Incremental hashing Functions
+    , init     -- :: Ctx
+    , update   -- :: Ctx -> ByteString -> Ctx
+    , updates  -- :: Ctx -> [ByteString] -> Ctx
+    , finalize -- :: Ctx -> ByteString
+
+    -- * Single Pass hashing
+    , hash     -- :: ByteString -> ByteString
+    , hashlazy -- :: ByteString -> ByteString
+    ) where
+
+import Prelude hiding (init)
+import qualified Data.ByteString.Lazy as L
+import Data.ByteString (ByteString)
+import Crypto.Hash.Internal (unsafeDoIO)
+import Crypto.Hash.Internal.%%MODULENAME%%
+
+{-# RULES "hash" forall b. finalize (update init b) = hash b #-}
+{-# RULES "hash.list1" forall b. finalize (updates init [b]) = hash b #-}
+{-# RULES "hashmany" forall b. finalize (foldl update init b) = hashlazy (L.fromChunks b) #-}
+{-# RULES "hashlazy" forall b. finalize (foldl update init $ L.toChunks b) = hashlazy b #-}
+
+{-# NOINLINE init #-}
+-- | init a context
+init :: Ctx
+init = unsafeDoIO internalInit
+
+{-# NOINLINE update #-}
+-- | update a context with a bytestring returning the new updated context
+update :: Ctx        -- ^ the context to update
+       -> ByteString -- ^ the data to update with
+       -> Ctx        -- ^ the updated context
+update ctx d = unsafeDoIO $ withCtxCopy ctx $ \ptr -> internalUpdate ptr d
+
+{-# NOINLINE updates #-}
+-- | updates a context with multiples bytestring returning the new updated context
+updates :: Ctx          -- ^ the context to update
+        -> [ByteString] -- ^ a list of data bytestring to update with
+        -> Ctx          -- ^ the updated context
+updates ctx d = unsafeDoIO $ withCtxCopy ctx $ \ptr -> mapM_ (internalUpdate ptr) d
+
+{-# NOINLINE finalize #-}
+-- | finalize the context into a digest bytestring
+finalize :: Ctx -> ByteString
+finalize ctx = unsafeDoIO $ withCtxThrow ctx internalFinalize
+
+{-# NOINLINE hash #-}
+-- | hash a strict bytestring into a digest bytestring
+hash :: ByteString -> ByteString
+hash d = unsafeDoIO $ withCtxNewThrow $ \ptr -> do
+    internalInitAt ptr >> internalUpdate ptr d >> internalFinalize ptr
+
+{-# NOINLINE hashlazy #-}
+-- | hash a lazy bytestring into a digest bytestring
+hashlazy :: L.ByteString -> ByteString
+hashlazy l = unsafeDoIO $ withCtxNewThrow $ \ptr -> do
+    internalInitAt ptr >> mapM_ (internalUpdate ptr) (L.toChunks l) >> internalFinalize ptr