diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,13 @@ +# Revision history for sha1 + +## 0.1.0.2 -- 2020-03-09 + +* Add proper attribution to license file. + +## 0.1.0.1 -- 2020-03-09 + +* Add `sha1.h` to `extra-source-files`. + +## 0.1.0.0 -- 2020-03-09 + +* Initial release diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2010-2014 Vincent Hanquez + 2016 Herbert Valerio Riedel + 2020 Andrew Martin + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions +are met: + +1. Redistributions of source code must retain the above copyright notice, +this list of conditions and the following disclaimer. + +2. Redistributions in binary form must reproduce the above copyright +notice, this list of conditions and the following disclaimer in the +documentation and/or other materials provided with the distribution. + +3. Neither the name of the copyright holder nor the names of its +contributors may be used to endorse or promote products derived from +this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED +TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR +PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF +LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING +NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS +SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/md5.h b/cbits/md5.h new file mode 100644 --- /dev/null +++ b/cbits/md5.h @@ -0,0 +1,287 @@ +/* + * Copyright (C) 2006-2009 Vincent Hanquez + * 2016 Herbert Valerio Riedel + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. Redistributions in binary form must reproduce the above copyright + * notice, this list of conditions and the following disclaimer in the + * documentation and/or other materials provided with the distribution. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR ``AS IS'' AND ANY EXPRESS OR + * IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES + * OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. + * IN NO EVENT SHALL THE AUTHOR BE LIABLE FOR ANY DIRECT, INDIRECT, + * INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT + * NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, + * DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY + * THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT + * (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF + * THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + */ + +#ifndef BYTEVERSE_MD5_H +#define BYTEVERSE_MD5_H + +#include +#include +#include +#include +#include + +#include "Rts.h" + +struct md5_ctx +{ + uint64_t sz; + uint8_t buf[64]; + uint32_t h[4]; +}; + +#define BYTEVERSE_MD5_CTX_SIZE 88 + +static inline void hs_byteverse_md5_init(struct md5_ctx *ctx); +static inline void hs_byteverse_md5_update(struct md5_ctx *ctx, const uint8_t *data, HsInt off, HsInt len); +static inline void hs_byteverse_md5_finalize(struct md5_ctx *ctx, uint8_t *outBase, HsInt off); + +#if defined(static_assert) +static_assert(sizeof(struct md5_ctx) == BYTEVERSE_MD5_CTX_SIZE, "unexpected md5_ctx size"); +#else +/* poor man's pre-C11 _Static_assert */ +typedef char static_assertion__unexpected_md5_ctx_size[(sizeof(struct md5_ctx) == BYTEVERSE_MD5_CTX_SIZE)?1:-1]; +#endif + +#define ptr_uint32_aligned(ptr) (!((uintptr_t)(ptr) & 0x3)) + +static inline uint32_t +rol32(const uint32_t word, const unsigned shift) +{ + /* GCC usually transforms this into a 'rol'-insn */ + return (word << shift) | (word >> (32 - shift)); +} + +static inline uint32_t +cpu_to_le32(const uint32_t hl) +{ +#if !WORDS_BIGENDIAN + return hl; +#elif __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3) + return __builtin_bswap32(hl); +#else + /* GCC usually transforms this into a bswap insn */ + return ((hl & 0xff000000) >> 24) | + ((hl & 0x00ff0000) >> 8) | + ((hl & 0x0000ff00) << 8) | + ( hl << 24); +#endif +} + +static inline void +cpu_to_le32_array(uint32_t *dest, const uint32_t *src, unsigned wordcnt) +{ + while (wordcnt--) + *dest++ = cpu_to_le32(*src++); +} + +static inline uint64_t +cpu_to_le64(const uint64_t hll) +{ +#if !WORDS_BIGENDIAN + return hll; +#elif __GNUC__ > 4 || (__GNUC__ == 4 && __GNUC_MINOR__ >= 3) + return __builtin_bswap64(hll); +#else + return ((uint64_t)cpu_to_le32(hll & 0xffffffff) << 32LL) | cpu_to_le32(hll >> 32); +#endif +} + + +static inline void +hs_byteverse_md5_init(struct md5_ctx *ctx) +{ + memset(ctx, 0, sizeof(*ctx)); + + ctx->h[0] = 0x67452301; + ctx->h[1] = 0xefcdab89; + ctx->h[2] = 0x98badcfe; + ctx->h[3] = 0x10325476; +} + +#define f1(x, y, z) (z ^ (x & (y ^ z))) +#define f2(x, y, z) f1(z, x, y) +#define f3(x, y, z) (x ^ y ^ z) +#define f4(x, y, z) (y ^ (x | ~z)) +#define R(f, a, b, c, d, i, k, s) a += f(b, c, d) + w[i] + k; a = rol32(a, s); a += b + +static void +md5_do_chunk_aligned(struct md5_ctx *ctx, const uint32_t w[]) +{ + uint32_t a = ctx->h[0]; + uint32_t b = ctx->h[1]; + uint32_t c = ctx->h[2]; + uint32_t d = ctx->h[3]; + + R(f1, a, b, c, d, 0, 0xd76aa478, 7); + R(f1, d, a, b, c, 1, 0xe8c7b756, 12); + R(f1, c, d, a, b, 2, 0x242070db, 17); + R(f1, b, c, d, a, 3, 0xc1bdceee, 22); + R(f1, a, b, c, d, 4, 0xf57c0faf, 7); + R(f1, d, a, b, c, 5, 0x4787c62a, 12); + R(f1, c, d, a, b, 6, 0xa8304613, 17); + R(f1, b, c, d, a, 7, 0xfd469501, 22); + R(f1, a, b, c, d, 8, 0x698098d8, 7); + R(f1, d, a, b, c, 9, 0x8b44f7af, 12); + R(f1, c, d, a, b, 10, 0xffff5bb1, 17); + R(f1, b, c, d, a, 11, 0x895cd7be, 22); + R(f1, a, b, c, d, 12, 0x6b901122, 7); + R(f1, d, a, b, c, 13, 0xfd987193, 12); + R(f1, c, d, a, b, 14, 0xa679438e, 17); + R(f1, b, c, d, a, 15, 0x49b40821, 22); + + R(f2, a, b, c, d, 1, 0xf61e2562, 5); + R(f2, d, a, b, c, 6, 0xc040b340, 9); + R(f2, c, d, a, b, 11, 0x265e5a51, 14); + R(f2, b, c, d, a, 0, 0xe9b6c7aa, 20); + R(f2, a, b, c, d, 5, 0xd62f105d, 5); + R(f2, d, a, b, c, 10, 0x02441453, 9); + R(f2, c, d, a, b, 15, 0xd8a1e681, 14); + R(f2, b, c, d, a, 4, 0xe7d3fbc8, 20); + R(f2, a, b, c, d, 9, 0x21e1cde6, 5); + R(f2, d, a, b, c, 14, 0xc33707d6, 9); + R(f2, c, d, a, b, 3, 0xf4d50d87, 14); + R(f2, b, c, d, a, 8, 0x455a14ed, 20); + R(f2, a, b, c, d, 13, 0xa9e3e905, 5); + R(f2, d, a, b, c, 2, 0xfcefa3f8, 9); + R(f2, c, d, a, b, 7, 0x676f02d9, 14); + R(f2, b, c, d, a, 12, 0x8d2a4c8a, 20); + + R(f3, a, b, c, d, 5, 0xfffa3942, 4); + R(f3, d, a, b, c, 8, 0x8771f681, 11); + R(f3, c, d, a, b, 11, 0x6d9d6122, 16); + R(f3, b, c, d, a, 14, 0xfde5380c, 23); + R(f3, a, b, c, d, 1, 0xa4beea44, 4); + R(f3, d, a, b, c, 4, 0x4bdecfa9, 11); + R(f3, c, d, a, b, 7, 0xf6bb4b60, 16); + R(f3, b, c, d, a, 10, 0xbebfbc70, 23); + R(f3, a, b, c, d, 13, 0x289b7ec6, 4); + R(f3, d, a, b, c, 0, 0xeaa127fa, 11); + R(f3, c, d, a, b, 3, 0xd4ef3085, 16); + R(f3, b, c, d, a, 6, 0x04881d05, 23); + R(f3, a, b, c, d, 9, 0xd9d4d039, 4); + R(f3, d, a, b, c, 12, 0xe6db99e5, 11); + R(f3, c, d, a, b, 15, 0x1fa27cf8, 16); + R(f3, b, c, d, a, 2, 0xc4ac5665, 23); + + R(f4, a, b, c, d, 0, 0xf4292244, 6); + R(f4, d, a, b, c, 7, 0x432aff97, 10); + R(f4, c, d, a, b, 14, 0xab9423a7, 15); + R(f4, b, c, d, a, 5, 0xfc93a039, 21); + R(f4, a, b, c, d, 12, 0x655b59c3, 6); + R(f4, d, a, b, c, 3, 0x8f0ccc92, 10); + R(f4, c, d, a, b, 10, 0xffeff47d, 15); + R(f4, b, c, d, a, 1, 0x85845dd1, 21); + R(f4, a, b, c, d, 8, 0x6fa87e4f, 6); + R(f4, d, a, b, c, 15, 0xfe2ce6e0, 10); + R(f4, c, d, a, b, 6, 0xa3014314, 15); + R(f4, b, c, d, a, 13, 0x4e0811a1, 21); + R(f4, a, b, c, d, 4, 0xf7537e82, 6); + R(f4, d, a, b, c, 11, 0xbd3af235, 10); + R(f4, c, d, a, b, 2, 0x2ad7d2bb, 15); + R(f4, b, c, d, a, 9, 0xeb86d391, 21); + + ctx->h[0] += a; + ctx->h[1] += b; + ctx->h[2] += c; + ctx->h[3] += d; +} + +static void +md5_do_chunk(struct md5_ctx *ctx, const uint8_t buf[]) +{ + if (ptr_uint32_aligned(buf)) { /* aligned buf */ +#if WORDS_BIGENDIAN + uint32_t w[16]; cpu_to_le32_array(w, (const uint32_t *)buf, 16); +#else + const uint32_t *w = (const uint32_t *)buf; +#endif + md5_do_chunk_aligned(ctx, w); + } else { /* unaligned buf */ + uint32_t w[16]; memcpy(w, buf, 64); +#if WORDS_BIGENDIAN + cpu_to_le32_array(w, w, 16); +#endif + md5_do_chunk_aligned(ctx, w); + } +} + +static inline void +hs_byteverse_md5_update(struct md5_ctx *ctx, const uint8_t *dataBase, HsInt off, HsInt len) +{ + const uint8_t *data = dataBase + off; + size_t index = ctx->sz & 0x3f; + const size_t to_fill = 64 - index; + + ctx->sz += len; + + /* process partial buffer if there's enough data to make a block */ + if (index && len >= to_fill) { + memcpy(ctx->buf + index, data, to_fill); + md5_do_chunk(ctx, ctx->buf); + /* memset(ctx->buf, 0, 64); */ + len -= to_fill; + data += to_fill; + index = 0; + } + + /* process as many 64-blocks as possible */ + while (len >= 64) { + md5_do_chunk(ctx, data); + len -= 64; + data += 64; + } + + /* append data into buf */ + if (len) + memcpy(ctx->buf + index, data, len); +} + +static inline void +hs_byteverse_md5_finalize(struct md5_ctx *ctx, uint8_t *outBase, HsInt off) +{ + static const uint8_t padding[64] = { 0x80, }; + const uint64_t sz = ctx->sz; + const uint8_t *out = outBase + off; + + /* add padding and update data with it */ + const uint64_t bits = cpu_to_le64(ctx->sz << 3); + + /* pad out to 56 */ + const size_t index = (ctx->sz & 0x3f); + const size_t padlen = (index < 56) ? (56 - index) : ((64 + 56) - index); + hs_byteverse_md5_update(ctx, padding, 0, padlen); + + /* append length */ + hs_byteverse_md5_update(ctx, (const uint8_t *) &bits, 0, sizeof(bits)); + + /* output hash */ + cpu_to_le32_array((uint32_t *) out, ctx->h, 4); + + return; +} + +static inline void +hs_byteverse_md5_hash (const uint8_t *data, size_t len, uint8_t *out) +{ + struct md5_ctx ctx; + + hs_byteverse_md5_init(&ctx); + + hs_byteverse_md5_update(&ctx, data, 0, len); + + hs_byteverse_md5_finalize(&ctx, out, 0); +} + +#endif diff --git a/md5.cabal b/md5.cabal new file mode 100644 --- /dev/null +++ b/md5.cabal @@ -0,0 +1,49 @@ +cabal-version: 2.2 +name: md5 +version: 0.1.0.0 +synopsis: MD5 Hash +description: + This library is a copy of cryptohash-md5 that works on GC-managed + byte arrays instead of ByteString. The C code is a copied from + that library. If you find an issue with the C code, you should + open an issue on cryptohash-md5. +homepage: https://github.com/byteverse/md5 +bug-reports: https://github.com/byteverse/md5/issues +license: BSD-3-Clause +license-file: LICENSE +author: Andrew Martin +maintainer: andrew.thaddeus@gmail.com +copyright: 2023 Andrew Martin +category: Data +build-type: Simple +extra-source-files: + CHANGELOG.md + cbits/md5.h + +library + include-dirs: cbits + cc-options: -Wall -O3 + hs-source-dirs: src + exposed-modules: Hash.Md5 + other-modules: Hash.Md5.Internal + build-depends: + , base >=4.12 && <5 + , primitive >=0.7 && <0.8 + , bytebuild >=0.3.4 && <0.4 + , byteslice >=0.2.2 && <0.3 + default-language: Haskell2010 + ghc-options: -O2 -Wall + +test-suite test + Default-Language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + type: exitcode-stdio-1.0 + build-depends: + , base + , bytebuild >=0.3.4 + , byteslice >=0.1.4.0 + , natural-arithmetic >=0.1.1 + , primitive + , md5 + ghc-options: -O2 -Wall diff --git a/src/Hash/Md5.hs b/src/Hash/Md5.hs new file mode 100644 --- /dev/null +++ b/src/Hash/Md5.hs @@ -0,0 +1,71 @@ +{-# language BangPatterns #-} +{-# language DataKinds #-} +{-# language MagicHash #-} +{-# language UnliftedFFITypes #-} + +module Hash.Md5 + ( Context(..) + -- * Context Reuse + , context + , reinitialize + , update + , finalize + -- * One Shot + , boundedBuilder + ) where + +import Control.Monad.ST (ST) +import Data.Bytes.Builder.Bounded as BB +import Data.Bytes.Builder.Bounded.Unsafe as BBU +import Data.Bytes.Types (Bytes(Bytes)) +import Data.Primitive (ByteArray(..),MutableByteArray(..)) +import Data.Primitive (newByteArray) +import GHC.Exts (Int(I#),Int#,MutableByteArray#,ByteArray#,unsafeCoerce#) +import GHC.Exts (RealWorld) +import GHC.IO (unsafeIOToST) + +import Hash.Md5.Internal + +newtype Context s = Context (MutableByteArray s) + +-- | Create a new context. The context is initialized. +context :: ST s (Context s) +context = do + b <- newByteArray 88 + reinitialize (Context b) + pure (Context b) + +-- | Reset the context so that it may be used to hash another byte sequence. +reinitialize :: Context s -> ST s () +reinitialize (Context (MutableByteArray ctx)) = + unsafeIOToST (c_md5_init (unsafeCoerce# ctx)) + +finalize :: + Context s + -> MutableByteArray s -- ^ Destination, implied length is 16 + -> Int -- ^ Destination offset + -> ST s () +finalize (Context (MutableByteArray ctx)) (MutableByteArray x) !a = + unsafeIOToST (c_md5_finalize (unsafeCoerce# ctx) (unsafeCoerce# x) a) + +update :: + Context s + -> Bytes + -> ST s () +update (Context (MutableByteArray ctx)) (Bytes (ByteArray arr) off len) = + unsafeIOToST (c_md5_update_unsafe (unsafeCoerce# ctx) arr off len) + +performHash :: MutableByteArray s -> Int -> ByteArray -> Int -> Int -> ST s () +performHash (MutableByteArray x) !a (ByteArray y) !b !c = + unsafeIOToST $ do + MutableByteArray ctx <- newByteArray 88 + c_md5_init ctx + c_md5_update_unsafe ctx y b c + c_md5_finalize ctx (unsafeCoerce# x) a + +boundedBuilder :: Bytes -> BB.Builder 16 +boundedBuilder (Bytes arr off len) = BBU.construct + (\buf ix -> do + performHash buf ix arr off len + pure (ix + 16) + ) diff --git a/src/Hash/Md5/Internal.hs b/src/Hash/Md5/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Hash/Md5/Internal.hs @@ -0,0 +1,50 @@ +{-# LANGUAGE CApiFFI #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} + +-- | +-- Module : Hash.MD5.Internal +-- License : BSD-3 +-- +module Hash.Md5.Internal + ( c_md5_init + , c_md5_update_unsafe + , c_md5_finalize + ) where + +import GHC.Exts (ByteArray#, MutableByteArray#,RealWorld,Int#) +import Data.Word +import Foreign.C.Types +import Foreign.Ptr + +-- MD5 Context +-- +-- The context data is exactly 88 bytes long, however +-- the data in the context is stored depends on host-endianness. +-- +-- The context data is made up of +-- +-- * a 'Word64' representing the number of bytes already feed to hash algorithm so far, +-- * a 64-element 'Word8' buffer holding partial input-chunks, and finally +-- * a 4-element 'Word32' array holding the current work-in-progress digest-value. +-- +-- Consequently, a MD5 digest as produced by 'finalize' is 16 bytes long. +foreign import capi unsafe "md5.h hs_byteverse_md5_init" + c_md5_init :: + MutableByteArray# RealWorld -- ctx, updated + -> IO () + +foreign import capi unsafe "md5.h hs_byteverse_md5_update" + c_md5_update_unsafe :: + MutableByteArray# RealWorld -- ctx, updated + -> ByteArray# -- bytes that are hashed + -> Int -- offset into bytes, often zero + -> Int -- length of bytes + -> IO () + +foreign import capi unsafe "md5.h hs_byteverse_md5_finalize" + c_md5_finalize :: + MutableByteArray# RealWorld -- ctx + -> MutableByteArray# RealWorld -- output buffer, must be 16 bytes + -> Int -- output buffer offset + -> IO () diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,49 @@ +{-# language BangPatterns #-} + +import Data.Primitive (ByteArray) +import Data.Word (Word8) +import Numeric (showHex) + +import qualified Arithmetic.Nat as Nat +import qualified Data.Bytes.Builder.Bounded as BB +import qualified Data.Bytes as Bytes +import qualified Data.Bytes.Text.Ascii as Ascii +import qualified Data.Primitive as PM +import qualified GHC.Exts as Exts +import qualified Hash.Md5 as Md5 + +main :: IO () +main = do + putStrLn "Hashing: theoceanscovertheearth" + putStr "Expected: " + printHash expected + putStr "Got: " + printHash actual + if actual == expected + then putStrLn "Success" + else fail "Did not match" + +printHash :: ByteArray -> IO () +printHash !b = putStr (go 0) where + go !ix = if ix < 16 + then let val = PM.indexByteArray b ix :: Word8 in + if val < 16 + then '0' : showHex val (go (ix + 1)) + else showHex val (go (ix + 1)) + else "\n" + +actual :: ByteArray +actual = BB.run Nat.constant + (Md5.boundedBuilder + (Bytes.unsafeDrop 5 + (Ascii.fromString "12345theoceanscovertheearth") + ) + ) + +expected :: ByteArray +expected = Exts.fromList + [ 0xf6, 0xc6, 0x90, 0x8c + , 0x1d, 0xb5, 0x81, 0x4c + , 0xa6, 0xfc, 0x9e, 0x59 + , 0x65, 0x8a, 0xf9, 0xd4 + ]