From 4652fd99a775cf04ed1e4ff79272fc084b0db0d3 Mon Sep 17 00:00:00 2001 From: Vincent Hanquez Date: Sun, 8 Feb 2015 12:04:05 +0000 Subject: [PATCH] add template for hash generation and the little program associated with it --- gen/Gen.hs | 68 +++++++++++++++++++ gen/Template.hs | 65 +++++++++++++++++++ gen/template/hash-internal-len.hs | 104 ++++++++++++++++++++++++++++++ gen/template/hash-internal.hs | 101 +++++++++++++++++++++++++++++ gen/template/hash-len.hs | 74 +++++++++++++++++++++ gen/template/hash.hs | 74 +++++++++++++++++++++ 6 files changed, 486 insertions(+) create mode 100644 gen/Gen.hs create mode 100644 gen/Template.hs create mode 100644 gen/template/hash-internal-len.hs create mode 100644 gen/template/hash-internal.hs create mode 100644 gen/template/hash-len.hs create mode 100644 gen/template/hash.hs diff --git a/gen/Gen.hs b/gen/Gen.hs new file mode 100644 index 0000000..4838878 --- /dev/null +++ b/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 () diff --git a/gen/Template.hs b/gen/Template.hs new file mode 100644 index 0000000..af020f9 --- /dev/null +++ b/gen/Template.hs @@ -0,0 +1,65 @@ +-- | +-- Module : Template +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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) diff --git a/gen/template/hash-internal-len.hs b/gen/template/hash-internal-len.hs new file mode 100644 index 0000000..ca7f7f5 --- /dev/null +++ b/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 +-- 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) diff --git a/gen/template/hash-internal.hs b/gen/template/hash-internal.hs new file mode 100644 index 0000000..81fece7 --- /dev/null +++ b/gen/template/hash-internal.hs @@ -0,0 +1,101 @@ +{-# LANGUAGE ForeignFunctionInterface, CPP, MultiParamTypeClasses #-} + +-- | +-- Module : Crypto.Hash.Internal.%%MODULENAME%% +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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) diff --git a/gen/template/hash-len.hs b/gen/template/hash-len.hs new file mode 100644 index 0000000..a26ed54 --- /dev/null +++ b/gen/template/hash-len.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | +-- Module : Crypto.Hash.%%MODULENAME%% +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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 diff --git a/gen/template/hash.hs b/gen/template/hash.hs new file mode 100644 index 0000000..ad97ee2 --- /dev/null +++ b/gen/template/hash.hs @@ -0,0 +1,74 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- | +-- Module : Crypto.Hash.%%MODULENAME%% +-- License : BSD-style +-- Maintainer : Vincent Hanquez +-- 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