diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,8 @@ +# Revision history for sha256 + +## 0.1.0.0 -- 2025-01-20 + +* Rewrite of the FFI portions of the cryptohash-sha256 bindings, in order + to support precomputed HMAC keys, more efficient streaming and backtracking, + bitstring inputs, (de)serialization of intermediate states, intermediate + bytecounts, and more. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,202 @@ + + Apache License + Version 2.0, January 2004 + http://www.apache.org/licenses/ + + TERMS AND CONDITIONS FOR USE, REPRODUCTION, AND DISTRIBUTION + + 1. Definitions. + + "License" shall mean the terms and conditions for use, reproduction, + and distribution as defined by Sections 1 through 9 of this document. + + "Licensor" shall mean the copyright owner or entity authorized by + the copyright owner that is granting the License. + + "Legal Entity" shall mean the union of the acting entity and all + other entities that control, are controlled by, or are under common + control with that entity. For the purposes of this definition, + "control" means (i) the power, direct or indirect, to cause the + direction or management of such entity, whether by contract or + otherwise, or (ii) ownership of fifty percent (50%) or more of the + outstanding shares, or (iii) beneficial ownership of such entity. + + "You" (or "Your") shall mean an individual or Legal Entity + exercising permissions granted by this License. + + "Source" form shall mean the preferred form for making modifications, + including but not limited to software source code, documentation + source, and configuration files. + + "Object" form shall mean any form resulting from mechanical + transformation or translation of a Source form, including but + not limited to compiled object code, generated documentation, + and conversions to other media types. + + "Work" shall mean the work of authorship, whether in Source or + Object form, made available under the License, as indicated by a + copyright notice that is included in or attached to the work + (an example is provided in the Appendix below). + + "Derivative Works" shall mean any work, whether in Source or Object + form, that is based on (or derived from) the Work and for which the + editorial revisions, annotations, elaborations, or other modifications + represent, as a whole, an original work of authorship. For the purposes + of this License, Derivative Works shall not include works that remain + separable from, or merely link (or bind by name) to the interfaces of, + the Work and Derivative Works thereof. + + "Contribution" shall mean any work of authorship, including + the original version of the Work and any modifications or additions + to that Work or Derivative Works thereof, that is intentionally + submitted to Licensor for inclusion in the Work by the copyright owner + or by an individual or Legal Entity authorized to submit on behalf of + the copyright owner. For the purposes of this definition, "submitted" + means any form of electronic, verbal, or written communication sent + to the Licensor or its representatives, including but not limited to + communication on electronic mailing lists, source code control systems, + and issue tracking systems that are managed by, or on behalf of, the + Licensor for the purpose of discussing and improving the Work, but + excluding communication that is conspicuously marked or otherwise + designated in writing by the copyright owner as "Not a Contribution." + + "Contributor" shall mean Licensor and any individual or Legal Entity + on behalf of whom a Contribution has been received by Licensor and + subsequently incorporated within the Work. + + 2. Grant of Copyright License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + copyright license to reproduce, prepare Derivative Works of, + publicly display, publicly perform, sublicense, and distribute the + Work and such Derivative Works in Source or Object form. + + 3. Grant of Patent License. Subject to the terms and conditions of + this License, each Contributor hereby grants to You a perpetual, + worldwide, non-exclusive, no-charge, royalty-free, irrevocable + (except as stated in this section) patent license to make, have made, + use, offer to sell, sell, import, and otherwise transfer the Work, + where such license applies only to those patent claims licensable + by such Contributor that are necessarily infringed by their + Contribution(s) alone or by combination of their Contribution(s) + with the Work to which such Contribution(s) was submitted. If You + institute patent litigation against any entity (including a + cross-claim or counterclaim in a lawsuit) alleging that the Work + or a Contribution incorporated within the Work constitutes direct + or contributory patent infringement, then any patent licenses + granted to You under this License for that Work shall terminate + as of the date such litigation is filed. + + 4. Redistribution. You may reproduce and distribute copies of the + Work or Derivative Works thereof in any medium, with or without + modifications, and in Source or Object form, provided that You + meet the following conditions: + + (a) You must give any other recipients of the Work or + Derivative Works a copy of this License; and + + (b) You must cause any modified files to carry prominent notices + stating that You changed the files; and + + (c) You must retain, in the Source form of any Derivative Works + that You distribute, all copyright, patent, trademark, and + attribution notices from the Source form of the Work, + excluding those notices that do not pertain to any part of + the Derivative Works; and + + (d) If the Work includes a "NOTICE" text file as part of its + distribution, then any Derivative Works that You distribute must + include a readable copy of the attribution notices contained + within such NOTICE file, excluding those notices that do not + pertain to any part of the Derivative Works, in at least one + of the following places: within a NOTICE text file distributed + as part of the Derivative Works; within the Source form or + documentation, if provided along with the Derivative Works; or, + within a display generated by the Derivative Works, if and + wherever such third-party notices normally appear. The contents + of the NOTICE file are for informational purposes only and + do not modify the License. You may add Your own attribution + notices within Derivative Works that You distribute, alongside + or as an addendum to the NOTICE text from the Work, provided + that such additional attribution notices cannot be construed + as modifying the License. + + You may add Your own copyright statement to Your modifications and + may provide additional or different license terms and conditions + for use, reproduction, or distribution of Your modifications, or + for any such Derivative Works as a whole, provided Your use, + reproduction, and distribution of the Work otherwise complies with + the conditions stated in this License. + + 5. Submission of Contributions. Unless You explicitly state otherwise, + any Contribution intentionally submitted for inclusion in the Work + by You to the Licensor shall be under the terms and conditions of + this License, without any additional terms or conditions. + Notwithstanding the above, nothing herein shall supersede or modify + the terms of any separate license agreement you may have executed + with Licensor regarding such Contributions. + + 6. Trademarks. This License does not grant permission to use the trade + names, trademarks, service marks, or product names of the Licensor, + except as required for reasonable and customary use in describing the + origin of the Work and reproducing the content of the NOTICE file. + + 7. Disclaimer of Warranty. Unless required by applicable law or + agreed to in writing, Licensor provides the Work (and each + Contributor provides its Contributions) on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or + implied, including, without limitation, any warranties or conditions + of TITLE, NON-INFRINGEMENT, MERCHANTABILITY, or FITNESS FOR A + PARTICULAR PURPOSE. You are solely responsible for determining the + appropriateness of using or redistributing the Work and assume any + risks associated with Your exercise of permissions under this License. + + 8. Limitation of Liability. In no event and under no legal theory, + whether in tort (including negligence), contract, or otherwise, + unless required by applicable law (such as deliberate and grossly + negligent acts) or agreed to in writing, shall any Contributor be + liable to You for damages, including any direct, indirect, special, + incidental, or consequential damages of any character arising as a + result of this License or out of the use or inability to use the + Work (including but not limited to damages for loss of goodwill, + work stoppage, computer failure or malfunction, or any and all + other commercial damages or losses), even if such Contributor + has been advised of the possibility of such damages. + + 9. Accepting Warranty or Additional Liability. While redistributing + the Work or Derivative Works thereof, You may choose to offer, + and charge a fee for, acceptance of support, warranty, indemnity, + or other liability obligations and/or rights consistent with this + License. However, in accepting such obligations, You may act only + on Your own behalf and on Your sole responsibility, not on behalf + of any other Contributor, and only if You agree to indemnify, + defend, and hold each Contributor harmless for any liability + incurred by, or claims asserted against, such Contributor by reason + of your accepting any such warranty or additional liability. + + END OF TERMS AND CONDITIONS + + APPENDIX: How to apply the Apache License to your work. + + To apply the Apache License to your work, attach the following + boilerplate notice, with the fields enclosed by brackets "[]" + replaced with your own identifying information. (Don't include + the brackets!) The text should be enclosed in the appropriate + comment syntax for the file format. We also recommend that a + file or class name and description of purpose be included on the + same "printed page" as the copyright notice for easier + identification within third-party archives. + + Copyright [yyyy] [name of copyright owner] + + Licensed under the Apache License, Version 2.0 (the "License"); + you may not use this file except in compliance with the License. + You may obtain a copy of the License at + + http://www.apache.org/licenses/LICENSE-2.0 + + Unless required by applicable law or agreed to in writing, software + distributed under the License is distributed on an "AS IS" BASIS, + WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied. + See the License for the specific language governing permissions and + limitations under the License. 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/csrc/hs_sha256.c b/csrc/hs_sha256.c new file mode 100644 --- /dev/null +++ b/csrc/hs_sha256.c @@ -0,0 +1,430 @@ +/* + * Copyright (C) 2006-2009 Vincent Hanquez + * 2016 Herbert Valerio Riedel + * 2024 Leon P Smith + * + * 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. + */ + +#include +#include +#include +#include +#include + +#include "hs_hashstring_memcmp.h" +#include "hs_sha256.h" + +#define ptr_uint32_aligned(ptr) (!((uintptr_t)(ptr) & 0x3)) + +static inline uint32_t +ror32(const uint32_t word, const unsigned shift) +{ + /* GCC usually transforms this into a 'ror'-insn */ + return (word >> shift) | (word << (32 - shift)); +} + +static inline uint32_t +cpu_to_be32(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_be32_array(uint32_t *restrict dest, const uint32_t *restrict src, unsigned wordcnt) +{ + while (wordcnt--) + *dest++ = cpu_to_be32(*src++); +} + +static inline uint64_t +cpu_to_be64(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_be32(hll & 0xffffffff) << 32LL) | cpu_to_be32(hll >> 32); +#endif +} + +const uint32_t hs_sha256_init[SHA256_STATE_LEN] = { + 0x6a09e667, + 0xbb67ae85, + 0x3c6ef372, + 0xa54ff53a, + 0x510e527f, + 0x9b05688c, + 0x1f83d9ab, + 0x5be0cd19 +}; + +const uint8_t hs_sha256_padding[SHA256_BLOCK_SIZE + 1] = { 0x80, }; + +/* 232 times the cube root of the first 64 primes 2..311 */ +static const uint32_t k[] = { + 0x428a2f98, 0x71374491, 0xb5c0fbcf, 0xe9b5dba5, 0x3956c25b, 0x59f111f1, + 0x923f82a4, 0xab1c5ed5, 0xd807aa98, 0x12835b01, 0x243185be, 0x550c7dc3, + 0x72be5d74, 0x80deb1fe, 0x9bdc06a7, 0xc19bf174, 0xe49b69c1, 0xefbe4786, + 0x0fc19dc6, 0x240ca1cc, 0x2de92c6f, 0x4a7484aa, 0x5cb0a9dc, 0x76f988da, + 0x983e5152, 0xa831c66d, 0xb00327c8, 0xbf597fc7, 0xc6e00bf3, 0xd5a79147, + 0x06ca6351, 0x14292967, 0x27b70a85, 0x2e1b2138, 0x4d2c6dfc, 0x53380d13, + 0x650a7354, 0x766a0abb, 0x81c2c92e, 0x92722c85, 0xa2bfe8a1, 0xa81a664b, + 0xc24b8b70, 0xc76c51a3, 0xd192e819, 0xd6990624, 0xf40e3585, 0x106aa070, + 0x19a4c116, 0x1e376c08, 0x2748774c, 0x34b0bcb5, 0x391c0cb3, 0x4ed8aa4a, + 0x5b9cca4f, 0x682e6ff3, 0x748f82ee, 0x78a5636f, 0x84c87814, 0x8cc70208, + 0x90befffa, 0xa4506ceb, 0xbef9a3f7, 0xc67178f2 +}; + +#define e0(x) (ror32(x, 2) ^ ror32(x,13) ^ ror32(x,22)) +#define e1(x) (ror32(x, 6) ^ ror32(x,11) ^ ror32(x,25)) +#define s0(x) (ror32(x, 7) ^ ror32(x,18) ^ (x >> 3)) +#define s1(x) (ror32(x,17) ^ ror32(x,19) ^ (x >> 10)) + +static void +sha256_do_chunk_aligned(uint32_t state[const restrict SHA256_STATE_LEN], uint32_t w[const restrict 64]) +{ + int i; + + for (i = 16; i < 64; i++) + w[i] = s1(w[i - 2]) + w[i - 7] + s0(w[i - 15]) + w[i - 16]; + + uint32_t a = state[0]; + uint32_t b = state[1]; + uint32_t c = state[2]; + uint32_t d = state[3]; + uint32_t e = state[4]; + uint32_t f = state[5]; + uint32_t g = state[6]; + uint32_t h = state[7]; + +#define R(a, b, c, d, e, f, g, h, k, w) \ + t1 = h + e1(e) + (g ^ (e & (f ^ g))) + k + w; \ + t2 = e0(a) + ((a & b) | (c & (a | b))); \ + d += t1; \ + h = t1 + t2; + + for (i = 0; i < 64; i += 8) { + uint32_t t1, t2; + + R(a, b, c, d, e, f, g, h, k[i + 0], w[i + 0]); + R(h, a, b, c, d, e, f, g, k[i + 1], w[i + 1]); + R(g, h, a, b, c, d, e, f, k[i + 2], w[i + 2]); + R(f, g, h, a, b, c, d, e, k[i + 3], w[i + 3]); + R(e, f, g, h, a, b, c, d, k[i + 4], w[i + 4]); + R(d, e, f, g, h, a, b, c, k[i + 5], w[i + 5]); + R(c, d, e, f, g, h, a, b, k[i + 6], w[i + 6]); + R(b, c, d, e, f, g, h, a, k[i + 7], w[i + 7]); + } + +#undef R + + state[0] += a; + state[1] += b; + state[2] += c; + state[3] += d; + state[4] += e; + state[5] += f; + state[6] += g; + state[7] += h; +} + +static void +sha256_do_chunk +(uint32_t state[const restrict SHA256_STATE_LEN], + const uint8_t buf[const restrict SHA256_BLOCK_SIZE]) +{ + /* + printf( "state: "); + for (int i = 0; i < SHA256_STATE_LEN; i++) + printf("%08x", state[i]); + printf("\nbuffer: "); + for (int i = 0; i < SHA256_BLOCK_SIZE; i++) + printf("%02x", buf[i]); + printf("\n"); + */ + uint32_t w[64]; /* only first 16 words are filled in */ + if (ptr_uint32_aligned(buf)) { /* aligned buf */ + cpu_to_be32_array(w, (const uint32_t *)buf, 16); + } else { /* unaligned buf */ + memcpy(w + 16, buf, 64); +#if !WORDS_BIGENDIAN + cpu_to_be32_array(w, w + 16, 16); +#endif + } + sha256_do_chunk_aligned(state, w); + explicit_bzero(&w, sizeof(w)); + /* + printf( "state': "); + for (int i = 0; i < SHA256_STATE_LEN; i++) + printf("%08x", state[i]); + printf("\n"); + */ +} + +size_t +hs_sha256_update +(const uint32_t state[const SHA256_STATE_LEN], + const uint8_t *const data, + size_t const datalen, + uint32_t out[const SHA256_STATE_LEN]) +{ + if (out != state) memcpy(out, state, SHA256_DIGEST_SIZE); + if (data == NULL) return 0; + size_t i = 0; + size_t dataLeft = datalen; + while (dataLeft >= SHA256_BLOCK_SIZE) { + sha256_do_chunk(out, data + i); + i += SHA256_BLOCK_SIZE; + dataLeft -= SHA256_BLOCK_SIZE; + } + return i; +} + +void +hs_sha256_update_ctx +(const sha256_ctx *const in, + const uint8_t *const data, + const size_t datalen, + sha256_ctx *const out) +{ + const size_t bufferlen = in->count & 0x3F; + if ( data == NULL || datalen == 0 ) { + if (in != out) memcpy(out, in, sizeof(sha256_ctx) + bufferlen); + } else if ( datalen + bufferlen < SHA256_BLOCK_SIZE ) { + if (in != out) memcpy(out, in, sizeof(sha256_ctx) + bufferlen); + memcpy(out->buffer + bufferlen, data, datalen); + out->count += datalen; + } else if ( bufferlen == 0 ) { + const size_t processedLen = hs_sha256_update(in->state, data, datalen, out->state); + out->count = in->count + datalen; + memcpy(out->buffer, data + processedLen, datalen - processedLen); + } else { + // Don't assume the output has enough extra space for a full buffer + uint8_t mybuf[SHA256_BLOCK_SIZE] __attribute__ ((aligned (4))); + memcpy(mybuf, in->buffer, bufferlen); + size_t processedDataLen = SHA256_BLOCK_SIZE - bufferlen; + memcpy(mybuf + bufferlen, data, processedDataLen); + hs_sha256_update(in->state, mybuf, SHA256_BLOCK_SIZE, out->state); + processedDataLen += hs_sha256_update( out->state, + data + processedDataLen, + datalen - processedDataLen, + out->state ); + out->count = in->count + datalen; + memcpy(out->buffer, data + processedDataLen, datalen - processedDataLen ); + } +} + +void +hs_sha256_promote_to_ctx +(const uint32_t state[const SHA256_STATE_LEN], + uint64_t const blockcount, + const uint8_t *const data, + size_t const datalen, + sha256_ctx *const out) +{ + hs_sha256_update(state, data, datalen, out->state); + out->count = (blockcount << 6) + datalen; + size_t const bufferlen = datalen & 0x3F; + if (data != NULL && bufferlen > 0) { + memcpy(out->buffer, data + (datalen - bufferlen), bufferlen); + } +} + +void +hs_sha256_encode_state +(const uint32_t in[const SHA256_STATE_LEN], + uint8_t out[const SHA256_DIGEST_SIZE]) +{ +#if WORDS_BIGENDIAN + memcpy(out, (uint8_t *)in, SHA256_DIGEST_SIZE); +#else + if(ptr_uint32_aligned(out)) { + cpu_to_be32_array((uint32_t *)out, in, SHA256_STATE_LEN); + } else { + for (int i = 0; i < SHA256_STATE_LEN; i++) { + int pos = i << 2; + out[pos ] = (in[i] >> 24) & 0xFF; + out[pos+1] = (in[i] >> 16) & 0xFF; + out[pos+2] = (in[i] >> 8) & 0xFF; + out[pos+3] = (in[i] ) & 0xFF; + } + } +#endif +} + +void +hs_sha256_decode_state +(const uint8_t in[const SHA256_DIGEST_SIZE], + uint32_t out[const SHA256_STATE_LEN]) +{ +#if WORDS_BIGENDIAN + memcpy((uint8_t *)out, in, SHA256_DIGEST_SIZE); +#else + if(ptr_uint32_aligned(in)) { + cpu_to_be32_array(out, (uint32_t *)in, SHA256_STATE_LEN); + } else { + for (int i = 0; i < SHA256_DIGEST_SIZE; i += 4) { + out [i >> 2] + = ((uint32_t)in[i ]) << 24 + | ((uint32_t)in[i+1]) << 16 + | ((uint32_t)in[i+2]) << 8 + | ((uint32_t)in[i+3]); + } + } +#endif +} + +// The unpinned ByteArray approach I'm taking to the FFI seems to +// necessitate this kind of accessor functions. It'd be nice +// to simply use #{peek sha256_ctx, count} style accessors from +// haskell, but I'm not sure that works with this approach. +uint64_t +hs_sha256_get_count +(const sha256_ctx *const ctx) +{ + return ctx->count; +} + +void +hs_sha256_init_ctx +(sha256_ctx *const out) +{ + hs_sha256_promote_to_ctx(hs_sha256_init, 0, NULL, 0, out); +} + +void +hs_sha256_finalize_ctx_bits +(const sha256_ctx *const in, + const uint8_t *const data, + uint64_t const datalenbits, + uint8_t out[const SHA256_DIGEST_SIZE]) +{ + uint8_t buffer[SHA256_BLOCK_SIZE] __attribute__ ((aligned (4))); + uint32_t state[SHA256_STATE_LEN]; + size_t bufferPos = in->count & 0x3F; + size_t bufferLeft = SHA256_BLOCK_SIZE - bufferPos; + size_t dataLeft = datalenbits >> 3; + size_t dataPos; + memcpy(buffer, in->buffer, bufferPos); + if (data == NULL || datalenbits < 8) { + memcpy(state, in, SHA256_DIGEST_SIZE); + dataPos = 0; + } else if (dataLeft < bufferLeft) { + memcpy(state, in, SHA256_DIGEST_SIZE); + dataPos = dataLeft; + memcpy(buffer + bufferPos, data, dataLeft); + bufferPos += dataLeft; + } else { + memcpy(buffer + bufferPos, data, bufferLeft); + hs_sha256_update(in->state, buffer, SHA256_BLOCK_SIZE, state); + dataPos = bufferLeft; + dataLeft -= bufferLeft; + size_t processedLen = hs_sha256_update(state, data + dataPos, dataLeft, state); + dataPos += processedLen; + dataLeft -= processedLen; + memcpy(buffer, data + dataPos, dataLeft); + bufferPos = dataLeft; + } + + uint8_t bitsLeft = datalenbits & 7; + + // we need this conditional to avoid dereferencing past the end of "data" + uint8_t lastByte = bitsLeft == 0 ? 0x80 + : (data[dataPos] & (0xFF << (8 - bitsLeft))) | 1 << (7 - bitsLeft); + + buffer[bufferPos++] = lastByte; + + if (bufferPos <= 56) { + memset(buffer + bufferPos, 0, 56 - bufferPos); + } else { + memset(buffer + bufferPos, 0, 64 - bufferPos); + sha256_do_chunk(state,buffer); + memset(buffer, 0, 56); + } + + uint64_t finalBitLen = (in->count << 3) + datalenbits ; + + buffer[56] = (finalBitLen >> 56) & 0xFF; + buffer[57] = (finalBitLen >> 48) & 0xFF; + buffer[58] = (finalBitLen >> 40) & 0xFF; + buffer[59] = (finalBitLen >> 32) & 0xFF; + buffer[60] = (finalBitLen >> 24) & 0xFF; + buffer[61] = (finalBitLen >> 16) & 0xFF; + buffer[62] = (finalBitLen >> 8) & 0xFF; + buffer[63] = (finalBitLen ) & 0xFF; + + sha256_do_chunk(state, buffer); + + hs_sha256_encode_state(state, out); + + explicit_bzero(&state, sizeof(state)); + explicit_bzero(&buffer, sizeof(buffer)); +} + +int +hs_sha256_const_memcmp_uint32be +(const uint32_t *const a, + const uint32_t *const b, + uint32_t const n ) +{ + int d, out = 0; + uint32_t i = n; + while (i > 0) { + i--; + for (int j = 0; j < 32; j += 8 ) { + d = ((a[i] >> j) & 0xFF) - ((b[i] >> j) & 0xFF); + out = d == 0 ? out : d; + } + } + return out; +} + +// constant-ish time memcmp, could be better, but should be pretty good +// doesn't handle nulls, must be passed a non-null argument! +int +hs_sha256_const_memcmp_ctx +(const sha256_ctx *const a, + const sha256_ctx *const b ) +{ + int d; + if ( (d = hs_sha256_const_memcmp_uint32be(a->state, b->state, SHA256_STATE_LEN)) ) return d; + int x = a->count & 0x3F; + int y = b->count & 0x3F; + int n = (x < y) ? x : y; + if ( (d = hs_hashstring_const_memcmp(a->buffer, b->buffer, n)) ) return d; + if ( (d = x - y) ) return d; + // does this last comparison even matter in practice? + if (a->count == b->count) return 0; + if (a->count < b->count) return -1; + return 1; +} diff --git a/csrc/hs_sha256.h b/csrc/hs_sha256.h new file mode 100644 --- /dev/null +++ b/csrc/hs_sha256.h @@ -0,0 +1,87 @@ +#pragma once + +#include +// #include +// #include +// #include + +#define SHA256_BLOCK_SIZE 64 +#define SHA256_DIGEST_SIZE 32 +#define SHA256_STATE_LEN 8 + +typedef struct sha256_ctx +{ + uint32_t state[SHA256_STATE_LEN]; + uint64_t count; + uint8_t buffer[]; +} sha256_ctx; + +size_t +hs_sha256_update +(const uint32_t state[const SHA256_STATE_LEN], + const uint8_t *const data, + size_t const datalen, + uint32_t out[const SHA256_STATE_LEN]); + +void +hs_sha256_update_ctx +(const sha256_ctx *const in, + const uint8_t *const data, + const size_t datalen, + sha256_ctx *const out); + +void +hs_sha256_promote_to_ctx +(const uint32_t state[const SHA256_STATE_LEN], + uint64_t const blockcount, + const uint8_t *const data, + size_t const datalen, + sha256_ctx *const out); + +void +hs_sha256_finalize_ctx_bits +(const sha256_ctx *const in, + const uint8_t *const bits, + uint64_t const bitlen, + uint8_t out[const SHA256_DIGEST_SIZE]); + +void +hs_sha256_encode_state +(const uint32_t in[const SHA256_STATE_LEN], + uint8_t out[const SHA256_DIGEST_SIZE]); + +void +hs_sha256_decode_state +(const uint8_t in[const SHA256_DIGEST_SIZE], + uint32_t out[const SHA256_STATE_LEN]); + +uint64_t +hs_sha256_get_count +(const sha256_ctx *const ctx); + +uint8_t * +hs_sha256_get_buffer +(sha256_ctx *const ctx); + +uint32_t * +hs_sha256_get_state +(sha256_ctx *const ctx); + +void +hs_sha256_init_ctx +(sha256_ctx *const out); + +int +hs_sha256_const_memcmp_ctx +(const sha256_ctx *const a, + const sha256_ctx *const b); + +int +hs_sha256_const_memcmp_uint32be +(const uint32_t *const a, + const uint32_t *const b, + uint32_t const n ); + +extern const uint32_t hs_sha256_init[SHA256_STATE_LEN]; + +extern const uint8_t hs_sha256_padding[(SHA256_BLOCK_SIZE + 1)]; diff --git a/lib/Crypto/Sha256.hs b/lib/Crypto/Sha256.hs new file mode 100644 --- /dev/null +++ b/lib/Crypto/Sha256.hs @@ -0,0 +1,126 @@ +{-# LANGUAGE MagicHash, UnboxedTuples, OverloadedStrings, ScopedTypeVariables, + BangPatterns, LambdaCase #-} + +------------------------------------------------------------------------------- +-- | +-- Module: Crypto.Sha256 +-- Copyright: (c) 2024 Auth Global +-- License: Apache2 +-- +-- Binding to SHA256, supporting streaming, backtracking, bitstring inputs, and +-- (de)serialization of intermediate states. +-- +------------------------------------------------------------------------------- + +module Crypto.Sha256 + ( hash + , hash' + , Sha256Ctx() + , sha256_init + , sha256_update, sha256_feed + , sha256_updates, sha256_feeds + , sha256_byteCount + , sha256_blockCount + , sha256_bufferLength + , sha256_state + , sha256_finalize , sha256_finalize_toByteString + , sha256_finalizeBits , sha256_finalizeBits_toByteString + , sha256_finalizeBytes, sha256_finalizeBytes_toByteString + ) where + +import Data.Array.Byte +import Data.Bits((.&.), shiftR) +import Data.ByteString(ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Internal (unsafeCreate) +import Data.ByteString.Unsafe(unsafeUseAsCString, unsafeUseAsCStringLen) +import Data.Foldable(foldl') +import Data.Function((&)) +import Data.Word +import GHC.Exts +import GHC.IO + +import Crypto.HashString +import Crypto.HashString.FFI (HashString(..)) +import Crypto.Sha256.Subtle + +-- TODO: there are a number of magic literals scattered throughout that +-- really ought to refer to a symbolic constant of some sort + +hash :: ByteString -> ByteString +hash x = sha256_init & sha256_finalizeBits_toByteString x maxBound + +hash' :: ByteString -> HashString +hash' x = sha256_init & sha256_finalizeBits x maxBound + +sha256_init :: Sha256Ctx +sha256_init = + unsafePerformIO . IO $ \st -> + let !(# st0, a #) = newByteArray# 40# st + !(# st1, _ #) = unIO (c_sha256_init_ctx a) st0 + !(# st2, b #) = unsafeFreezeByteArray# a st1 + in (# st2, Sha256Ctx (ByteArray b) #) + +sha256_byteCount :: Sha256Ctx -> Word64 +sha256_byteCount (Sha256Ctx (ByteArray ctx)) = c_sha256_get_count ctx + +sha256_blockCount :: Sha256Ctx -> Word64 +sha256_blockCount ctx = sha256_byteCount ctx `shiftR` 6 + +sha256_bufferLength :: Sha256Ctx -> Word8 +sha256_bufferLength ctx = fromIntegral (sha256_byteCount ctx .&. 0x3F) + +sha256_state :: Sha256Ctx -> HashString +sha256_state = sha256state_encode . sha256state_fromCtxInplace + +sha256_update :: Sha256Ctx -> ByteString -> Sha256Ctx +sha256_update ctx0@(Sha256Ctx (ByteArray ctx)) bytes + | B.null bytes = ctx0 + | otherwise = + unsafePerformIO $ do + let count = c_sha256_get_count ctx + fromIntegral (B.length bytes) + let !(I# bufLen#) = 40 + fromIntegral (count .&. 0x3F) + unsafeUseAsCStringLen bytes $ \(bp,bl) -> IO $ \st -> + let !(# st0, a #) = newByteArray# bufLen# st + !(# st1, _ #) = unIO (c_sha256_update_ctx ctx bp (fromIntegral bl) a) st0 + !(# st2, b #) = unsafeFreezeByteArray# a st1 + in (# st2, Sha256Ctx (ByteArray b) #) + +sha256_updates :: Foldable f => Sha256Ctx -> f ByteString -> Sha256Ctx +sha256_updates = foldl' sha256_update + +sha256_feed :: ByteString -> Sha256Ctx -> Sha256Ctx +sha256_feed = flip sha256_update + +sha256_feeds :: Foldable f => f ByteString -> Sha256Ctx -> Sha256Ctx +sha256_feeds = flip sha256_updates + +sha256_finalize :: Sha256Ctx -> HashString +sha256_finalize = sha256_finalizeBits B.empty 0 + +sha256_finalize_toByteString :: Sha256Ctx -> ByteString +sha256_finalize_toByteString = sha256_finalizeBits_toByteString B.empty 0 + +sha256_finalizeBits :: ByteString -> Word64 -> Sha256Ctx -> HashString +sha256_finalizeBits bits bitlen0 (Sha256Ctx (ByteArray ctx)) = + unsafePerformIO . unsafeUseAsCString bits $ \bp -> IO $ \st -> + let !(# st0, a #) = newByteArray# 32# st + !(# st1, () #) = unIO (c_sha256_finalize_ctx_bits_ba ctx bp bitlen a) st0 + !(# st2, b #) = unsafeFreezeByteArray# a st1 + in (# st2, HashString (ByteArray b) #) + where + bitlen = min (fromIntegral (B.length bits) * 8) bitlen0 + +sha256_finalizeBits_toByteString :: ByteString -> Word64 -> Sha256Ctx -> ByteString +sha256_finalizeBits_toByteString bits bitlen0 (Sha256Ctx (ByteArray ctx)) = + unsafeCreate 32 $ \rp -> + unsafeUseAsCString bits $ \bp -> + c_sha256_finalize_ctx_bits ctx bp bitlen rp + where + bitlen = min (fromIntegral (B.length bits) * 8) bitlen0 + +sha256_finalizeBytes :: ByteString -> Sha256Ctx -> HashString +sha256_finalizeBytes = flip sha256_finalizeBits maxBound + +sha256_finalizeBytes_toByteString :: ByteString -> Sha256Ctx -> ByteString +sha256_finalizeBytes_toByteString = flip sha256_finalizeBits_toByteString maxBound diff --git a/lib/Crypto/Sha256/Hkdf.hs b/lib/Crypto/Sha256/Hkdf.hs new file mode 100644 --- /dev/null +++ b/lib/Crypto/Sha256/Hkdf.hs @@ -0,0 +1,189 @@ +------------------------------------------------------------------------------- +-- | +-- Module: Crypto.Sha256.Hkdf +-- Copyright: (c) 2024 Auth Global +-- License: Apache2 +-- +-- +-- Implementation of HKDF-SHA256 supporting key reuse, backtracking, streaming, +-- and more. +-- +------------------------------------------------------------------------------- + +module Crypto.Sha256.Hkdf + ( hkdf + , hkdf' + , hkdfList + , hkdfList' + , hkdfGen + , hkdfExtract + , hkdfExpand + , hkdfExpand' + , hkdfExpandList + , hkdfExpandList' + , hkdfExpandGen + , HkdfCtx() + , hkdfCtx_init + , hkdfCtx_feed, hkdfCtx_feeds + , hkdfCtx_update, hkdfCtx_updates + , hkdfCtx_finalize + , HkdfGen() + , hkdfGen_init + , hkdfGen_read + , hkdfGen_read' + , hkdfGen_peek + ) where + +import Control.Arrow((***)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as SB +import Data.Function((&)) +import qualified Data.List as List + +import Crypto.HashString ( HashString ) +import qualified Crypto.HashString as HS +import Crypto.Sha256.Hmac +import Crypto.Sha256.Hkdf.Subtle + +hkdf :: HmacKeyPlain -- ^ salt + -> ByteString -- ^ initial keying material + -> ByteString -- ^ info tag + -> Int -- ^ desired output length + -> ByteString +hkdf = (fmap . fmap . fmap . fmap $ HS.toByteString) hkdf' + +hkdf' :: HmacKeyPlain -- ^ salt + -> ByteString -- ^ initial keying material + -> ByteString -- ^ info tag + -> Int -- ^ desired output length + -> HashString +hkdf' = (fmap . fmap . fmap $ \gen len -> + mconcat (HS.takeBytes len (hkdfGen_toList' gen)) + ) hkdfGen + +hkdfList + :: HmacKeyPlain -- ^ salt + -> ByteString -- ^ initial keying material + -> ByteString -- ^ info tag + -> [ByteString] +hkdfList = (fmap . fmap . fmap $ hkdfGen_toList) hkdfGen + +hkdfList' + :: HmacKeyPlain -- ^ salt + -> ByteString -- ^ initial keying material + -> ByteString -- ^ info tag + -> [HashString] +hkdfList' = (fmap . fmap . fmap $ hkdfGen_toList') hkdfGen + + +hkdfGen + :: HmacKeyPlain -- ^ salt + -> ByteString -- ^ initial keying material + -> ByteString -- ^ info tag + -> HkdfGen +hkdfGen = fmap hkdfExpandGen . hkdfExtract . hmacKey_hashed + +hkdfExtract + :: HmacKey -- ^ salt + -> ByteString -- ^ initial keying material + -> HmacKey -- ^ pseudorandom key +hkdfExtract = fmap hkdfCtx_finalize . hkdfCtx_update . hkdfCtx_init + +hkdfExpand + :: HmacKey -- ^ pseudorandom key + -> ByteString -- ^ info tag + -> Int -- ^ desired length + -> ByteString +hkdfExpand = (fmap . fmap . fmap $ HS.toByteString) hkdfExpand' + +hkdfExpand' + :: HmacKey -- ^ pseudorandom key + -> ByteString -- ^ info tag + -> Int -- ^ desired length + -> HashString +hkdfExpand' = + (fmap . fmap $ \gen len -> + mconcat (HS.takeBytes len (hkdfGen_toList' gen)) + ) hkdfExpandGen + +hkdfExpandList + :: HmacKey -- ^ pseudorandom key + -> ByteString -- ^ info tag + -> [ByteString] -- ^ infinite lazy list of output blocks +hkdfExpandList = fmap hkdfGen_toList . hkdfExpandGen + +hkdfExpandList' + :: HmacKey -- ^ pseudorandom key + -> ByteString -- ^ info tag + -> [HashString] -- ^ infinite lazy list of output blocks +hkdfExpandList' = fmap hkdfGen_toList' . hkdfExpandGen + +hkdfExpandGen + :: HmacKey -- ^ pseudorandom key + -> ByteString -- ^ info tag + -> HkdfGen +hkdfExpandGen prk = hkdfGen_init prk . SB.toShort + +hkdfCtx_init :: HmacKey -> HkdfCtx +hkdfCtx_init key = HkdfCtx (hmacCtx_init key) + +hkdfCtx_feeds :: Foldable f => f ByteString -> HkdfCtx -> HkdfCtx +hkdfCtx_feeds bs (HkdfCtx ctx) = HkdfCtx (hmacCtx_feeds bs ctx) + +hkdfCtx_feed :: ByteString -> HkdfCtx -> HkdfCtx +hkdfCtx_feed bs (HkdfCtx ctx) = HkdfCtx (hmacCtx_feed bs ctx) + +hkdfCtx_updates :: Foldable f => HkdfCtx -> f ByteString -> HkdfCtx +hkdfCtx_updates (HkdfCtx ctx) bs = HkdfCtx (hmacCtx_updates ctx bs) + +hkdfCtx_update :: HkdfCtx -> ByteString -> HkdfCtx +hkdfCtx_update (HkdfCtx ctx) bs = HkdfCtx (hmacCtx_update ctx bs) + +hkdfCtx_finalize :: HkdfCtx -> HmacKey +hkdfCtx_finalize (HkdfCtx ctx) = hmacKey (HS.toByteString (hmacCtx_finalize ctx)) + +hkdfGen_init :: HmacKey -> ShortByteString -> HkdfGen +hkdfGen_init key info = HkdfGen + { hkdfGen_info = info + , hkdfGen_key = key + , hkdfGen_counter = 1 + , hkdfGen_state = HS.fromShort SB.empty + } + +hkdfGen_read' :: HkdfGen -> (HashString, HkdfGen) +hkdfGen_read' gen = (state',gen') + where + info = hkdfGen_info gen + key = hkdfGen_key gen + counter = hkdfGen_counter gen + state = hkdfGen_state gen + counter' = counter + 1 + state' = hmacCtx_init key & + hmacCtx_feed (HS.toByteString state) & + hmacCtx_feed (SB.fromShort info) & + hmacCtx_finalizeBits (B.singleton counter) 8 + gen' = HkdfGen + { hkdfGen_info = info + , hkdfGen_key = key + , hkdfGen_counter = counter' + , hkdfGen_state = state' + } + +hkdfGen_read :: HkdfGen -> (ByteString, HkdfGen) +hkdfGen_read = (HS.toByteString *** id) . hkdfGen_read' + +hkdfGen_peek :: HkdfGen -> Maybe HashString +hkdfGen_peek gen = + if (SB.null (HS.toShort st)) + then Nothing + else Just st + where + st = hkdfGen_state gen + +hkdfGen_toList' :: HkdfGen -> [HashString] +hkdfGen_toList' = List.unfoldr (Just . hkdfGen_read') + +hkdfGen_toList :: HkdfGen -> [ByteString] +hkdfGen_toList = List.unfoldr (Just . hkdfGen_read) diff --git a/lib/Crypto/Sha256/Hkdf/Subtle.hs b/lib/Crypto/Sha256/Hkdf/Subtle.hs new file mode 100644 --- /dev/null +++ b/lib/Crypto/Sha256/Hkdf/Subtle.hs @@ -0,0 +1,29 @@ +------------------------------------------------------------------------------- +-- | +-- Module: Crypto.Sha256.Hkdf.Subtle +-- Copyright: (c) 2024 Auth Global +-- License: Apache2 +-- +------------------------------------------------------------------------------- + +module Crypto.Sha256.Hkdf.Subtle where + +import Data.ByteString.Short(ShortByteString) +import Data.Word +import Crypto.HashString +import Crypto.Sha256.Hmac + +-- | Context type for incremental @hkdfExtract@ + +newtype HkdfCtx = HkdfCtx { + hkdfCtx_hmacCtx :: HmacCtx + } deriving (Eq, Ord) + +-- | Plain-old-data representation of the generator for @hkdfExpand@ + +data HkdfGen = HkdfGen + { hkdfGen_info :: !ShortByteString + , hkdfGen_key :: !HmacKey + , hkdfGen_counter :: !Word8 + , hkdfGen_state :: !HashString + } diff --git a/lib/Crypto/Sha256/Hmac.hs b/lib/Crypto/Sha256/Hmac.hs new file mode 100644 --- /dev/null +++ b/lib/Crypto/Sha256/Hmac.hs @@ -0,0 +1,401 @@ +{-# LANGUAGE ViewPatterns, LambdaCase, BangPatterns #-} + +------------------------------------------------------------------------------- +-- | +-- Module: Crypto.Sha256.Hmac +-- Copyright: (c) 2024 Auth Global +-- License: Apache2 +-- +-- An implementation of HMAC-SHA256 that supports precomputed keys, streaming, +-- backtracking, bitstring inputs, and (de)serialization of intermediate states. +-- +------------------------------------------------------------------------------- + +module Crypto.Sha256.Hmac + ( hmac + , hmac' + , HmacKeyPlain + -- , hmacKeyPlain_eq + , HmacKey() + , hmacKey + , hmacKey_hashed + , hmacKey_toPlain + , hmacKey_toHashed + , hmacKey_forgetPlain + , hmacKey_run + , HmacKeyLike() + , hmacKeyLike + , hmacKeyLike_init + , hmacKeyLike_initHashed + , hmacKeyLike_initPrefixed + , hmacKeyLike_toKey + , hmacKeyLike_toPlain + , hmacKeyLike_toHashed + , hmacKeyLike_toPrefixed + , hmacKeyLike_run + , hmacKeyLike_byteCount + , hmacKeyLike_blockCount + , hmacKeyLike_bufferLength + -- , hmacKeyLike_feeds + -- , hmacKeyLike_feedsWith + , HmacKeyHashed() + , hmacKeyHashed + , hmacKeyHashed_toKey + , hmacKeyHashed_run + , hmacKeyHashed_runWith + , HmacKeyPrefixed() + , hmacKeyPrefixed + , hmacKeyPrefixed_init + , hmacKeyPrefixed_initHashed + , hmacKeyPrefixed_initLike + , hmacKeyPrefixed_toHashed + -- , hmacKeyPrefixed_eqHashed + , hmacKeyPrefixed_feed + , hmacKeyPrefixed_feeds + , hmacKeyPrefixed_feedsWith + , hmacKeyPrefixed_run + , hmacKeyPrefixed_byteCount + , hmacKeyPrefixed_blockCount + , hmacKeyPrefixed_bufferLength + , HmacCtx() + , hmacCtx + , hmacCtx_init + , hmacCtx_initWith + , hmacCtx_update, hmacCtx_feed + , hmacCtx_updates, hmacCtx_feeds + , hmacCtx_finalize , hmacCtx_finalize_toByteString + , hmacCtx_finalizeBits , hmacCtx_finalizeBits_toByteString + , hmacCtx_finalizeBytes, hmacCtx_finalizeBytes_toByteString + , hmacCtx_byteCount + , hmacCtx_blockCount + , hmacCtx_bufferLength +-- , hmacCtx_toHmacKeyPrefixed + ) where + +import Data.Bits(xor) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.List(scanl') +import Data.Function((&)) +import Data.Foldable(Foldable, toList) +import Data.Int +import Data.Word + +import Crypto.HashString +import Crypto.Sha256 as Sha256 +import Crypto.Sha256.Subtle +import Crypto.Sha256.Hmac.Implementation + +-- Should these be made publicly available? Are these available anywhere else? +dropBs :: Int64 -> [ ByteString ] -> [ ByteString ] +dropBs = go + where + len = fromIntegral . B.length + go _ [] = [] + go 0 bs = bs + go n (b:bs) + | n >= len b = go (n - len b) bs + | otherwise = B.drop (fromIntegral n) b : bs + +takeBs :: Int64 -> [ ByteString ] -> [ ByteString ] +takeBs = go + where + len = fromIntegral . B.length + go _ [] = [] + go n (b:bs) + | n <= 0 = [] + | len b < n = b : go (n - len b) bs + | otherwise = [B.take (fromIntegral n) b] + +takeBs' :: Int64 -> [ ByteString ] -> [ ByteString ] +takeBs' n bs = if haveEnough then takeBs n bs else [] + where + len = fromIntegral . B.length + haveEnough = any (>= n) (scanl' (+) 0 (map len bs)) + + +-- Initialize a precomputed hmac key from a plaintext bytestring, which +-- can then be turned into an hmac context using 'hmacKey_run' +-- +-- Note this structure retains the plaintext key, which isn't strictly necessary +-- for actually computing the resulting hmac function. The plaintext key can +-- be forgotten using 'hmacKey_forgetPlain'. +hmacKey :: HmacKeyPlain -> HmacKey +hmacKey key = HmacKey_Plain key (hmacKeyHashed key) + +-- | If the plaintext hmac key has been remembered by the precomputed key, return it. +-- Otherwise return 'Nothing'. Keys precomputed by 'hmacKey' retain the plaintext, +-- which can subsequently be forgotten by 'hmacKey_forgetPlain'. Alternatively, +-- keys precomputed by 'hmacKey_hashed' never retains the plaintext key in the +-- first place. +hmacKey_toPlain :: HmacKey -> Maybe HmacKeyPlain +hmacKey_toPlain = \case + HmacKey_Plain a _ -> Just a + HmacKey_Hashed _ -> Nothing + +-- | Forget any plaintext hmac keys being retained by a given precomputed key, meaning +-- that for all x, @hmacKey_toPlain (hmacKey_forgetPlain x) == Nothing@. +-- +-- This is potentially useful when implementing PBKDF2, as the plaintext password can +-- immediately be replaced with a precomputed hmac key, even before key-stretching +-- is complete. Note that the precomputed hmac key does provide a fast brute-force +-- attack on the plaintext key, typically as little as 1 SHA256 block, so this cannot be +-- relied upon for secrecy if the hmac key is potentially guessable, such as a weak +-- password or a non-secret salt. + +hmacKey_forgetPlain :: HmacKey -> HmacKey +hmacKey_forgetPlain = \case + HmacKey_Plain _ b -> HmacKey_Hashed b + x@(HmacKey_Hashed _) -> x + +hmacKeyLike :: HmacKeyPlain -> HmacKeyLike +hmacKeyLike key = HmacKeyLike_Plain key (hmacKeyHashed key) + +hmacKeyLike_init :: HmacKey -> HmacKeyLike +hmacKeyLike_init = \case + HmacKey_Plain a b -> HmacKeyLike_Plain a b + HmacKey_Hashed b -> HmacKeyLike_Hashed b + +hmacKeyLike_initHashed :: HmacKeyHashed -> HmacKeyLike +hmacKeyLike_initHashed = HmacKeyLike_Hashed + +hmacKeyLike_initPrefixed :: HmacKeyPrefixed -> HmacKeyLike +hmacKeyLike_initPrefixed = HmacKeyLike_Prefixed + +hmacKeyLike_toPlain :: HmacKeyLike -> Maybe HmacKeyPlain +hmacKeyLike_toPlain = \case + HmacKeyLike_Plain a _ -> Just a + HmacKeyLike_Hashed _ -> Nothing + HmacKeyLike_Prefixed _ -> Nothing + +hmacKeyLike_toHashed :: HmacKeyLike -> Maybe HmacKeyHashed +hmacKeyLike_toHashed = \case + HmacKeyLike_Plain _ a -> Just a + HmacKeyLike_Hashed a -> Just a + HmacKeyLike_Prefixed a -> hmacKeyPrefixed_toHashed a + +hmacKeyLike_toKey :: HmacKeyLike -> Maybe HmacKey +hmacKeyLike_toKey = \case + HmacKeyLike_Plain a b -> Just $ HmacKey_Plain a b + HmacKeyLike_Hashed b -> Just $ HmacKey_Hashed b + HmacKeyLike_Prefixed c -> HmacKey_Hashed <$> hmacKeyPrefixed_toHashed c + +hmacKeyLike_run :: HmacKeyLike -> HmacCtx +hmacKeyLike_run = \case + HmacKeyLike_Plain _ a -> hmacKeyHashed_run a + HmacKeyLike_Hashed a -> hmacKeyHashed_run a + HmacKeyLike_Prefixed a -> hmacKeyPrefixed_run a + +-- | how many bytes have been fed into the SHA256 state machine? This is always 64 +-- more bytes than hmac's "message" input. +-- If @hmacKeyLike_toKey x == Just ...@, then @hmacKeyLike_byteCount x == 64@. +-- If @hmacKeyLike_toKey x == Nothing@, then this returns a multiple of 64 that is +-- greater or equal to 128. +-- + +hmacKeyLike_byteCount :: HmacKeyLike -> Word64 +hmacKeyLike_byteCount = \case + HmacKeyLike_Plain _ _ -> 64 + HmacKeyLike_Hashed _ -> 64 + HmacKeyLike_Prefixed b -> hmacKeyPrefixed_byteCount b + +hmacKeyLike_blockCount :: HmacKeyLike -> Word64 +hmacKeyLike_blockCount = \case + HmacKeyLike_Plain _ _ -> 1 + HmacKeyLike_Hashed _ -> 1 + HmacKeyLike_Prefixed b -> hmacKeyPrefixed_blockCount b + +hmacKeyLike_bufferLength :: HmacKeyLike -> Word8 +hmacKeyLike_bufferLength = const 0 + +-- | Precompute an HmacKey without retaining the plaintext input, equivalent to +-- 'hmacKey_forgetInput . hmacKey' +hmacKey_hashed :: HmacKeyPlain -> HmacKey +hmacKey_hashed = HmacKey_Hashed . hmacKeyHashed + +hmacKey_run :: HmacKey -> HmacCtx +hmacKey_run = hmacCtx_init + +hmacKeyHashed :: HmacKeyPlain -> HmacKeyHashed +hmacKeyHashed key = HmacKeyHashed opad ipad + where + ipad = tweak 0x36 + opad = tweak 0x5c + k1 = if B.length key > 64 then Sha256.hash key else key + k2 = B.append k1 (B.replicate (64 - B.length k1) 0) + tweak c = sha256state_init & sha256state_feed (B.map (xor c) k2) + +hmacKeyHashed_toKey :: HmacKeyHashed -> HmacKey +hmacKeyHashed_toKey = HmacKey_Hashed + +hmacKeyHashed_run :: HmacKeyHashed -> HmacCtx +hmacKeyHashed_run key = HmacCtx + { hmacCtx_ipadCtx = hmacKeyHashed_ipadCtx key + , hmacCtx_opad = hmacKeyHashed_opad key + } + +hmacKeyHashed_runWith :: HmacKeyHashed -> ByteString -> HmacCtx +hmacKeyHashed_runWith key str = HmacCtx + { hmacCtx_ipadCtx = hmacKeyHashed_runIpadCtx key str + , hmacCtx_opad = hmacKeyHashed_opad key + } + +hmacKeyPrefixed :: HmacKeyPlain -> HmacKeyPrefixed +hmacKeyPrefixed = hmacKeyPrefixed_initHashed . hmacKeyHashed + +hmacKeyPrefixed_init :: HmacKey -> HmacKeyPrefixed +hmacKeyPrefixed_init = hmacKeyPrefixed_initHashed . hmacKey_toHashed + +hmacKeyPrefixed_initLike :: HmacKeyLike -> HmacKeyPrefixed +hmacKeyPrefixed_initLike = hmacKeyLike_toPrefixed + +hmacKeyPrefixed_toHashed :: HmacKeyPrefixed -> Maybe HmacKeyHashed +hmacKeyPrefixed_toHashed x = + if hmacKeyPrefixed_blockCount x == 1 + then Just $ HmacKeyHashed + { hmacKeyHashed_ipad = sha256state_fromCtxInplace (hmacKeyPrefixed_ipadCtx x) + , hmacKeyHashed_opad = hmacKeyPrefixed_opad x + } + else Nothing + +hmacKeyPrefixed_feed :: ByteString -> HmacKeyPrefixed -> (ByteString, HmacKeyPrefixed) +hmacKeyPrefixed_feed x = hmacKeyPrefixed_feeds [x] + +hmacKeyPrefixed_feeds :: Foldable f => f ByteString -> HmacKeyPrefixed -> (ByteString, HmacKeyPrefixed) +hmacKeyPrefixed_feeds = hmacKeyPrefixed_feedsWith id + +hmacKeyPrefixed_feedsWith :: Foldable f => (a -> ByteString) -> f a -> HmacKeyPrefixed -> (ByteString, HmacKeyPrefixed) +hmacKeyPrefixed_feedsWith f = go . map f . toList + where + go bss !st = + case takeBs' 64 bss of + [] -> (B.concat bss, st) + x -> go (dropBs 64 bss) st' + where + st' = HmacKeyPrefixed + { hmacKeyPrefixed_ipadCtx = sha256_updates (hmacKeyPrefixed_ipadCtx st) x + , hmacKeyPrefixed_opad = hmacKeyPrefixed_opad st + } + +hmacKeyPrefixed_run :: HmacKeyPrefixed -> HmacCtx +hmacKeyPrefixed_run key = HmacCtx + { hmacCtx_ipadCtx = hmacKeyPrefixed_ipadCtx key + , hmacCtx_opad = hmacKeyPrefixed_opad key + } + +hmacKeyPrefixed_byteCount :: HmacKeyPrefixed -> Word64 +hmacKeyPrefixed_byteCount = sha256_byteCount . hmacKeyPrefixed_ipadCtx + +hmacKeyPrefixed_bufferLength :: HmacKeyPrefixed -> Word8 +hmacKeyPrefixed_bufferLength = const 0 + +-- | A simple interface to HMAC-SHA256. Note that this function was written +-- to make partial application an efficient way to compute the hmac of +-- multiple messages with exactly the same key: +-- +-- @ +-- let myHash = hmac "my-key" +-- in (myHash "message 1", myHash "message 2", myHash "message 3") +-- @ +-- +-- This typically saves two SHA-256 blocks per reused function application. +-- Thus this example saves four block computations from the two reused +-- calls to @myHash@ in this example. +-- +-- Initializing the @myHash@ closure requires computing two SHA-256 blocks. +-- Applying the closure requires two further SHA-256 blocks per message, +-- as every message is less than 56 bytes long. Thus the total computation +-- requires 8 SHA-256 blocks with reuse, or 12 SHA-256 blocks without reuse. +-- +-- Key reuse can save four or more block computations per application if +-- the reused key is longer than 64 bytes. I don't recommend using HMAC +-- keys that are longer than 64 bytes, as all such keys can be trivially +-- replaced with the SHA256 hash of the key, which is only 32 bytes long. +-- +-- This high-level interface is implemented using 'hmacCtx_finalize', +-- 'hmacKeyHashed_run', and 'hmacKeyHashed' composed in a point-free style +-- in order to help ensure key reuse works as expected. + +hmac :: HmacKeyPlain -> ByteString -> ByteString +hmac = fmap hmacCtx_finalize_toByteString . hmacCtx_initWith . hmacKey_hashed + +hmac' :: HmacKeyPlain -> ByteString -> HashString +hmac' = fmap hmacCtx_finalize . hmacCtx_initWith . hmacKey_hashed + +hmacCtx :: HmacKeyPlain -> HmacCtx +hmacCtx = hmacCtx_init . hmacKey_hashed + +-- | Initialize a new empty HMAC context from a precomputed HMAC key. + +hmacCtx_init :: HmacKey -> HmacCtx +hmacCtx_init = hmacKeyHashed_run . hmacKey_toHashed + +hmacCtx_initWith :: HmacKey -> ByteString -> HmacCtx +hmacCtx_initWith = hmacKeyHashed_runWith . hmacKey_toHashed + +-- | Append a bytestring onto the end of the message argument to HMAC. + +hmacCtx_update :: HmacCtx -> ByteString -> HmacCtx +hmacCtx_update = flip hmacCtx_feed + +hmacCtx_feed :: ByteString -> HmacCtx -> HmacCtx +hmacCtx_feed b (HmacCtx oc ic) = HmacCtx oc (sha256_update ic b) + +-- | Append zero or more bytestrings onto the end of the message argument to +-- HMAC. + +hmacCtx_updates :: Foldable f => HmacCtx -> f ByteString -> HmacCtx +hmacCtx_updates = flip hmacCtx_feeds + +hmacCtx_feeds :: Foldable f => f ByteString -> HmacCtx -> HmacCtx +hmacCtx_feeds bs (HmacCtx oc ic) = HmacCtx oc (sha256_updates ic (toList bs)) + +-- | Finish computing the final 32-byte hash for an HMAC context. + +hmacCtx_finalize :: HmacCtx -> HashString +hmacCtx_finalize = hmacCtx_finalizeBits B.empty 0 + +-- | Append any arbitrary bitstring onto the end of an HMAC context, and +-- finish computing the final 32-byte hash. + +hmacCtx_finalizeBits :: ByteString -> Word64 -> HmacCtx -> HashString +hmacCtx_finalizeBits bits bitlen (HmacCtx oc ic) = outer + where + inner = sha256_finalizeBits_toByteString bits bitlen ic + outer = sha256_finalize (sha256state_runWith 1 inner oc) + +hmacCtx_finalize_toByteString :: HmacCtx -> ByteString +hmacCtx_finalize_toByteString = hmacCtx_finalizeBits_toByteString B.empty 0 + +-- | Append any arbitrary bitstring onto the end of an HMAC context, and +-- finish computing the final 32-byte hash. + +hmacCtx_finalizeBits_toByteString :: ByteString -> Word64 -> HmacCtx -> ByteString +hmacCtx_finalizeBits_toByteString bits bitlen (HmacCtx oc ic) = outer + where + inner = sha256_finalizeBits_toByteString bits bitlen ic + outer = sha256_finalize_toByteString (sha256state_runWith 1 inner oc) + +hmacCtx_finalizeBytes :: ByteString -> HmacCtx -> HashString +hmacCtx_finalizeBytes = flip hmacCtx_finalizeBits maxBound + +hmacCtx_finalizeBytes_toByteString :: ByteString -> HmacCtx -> ByteString +hmacCtx_finalizeBytes_toByteString = flip hmacCtx_finalizeBits_toByteString maxBound + +hmacCtx_byteCount :: HmacCtx -> Word64 +hmacCtx_byteCount = sha256_byteCount . hmacCtx_ipadCtx + +hmacCtx_blockCount :: HmacCtx -> Word64 +hmacCtx_blockCount = sha256_blockCount . hmacCtx_ipadCtx + +hmacCtx_bufferLength :: HmacCtx -> Word8 +hmacCtx_bufferLength = sha256_bufferLength . hmacCtx_ipadCtx + +-- Ugh, I don't have convenient access to cryptohash's internal counter. I +-- should fix that. I also need to fix the fact that cryptohash-sha256 exposes +-- endianess issues in a publicly-facing bytestrings, thus potentially creating +-- less-than-immediately-obvious problems when serializing/deserializing SHA256 +-- states. Thus part of the reason why I started on newer SHA256 bindings for +-- GHC 9.4. + +-- hmacCtx_toHmacKeyPrefixed :: HmacCtx -> (ByteString, HmacKeyPrefixed) diff --git a/lib/Crypto/Sha256/Hmac/Implementation.hs b/lib/Crypto/Sha256/Hmac/Implementation.hs new file mode 100644 --- /dev/null +++ b/lib/Crypto/Sha256/Hmac/Implementation.hs @@ -0,0 +1,233 @@ +{-# LANGUAGE ViewPatterns, LambdaCase #-} + +module Crypto.Sha256.Hmac.Implementation where + +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.Function(on) +import Data.Word + +import Crypto.Sha256 as Sha256 +import Crypto.Sha256.Subtle + +type HmacKeyPlain = ByteString + +nullBuffer :: ByteString +nullBuffer = BS.replicate 64 0 + +-- | A cached, precomputed hmac key. It comes in two flavors, one that remembers the +-- plaintext key, and one that doesn't, remembering only the precomputed hmac key. +-- +-- Computing an hmac key typically requires two SHA256 blocks, unless the key itself +-- is more than 64 bytes, in which case precomputing the key will require at least +-- four SHA256 blocks. + +data HmacKey + = HmacKey_Plain {-# UNPACK #-} !HmacKeyPlain HmacKeyHashed + | HmacKey_Hashed {-# UNPACK #-} !HmacKeyHashed + +instance Eq HmacKey where + (HmacKey_Plain a _) == (HmacKey_Plain b _) = hmacKeyPlain_eq a b + a == b = hmacKey_toHashed a == hmacKey_toHashed b + +instance Ord HmacKey where + compare = compare `on` hmacKey_toHashed + +-- | This function can in theory return False, when converting both strings +-- to a 'HmacKeyHashed' first and then comparing returns True. However, +-- probabilistically speaking, the recall of this function is +-- cryptographically close to 1, and significantly faster than a full +-- HMAC key derivation. +-- +-- There are three ways that a failure of recall, i.e. a false negative, can +-- happen: +-- +-- If one key is 32 bytes or shorter, and the other is longer than 64 bytes, +-- recall failures can happen if the SHA-256 hash of the longer key ends in +-- at least 16 null bytes, corresponding to a partial preimage. +-- +-- If both keys are longer than 64 bytes, recall failures can happen when +-- those keys collide SHA-256. +-- +-- Alternatively, recall failures can happen when HMAC-SHA256's key schedule +-- collides. This should be considerably more difficult than a regular SHA-256 +-- collision, because it involves xor'ing each key with two different pads, +-- and then hashing both. Thus, effectively, this requires two SHA-256 +-- collisions of a very specific form. + +hmacKeyPlain_eq :: HmacKeyPlain -> HmacKeyPlain -> Bool +hmacKeyPlain_eq a b = + case (BS.length a > 64, BS.length b > 64) of + (False, False) -> ((==) `on` normalize) a b + (True, False) -> checkEq a b + (False, True) -> checkEq b a + (True, True) -> a == b + where + normalize = BS.dropWhileEnd (==0) + checkEq x (normalize -> y) + | BS.length y > 32 || BS.length y <= 16 = False + | otherwise = normalize (Sha256.hash x) == y + +hmacKey_ipad :: HmacKey -> Sha256State +hmacKey_ipad = hmacKeyHashed_ipad . hmacKey_toHashed + +hmacKey_runIpadCtx :: HmacKey -> ByteString -> Sha256Ctx +hmacKey_runIpadCtx k b = sha256state_runWith 1 b (hmacKey_ipad k) + +hmacKey_ipadCtx :: HmacKey -> Sha256Ctx +hmacKey_ipadCtx = flip hmacKey_runIpadCtx BS.empty + +hmacKey_opad :: HmacKey -> Sha256State +hmacKey_opad = hmacKeyHashed_opad . hmacKey_toHashed + +hmacKey_runOpadCtx :: HmacKey -> ByteString -> Sha256Ctx +hmacKey_runOpadCtx k b = sha256state_runWith 1 b (hmacKey_opad k) + +hmacKey_opadCtx :: HmacKey -> Sha256Ctx +hmacKey_opadCtx = flip hmacKey_runOpadCtx BS.empty + +hmacKey_toHashed :: HmacKey -> HmacKeyHashed +hmacKey_toHashed = \case + HmacKey_Plain _ x -> x + HmacKey_Hashed x -> x + +-- | An @HmacKeyLike@ context can either be an 'HmacKey', or a +-- 'HmacKeyPrefixed'. + +data HmacKeyLike + = HmacKeyLike_Plain {-# UNPACK #-} !HmacKeyPlain HmacKeyHashed + | HmacKeyLike_Hashed {-# UNPACK #-} !HmacKeyHashed + | HmacKeyLike_Prefixed {-# UNPACK #-} !HmacKeyPrefixed + +hmacKeyPrefixed_eqHashed :: HmacKeyPrefixed -> HmacKeyHashed -> Bool +hmacKeyPrefixed_eqHashed a + | hmacKeyPrefixed_blockCount a /= 1 = const False + | otherwise = \b -> hmacKeyPrefixed_ipadCtx a == hmacKeyHashed_ipadCtx b + && hmacKeyPrefixed_opad a == hmacKeyHashed_opad b + +instance Eq HmacKeyLike where + (HmacKeyLike_Plain a _) == (HmacKeyLike_Plain b _) = hmacKeyPlain_eq a b + (HmacKeyLike_Plain _ a) == (HmacKeyLike_Hashed b) = a == b + (HmacKeyLike_Plain _ a) == (HmacKeyLike_Prefixed b) = hmacKeyPrefixed_eqHashed b a + (HmacKeyLike_Hashed a) == (HmacKeyLike_Plain _ b) = a == b + (HmacKeyLike_Hashed a) == (HmacKeyLike_Hashed b) = a == b + (HmacKeyLike_Hashed a) == (HmacKeyLike_Prefixed b) = hmacKeyPrefixed_eqHashed b a + (HmacKeyLike_Prefixed a) == (HmacKeyLike_Plain _ b) = hmacKeyPrefixed_eqHashed a b + (HmacKeyLike_Prefixed a) == (HmacKeyLike_Hashed b) = hmacKeyPrefixed_eqHashed a b + (HmacKeyLike_Prefixed a) == (HmacKeyLike_Prefixed b) = a == b + +instance Ord HmacKeyLike where + compare = compare `on` hmacKeyLike_toPrefixed + +hmacKeyLike_toPrefixed :: HmacKeyLike -> HmacKeyPrefixed +hmacKeyLike_toPrefixed = \case + HmacKeyLike_Plain _ b -> hmacKeyPrefixed_initHashed b + HmacKeyLike_Hashed b -> hmacKeyPrefixed_initHashed b + HmacKeyLike_Prefixed b -> b + +hmacKeyPrefixed_initHashed :: HmacKeyHashed -> HmacKeyPrefixed +hmacKeyPrefixed_initHashed k = HmacKeyPrefixed (hmacKeyHashed_opad k) (hmacKeyHashed_ipadCtx k) + +hmacKeyLike_ipadCtx :: HmacKeyLike -> Sha256Ctx +hmacKeyLike_ipadCtx = \case + HmacKeyLike_Plain _ x -> hmacKeyHashed_ipadCtx x + HmacKeyLike_Hashed x -> hmacKeyHashed_ipadCtx x + HmacKeyLike_Prefixed x -> hmacKeyPrefixed_ipadCtx x + +hmacKeyLike_opad :: HmacKeyLike -> Sha256State +hmacKeyLike_opad = \case + HmacKeyLike_Plain _ x -> hmacKeyHashed_opad x + HmacKeyLike_Hashed x -> hmacKeyHashed_opad x + HmacKeyLike_Prefixed x -> hmacKeyPrefixed_opad x + +hmacKeyLike_opadCtx :: HmacKeyLike -> Sha256Ctx +hmacKeyLike_opadCtx = \case + HmacKeyLike_Plain _ x -> hmacKeyHashed_opadCtx x + HmacKeyLike_Hashed x -> hmacKeyHashed_opadCtx x + HmacKeyLike_Prefixed x -> hmacKeyPrefixed_opadCtx x + +hmacKeyLike_runIpadCtx :: HmacKeyLike -> ByteString -> Sha256Ctx +hmacKeyLike_runIpadCtx = \case + HmacKeyLike_Plain _ x -> hmacKeyHashed_runIpadCtx x + HmacKeyLike_Hashed x -> hmacKeyHashed_runIpadCtx x + HmacKeyLike_Prefixed x -> hmacKeyPrefixed_runIpadCtx x + +hmacKeyLike_runOpadCtx :: HmacKeyLike -> ByteString -> Sha256Ctx +hmacKeyLike_runOpadCtx = \case + HmacKeyLike_Plain _ x -> hmacKeyHashed_runOpadCtx x + HmacKeyLike_Hashed x -> hmacKeyHashed_runOpadCtx x + HmacKeyLike_Prefixed x -> hmacKeyPrefixed_runOpadCtx x + +-- | Fixed-size context representing the state of a partial HMAC computation +-- with a complete HMAC key and a partial message parameter. This maintains +-- a buffer of up to 63 unprocessed bytes, so that you may feed it arbitrary +-- bytestring without dealing with buffer boundaries. + +data HmacCtx = HmacCtx + { hmacCtx_opad :: {-# UNPACK #-} !Sha256State + , hmacCtx_ipadCtx :: {-# UNPACK #-} !Sha256Ctx + } deriving (Eq, Ord) + +-- | A precomputed HMAC key. This structure is 64 bytes long, and consists of two +-- SHA256 hashes. +-- +-- Computing an HMAC key typically costs two SHA256 blocks. No additional +-- blocks are incurred for keys that are 64 bytes or less in +-- length. Keys that are longer than 64 bytes long must be first hashed +-- with SHA256 before the key can be derived, incurring extra block +-- comptuations. +-- +-- It is not uncommon that implementations of PBKDF2, HKDF, etc unnecessarily +-- redo this computation even though a single HMAC key is used repeatedly. +-- +-- Technically these "hashes" are unfinished SHA-256 states, +-- as the standard end-of-message padding has yet to be applied. +-- Thus you can't compute these hashes using the most common +-- command-line tools like sha256sum. +-- +-- The lack of end-of-message padding is also why precomputing +-- HMAC keys on keys up to 64 bytes only requires one SHA-256 block +-- computation for each of the two pads, whereas more typically +-- the boundary for extra block computations happens between the 55th +-- and 56th byte due to end-of-message padding. + +-- TODO: Might it be a good idea to pack both states into one ByteArray? + +data HmacKeyHashed = HmacKeyHashed + { hmacKeyHashed_opad :: {-# UNPACK #-} !Sha256State + , hmacKeyHashed_ipad :: {-# UNPACK #-} !Sha256State + } deriving (Eq, Ord) + +hmacKeyHashed_ipadCtx :: HmacKeyHashed -> Sha256Ctx +hmacKeyHashed_ipadCtx = flip hmacKeyHashed_runIpadCtx BS.empty + +hmacKeyHashed_runIpadCtx :: HmacKeyHashed -> ByteString -> Sha256Ctx +hmacKeyHashed_runIpadCtx k b = sha256state_runWith 1 b (hmacKeyHashed_ipad k) + +hmacKeyHashed_opadCtx :: HmacKeyHashed -> Sha256Ctx +hmacKeyHashed_opadCtx = flip hmacKeyHashed_runOpadCtx BS.empty + +hmacKeyHashed_runOpadCtx :: HmacKeyHashed -> ByteString -> Sha256Ctx +hmacKeyHashed_runOpadCtx k b = sha256state_runWith 1 b (hmacKeyHashed_opad k) + +-- | Halfway between an HmacKeyHashed and an HmacCtx. +-- It's both an HmacKeyHashed that's gained a counter, +-- and a HmacCtx that's guaranteed to contain no unprocessed +-- input data. + +data HmacKeyPrefixed = HmacKeyPrefixed + { hmacKeyPrefixed_opad :: {-# UNPACK #-} !Sha256State + , hmacKeyPrefixed_ipadCtx :: {-# UNPACK #-} !Sha256Ctx + } deriving (Eq, Ord) + +hmacKeyPrefixed_runIpadCtx :: HmacKeyPrefixed -> ByteString -> Sha256Ctx +hmacKeyPrefixed_runIpadCtx k b = sha256_feed b (hmacKeyPrefixed_ipadCtx k) + +hmacKeyPrefixed_runOpadCtx :: HmacKeyPrefixed -> ByteString -> Sha256Ctx +hmacKeyPrefixed_runOpadCtx k b = sha256state_runWith 1 b (hmacKeyPrefixed_opad k) + +hmacKeyPrefixed_opadCtx :: HmacKeyPrefixed -> Sha256Ctx +hmacKeyPrefixed_opadCtx = flip hmacKeyPrefixed_runOpadCtx BS.empty + +hmacKeyPrefixed_blockCount :: HmacKeyPrefixed -> Word64 +hmacKeyPrefixed_blockCount = sha256_blockCount . hmacKeyPrefixed_ipadCtx diff --git a/lib/Crypto/Sha256/Hmac/Subtle.hs b/lib/Crypto/Sha256/Hmac/Subtle.hs new file mode 100644 --- /dev/null +++ b/lib/Crypto/Sha256/Hmac/Subtle.hs @@ -0,0 +1,35 @@ +------------------------------------------------------------------------------- +-- | +-- Module: Crypto.Sha256.Hmac.Subtle +-- Copyright: (c) 2024 Auth Global +-- License: Apache2 +-- +-- "Internal" data structures and functions for hmac +-- +------------------------------------------------------------------------------- + +module Crypto.Sha256.Hmac.Subtle + ( HmacKey(..) + , hmacKey_ipad + , hmacKey_ipadCtx + , hmacKey_opad + , hmacKey_opadCtx + , HmacKeyLike(..) + , hmacKeyLike_ipadCtx + , hmacKeyLike_opad + , hmacKeyLike_opadCtx + , hmacKeyLike_runIpadCtx + , hmacKeyLike_runOpadCtx + , HmacKeyHashed(..) + , hmacKeyHashed_ipadCtx + , hmacKeyHashed_opadCtx + , hmacKeyHashed_runIpadCtx + , hmacKeyHashed_runOpadCtx + , HmacKeyPrefixed(..) + , hmacKeyPrefixed_opadCtx + , hmacKeyPrefixed_runIpadCtx + , hmacKeyPrefixed_runOpadCtx + , HmacCtx(..) + ) where + +import Crypto.Sha256.Hmac.Implementation diff --git a/lib/Crypto/Sha256/Pbkdf2.hs b/lib/Crypto/Sha256/Pbkdf2.hs new file mode 100644 --- /dev/null +++ b/lib/Crypto/Sha256/Pbkdf2.hs @@ -0,0 +1,155 @@ +{-# LANGUAGE BangPatterns #-} + +------------------------------------------------------------------------------- +-- | +-- Module: Crypto.Sha256.Pbkdf2 +-- Copyright: (c) 2024 Auth Global +-- License: Apache2 +-- +-- An implementation of PBKDF2-HMAC-SHA256 +-- +------------------------------------------------------------------------------- + +module Crypto.Sha256.Pbkdf2 + ( pbkdf2 + , pbkdf2_index + , Pbkdf2Ctx() + , pbkdf2Ctx_init + , pbkdf2Ctx_feed, pbkdf2Ctx_feeds + , pbkdf2Ctx_update, pbkdf2Ctx_updates + , pbkdf2Ctx_finalize + , Pbkdf2Gen() + , pbkdf2Gen_iterate + , pbkdf2Gen_finalize + ) + where + +import Data.ByteString(ByteString) +import qualified Data.ByteString.Short as SB +import Data.Function((&)) +import Data.Word +import Crypto.HashString ( HashString ) +import qualified Crypto.HashString as HS +import Crypto.Sha256 +import Crypto.Sha256.Hmac +import Crypto.Sha256.Hmac.Subtle +import Crypto.Sha256.Pbkdf2.Subtle +import qualified Network.ByteOrder as NB + +takeHS :: Int -> [ HashString ] -> [ HashString ] +takeHS = go + where + len = SB.length . HS.toShort + go _ [] = [] + go n (b:bs) + | n <= 0 = [] + | len b < n = b : go (n - len b) bs + | otherwise = [HS.fromShort (SB.take n (HS.toShort b))] + +-- | Simple interface to PBKDF2. Reusing computations via partial application is +-- not (yet!) supported. TODO: write pbkdf2 and pbkdf2_index functions in a +-- point-free style. + +pbkdf2 + :: ByteString -- ^ nominally the "password" + -> ByteString -- ^ nominally the "salt" + -> Word64 -- ^ number of rounds + -> Int -- ^ desired length of output + -> HashString +pbkdf2 password0 salt rounds len = out + where + password = hmacKeyHashed password0 + saltCtx = + pbkdf2Ctx_init password & + pbkdf2Ctx_feed salt + gen index = + pbkdf2Ctx_finalize index saltCtx & + pbkdf2Gen_iterate ((max rounds 1) - 1) & + pbkdf2Gen_finalize + out = mconcat (takeHS len (map gen [1..maxBound])) + +pbkdf2_index + :: ByteString -- ^ nominally the "password" + -> ByteString -- ^ nominally the "salt" + -> Word32 -- ^ the "index", returns the i-th block of output. The first index is 1, thus the result consists of bytes starting at 32*(i-1) and ending before 32*i. This is appended as 4 more bytes after the salt. + -> Word64 -- ^ number of rounds + -> HashString -- ^ 32-byte output" +pbkdf2_index password0 salt index rounds = out + where + password = hmacKeyHashed password0 + saltCtx = + pbkdf2Ctx_init password & + pbkdf2Ctx_feed salt + out = + pbkdf2Ctx_finalize index saltCtx & + pbkdf2Gen_iterate ((max rounds 1) - 1) & + pbkdf2Gen_finalize + +pbkdf2Ctx_init :: HmacKeyHashed -> Pbkdf2Ctx +pbkdf2Ctx_init password = Pbkdf2Ctx + { pbkdf2Ctx_password = password + , pbkdf2Ctx_ipadCtx = hmacKeyHashed_ipadCtx password + } + +-- | Append some bytes to the end of the salt. Flipped version of 'pbkdf2Ctx_feed'. + +pbkdf2Ctx_update :: Pbkdf2Ctx -> ByteString -> Pbkdf2Ctx +pbkdf2Ctx_update ctx bs = ctx { pbkdf2Ctx_ipadCtx = sha256_update (pbkdf2Ctx_ipadCtx ctx) bs } + +-- | Append zero or more bytestrings to the end of the salt. Flipped version of 'pbkdf2Ctx_feeds' + +pbkdf2Ctx_updates :: Foldable f => Pbkdf2Ctx -> f ByteString -> Pbkdf2Ctx +pbkdf2Ctx_updates ctx bs = ctx { pbkdf2Ctx_ipadCtx = sha256_updates (pbkdf2Ctx_ipadCtx ctx) bs } + +-- | Append some bytes to the end of the salt. Flipped version of 'pbkdf2Ctx_update'. + +pbkdf2Ctx_feed :: ByteString -> Pbkdf2Ctx -> Pbkdf2Ctx +pbkdf2Ctx_feed = flip pbkdf2Ctx_update + +-- | Append zero or more bytestrings to the end of the salt. Flipped version of 'pbkdf2Ctx_updates'. + +pbkdf2Ctx_feeds :: Foldable f => f ByteString -> Pbkdf2Ctx -> Pbkdf2Ctx +pbkdf2Ctx_feeds = flip pbkdf2Ctx_updates + +-- | Append the index to the end of the salt, and then initialize a 'Pbkdf2Gen' with +-- one round applied. + +pbkdf2Ctx_finalize + :: Word32 -- ^ index of output block + -> Pbkdf2Ctx + -> Pbkdf2Gen +pbkdf2Ctx_finalize index ctx = Pbkdf2Gen + { pbkdf2Gen_password = password + , pbkdf2Gen_finalize = state + , pbkdf2Gen_state = state + } + where + password = pbkdf2Ctx_password ctx + ipad = pbkdf2Ctx_ipadCtx ctx & + sha256_finalizeBytes_toByteString (NB.bytestring32 index) + state = hmacKeyHashed_opadCtx password & + sha256_finalizeBytes ipad + +-- | Apply zero or more rounds to a pbkdf2 computation. + +pbkdf2Gen_iterate + :: Word64 -- ^ number of key-stretching rounds to perform + -> Pbkdf2Gen + -> Pbkdf2Gen +pbkdf2Gen_iterate n0 ctx = go n0 xorSum0 state0 + where + password = pbkdf2Gen_password ctx + xorSum0 = pbkdf2Gen_finalize ctx + state0 = pbkdf2Gen_state ctx + go n xorSum state + | n <= 0 = + Pbkdf2Gen + { pbkdf2Gen_password = password + , pbkdf2Gen_finalize = xorSum + , pbkdf2Gen_state = state + } + | otherwise = + let !state' = hmacKeyHashed_run password & + hmacCtx_finalizeBytes (HS.toByteString state) + !xorSum' = HS.xorLeft state' xorSum + in go (n-1) xorSum' state' diff --git a/lib/Crypto/Sha256/Pbkdf2/Subtle.hs b/lib/Crypto/Sha256/Pbkdf2/Subtle.hs new file mode 100644 --- /dev/null +++ b/lib/Crypto/Sha256/Pbkdf2/Subtle.hs @@ -0,0 +1,24 @@ +------------------------------------------------------------------------------- +-- | +-- Module: Crypto.Sha256.Pbkdf2.Subtle +-- Copyright: (c) 2024 Auth Global +-- License: Apache2 +-- +------------------------------------------------------------------------------- + +module Crypto.Sha256.Pbkdf2.Subtle where + +import Crypto.HashString +import Crypto.Sha256 +import Crypto.Sha256.Hmac + +data Pbkdf2Ctx = Pbkdf2Ctx + { pbkdf2Ctx_password :: !HmacKeyHashed + , pbkdf2Ctx_ipadCtx :: !Sha256Ctx + } + +data Pbkdf2Gen = Pbkdf2Gen + { pbkdf2Gen_password :: !HmacKeyHashed + , pbkdf2Gen_finalize :: !HashString + , pbkdf2Gen_state :: !HashString + } diff --git a/lib/Crypto/Sha256/Subtle.hs b/lib/Crypto/Sha256/Subtle.hs new file mode 100644 --- /dev/null +++ b/lib/Crypto/Sha256/Subtle.hs @@ -0,0 +1,231 @@ +{-# LANGUAGE MagicHash, UnboxedTuples, CApiFFI, UnliftedFFITypes, BangPatterns #-} + +------------------------------------------------------------------------------- +-- | +-- Module: Crypto.Sha256.Subtle +-- Copyright: (c) 2024 Auth Global +-- License: Apache2 +-- +------------------------------------------------------------------------------- + +module Crypto.Sha256.Subtle where + +import Data.Array.Byte +import Data.Bits((.&.)) +import Data.ByteString (ByteString) +import qualified Data.ByteString as B +import Data.ByteString.Unsafe(unsafeUseAsCStringLen) +import Data.Word +import Foreign.C +import Foreign.Ptr +import GHC.Exts +import GHC.IO + +import Crypto.HashString +import Crypto.HashString.FFI(HashString(..)) + +nullBuffer :: ByteString +nullBuffer = B.replicate 64 0 + +type MutableSha256State# = MutableByteArray# + +type Sha256State# = ByteArray# + +type MutableSha256Ctx# = MutableByteArray# + +type Sha256Ctx# = ByteArray# + +newtype Sha256State = Sha256State { unSha256State :: ByteArray } + +instance Eq Sha256State where + x == y = compare x y == EQ + +instance Ord Sha256State where + compare (Sha256State (ByteArray x)) (Sha256State (ByteArray y)) = + compare (c_const_memcmp_uint32be x y 8) 0 + +newtype Sha256Ctx = Sha256Ctx { unSha256Ctx :: ByteArray } + +instance Eq Sha256Ctx where + x == y = compare x y == EQ + +instance Ord Sha256Ctx where + compare (Sha256Ctx (ByteArray x)) (Sha256Ctx (ByteArray y)) = + compare (c_const_memcmp_ctx x y) 0 + +sha256state_init :: Sha256State +sha256state_init = + unsafePerformIO . IO $ \st -> + let !(Ptr addr) = c_sha256_init + !(# st0, a #) = newByteArray# 32# st + st1 = copyAddrToByteArray# addr a 0# 32# st0 + -- FIXME? Review this to ensure that 32# is the correct input above + -- Problem is the documentation is ambiguous, and the source is magic. + -- I'm assuming copyAddrToByteArray# works similarly as copyByteArray#. + !(# st2, b #) = unsafeFreezeByteArray# a st1 + in (# st2, (Sha256State (ByteArray b)) #) + +-- | Note that this function only processes as many 64-byte blocks as possible, +-- then discards the remainder of the input. Also note that this function does +-- nothing to track the number of bytes that have been fed into the state, which +-- will have to be done externally. + +sha256state_feed :: ByteString -> Sha256State -> Sha256State +sha256state_feed bytes (Sha256State (ByteArray p)) = + unsafePerformIO . unsafeUseAsCStringLen bytes $ \(bp, bl) -> IO $ \st -> + let !(# st0, a #) = newByteArray# 32# st + !(# st1, _ #) = unIO (c_sha256_update p bp (fromIntegral bl) a) st0 + !(# st2, b #) = unsafeFreezeByteArray# a st1 + in (# st2, Sha256State (ByteArray b) #) + +-- | Cast a Sha256Ctx to a Sha256State, without (much, if any) copying. +-- This has the disadvantage that the result will retain at least 8, and up to +-- 71 unnecessary bytes, depending on the length of the buffer. 72 extra bytes +-- will likely be possible once this binding supports mutable contexts and +-- supports freezing mutable contexts into immutable contexts without copying. + +sha256state_fromCtxInplace :: Sha256Ctx -> Sha256State +sha256state_fromCtxInplace (Sha256Ctx a) = Sha256State a + +-- | Cast a Sha256Ctx to a Sha256State. This copies the first 32 bytes of the +-- Sha256Ctx structure, so the result is always as small as possible. + +sha256state_fromCtx :: Sha256Ctx -> Sha256State +sha256state_fromCtx (Sha256Ctx (ByteArray ctx)) = + unsafePerformIO . IO $ \st -> + let !(# st0, a #) = newByteArray# 32# st + st1 = copyByteArray# ctx 0# a 0# 32# st0 + !(# st2, b #) = unsafeFreezeByteArray# a st1 + in (# st2, Sha256State (ByteArray b) #) + +sha256state_runWith :: Word64 -> ByteString -> Sha256State -> Sha256Ctx +sha256state_runWith blocks bytes (Sha256State (ByteArray p)) = + unsafePerformIO . unsafeUseAsCStringLen bytes $ \(bp, bl) -> IO $ \st -> + let !(# st0, a #) = newByteArray# ctxLen# st + !(# st1, () #) = unIO (c_sha256_promote_to_ctx p blocks bp (fromIntegral bl) a) st0 + !(# st2, b #) = unsafeFreezeByteArray# a st1 + in (# st2, Sha256Ctx (ByteArray b) #) + where + !(I# ctxLen#) = 40 + B.length bytes .&. 0x3F + +sha256state_encode :: Sha256State -> HashString +sha256state_encode (Sha256State (ByteArray x)) = + unsafePerformIO . IO $ \st -> + let !(# st0, a #) = newByteArray# 32# st + !(# st1, () #) = unIO (c_sha256_encode_state x a) st0 + !(# st2, b #) = unsafeFreezeByteArray# a st1 + in (# st2, HashString (ByteArray b) #) + +sha256state_decode :: HashString -> Sha256State +sha256state_decode (HashString (ByteArray x)) = + unsafePerformIO . IO $ \st -> + let !(# st0, a #) = newByteArray# 32# st + !(# st1, () #) = unIO (c_sha256_decode_state x a) st0 + !(# st2, b #) = unsafeFreezeByteArray# a st1 + in (# st2, Sha256State (ByteArray b) #) + +-- these calls must be labelled "unsafe", because the datastructures +-- we will be passing in are unpinned... keep that in mind when selecting +-- the size of the updates. (Also, maybe in some cases a different FFI +-- layer that uses safe calls would be desirable? Maybe not... It seems like +-- it should be possible to adequately work around the limitations of +-- long-lived unsafe calls by using smaller updates, making more calls to C.) + +-- See the documentation for details: +-- https://ghc.gitlab.haskell.org/ghc/doc/users_guide/exts/ffi.html#guaranteed-call-safety + +-- TODO: some functions have more than one binding, mostly for type reasons, and there +-- are several more variants of some of these bindings this module should support. + +foreign import ccall unsafe "hs_sha256.h &hs_sha256_init" + c_sha256_init :: Ptr Word32 + +foreign import capi unsafe "hs_sha256.h hs_sha256_init_ctx" + c_sha256_init_ctx :: MutableSha256Ctx# RealWorld -> IO () + +foreign import capi unsafe "hs_sha256.h hs_sha256_promote_to_ctx" + c_sha256_promote_to_ctx + :: Sha256State# -- ^ @state@, a pointer to an constant array of eight Word32 + -> Word64 -- ^ @blockCount@, the number of blocks that a sha256 context has processed + -> CString -- ^ pointer to the constant data to process + -> CSize -- ^ length of the data to process + -> MutableSha256Ctx# RealWorld -- ^ output pointer + -> IO () + +foreign import capi unsafe "hs_sha256.h hs_sha256_update" + c_sha256_update + :: Sha256State# -- ^ @state@, a pointer to an constant array of eight Word32 + -> CString -- ^ pointer to the constant data to process + -> CSize -- ^ length of the data to process + -> MutableSha256State# RealWorld -- ^ output pointer + -> IO Word64 -- ^ the new @count@ + +foreign import capi unsafe "hs_sha256.h hs_sha256_update_ctx" + c_sha256_update_ctx + :: Sha256Ctx# -- ^ @ctx@, a pointer to a constant sha256 context + -> CString -- ^ pointer to the constant data to process + -> CSize -- ^ length of the data to process + -> MutableSha256Ctx# RealWorld -- ^ output pointer + -> IO () + +foreign import capi unsafe "hs_sha256.h hs_sha256_update_ctx" + c_sha256_mutate_ctx + :: MutableSha256Ctx# RealWorld -- ^ @ctx@, a pointer to a constant sha256 context + -> CString -- ^ pointer to the constant data to process + -> CSize -- ^ length of the data to process + -> MutableSha256Ctx# RealWorld -- ^ output pointer, can be same as the input context + -> IO () + +foreign import capi unsafe "hs_sha256.h hs_sha256_get_count" + c_sha256_get_count + :: Sha256State# + -> Word64 + +foreign import capi unsafe "hs_sha256.h hs_sha256_finalize_ctx_bits" + c_sha256_finalize_ctx_bits + :: Sha256Ctx# + -> CString + -> Word64 + -> Ptr Word8 + -> IO () + +foreign import capi unsafe "hs_sha256.h hs_sha256_finalize_ctx_bits" + c_sha256_finalize_ctx_bits_ba + :: Sha256Ctx# + -> CString + -> Word64 + -> MutableByteArray# RealWorld + -> IO () + +foreign import capi unsafe "hs_sha256.h hs_sha256_finalize_ctx_bits" + c_sha256_finalize_mutable_ctx_bits + :: MutableSha256Ctx# RealWorld + -> CString + -> Word64 + -> CString + -> IO () + +foreign import capi unsafe "hs_sha256.h hs_sha256_encode_state" + c_sha256_encode_state + :: Sha256State# + -> MutableByteArray# RealWorld + -> IO () + +foreign import capi unsafe "hs_sha256.h hs_sha256_decode_state" + c_sha256_decode_state + :: ByteArray# + -> MutableSha256State# RealWorld + -> IO () + +foreign import capi unsafe "hs_sha256.h hs_sha256_const_memcmp_uint32be" + c_const_memcmp_uint32be + :: ByteArray# + -> ByteArray# + -> Word32 + -> CInt + +foreign import capi unsafe "hs_sha256.h hs_sha256_const_memcmp_ctx" + c_const_memcmp_ctx + :: ByteArray# + -> ByteArray# + -> CInt diff --git a/sha256.cabal b/sha256.cabal new file mode 100644 --- /dev/null +++ b/sha256.cabal @@ -0,0 +1,65 @@ +name: sha256 +version: 0.1.0.0 +synopsis: + A modern binding to SHA256, HMAC, HKDF, and PBKDF2 +description: + A modern binding to SHA256, HMAC, HKDF, and PBKDF2 supporting precomputed + HMAC keys, streaming, backtracking, bitstring inputs, and (de)serialization + of intermediate states. Both HKDF and PBKDF2 reuse HMAC key computations + for efficiency. +license: Apache-2.0 +license-file: LICENSE +author: Vincent Hanquez, Herbert Valerio Riedel, Leon P Smith +maintainer: Auth Global +copyright: 2006 Vincent Hanquez, 2016 Herbert Valerio Riedel, 2024 Auth Global +category: Graphics +build-type: Simple +extra-source-files: CHANGELOG.md +cabal-version: >=1.10 + +library + exposed-modules: + Crypto.Sha256 + Crypto.Sha256.Subtle + Crypto.Sha256.Hmac + Crypto.Sha256.Hmac.Subtle + Crypto.Sha256.Hkdf + Crypto.Sha256.Hkdf.Subtle + Crypto.Sha256.Pbkdf2 + Crypto.Sha256.Pbkdf2.Subtle + -- Crypto.Sha256.ST + -- Crypto.Sha256.ST.Subtle + + other-modules: + Crypto.Sha256.Hmac.Implementation + + build-depends: base < 5 + , bytestring + , hash-string + , network-byte-order + , ghc-prim + + hs-source-dirs: lib + include-dirs: csrc + default-language: Haskell2010 + ghc-options: -Wall + cc-options: -Wall + install-includes: csrc/hs_sha256.h + c-sources: csrc/hs_sha256.c + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + + other-modules: HMAC, + HKDF, + PBKDF2 + build-depends: base + , base16 + , bytestring + , hash-string + , sha256 + , tasty + , tasty-hunit + default-language: Haskell2010 diff --git a/test/HKDF.hs b/test/HKDF.hs new file mode 100644 --- /dev/null +++ b/test/HKDF.hs @@ -0,0 +1,67 @@ +-- Test Vectors for HKDF-SHA256 + +{-# LANGUAGE OverloadedStrings #-} + +module HKDF where + +import Data.Base16.Types +import Data.ByteString(ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as B +import qualified Data.ByteString.Short as SB +import Data.Function((&)) +import Data.Int +import Test.Tasty +import Test.Tasty.HUnit + +import Crypto.HashString (HashString(..)) +import qualified Crypto.HashString as HS +import Crypto.Sha256.Hkdf + +d :: ByteString -> ByteString +d = B.decodeBase16Lenient + +tests :: [TestTree] +tests = + [ testGroup "rfc5869 test vectors" + [ testCase ("rfc5869-" ++ show n) (run x) + | (n,x) <- zip [1..] testVectors + ] + ] + where + run x = HS.toBase16 (hkdf' (salt x) (ikm x) (info x) (B.length (out x))) @?= extractBase16 (B.encodeBase16' (out x)) + +testVectors :: [TestVector] +testVectors = + [ rfc5869_testCase1 + , rfc5869_testCase2 + , rfc5869_testCase3 + ] + +data TestVector = TestVector + { salt :: !ByteString + , ikm :: !ByteString + , info :: !ByteString + , out :: !ByteString + } + +rfc5869_testCase1 = TestVector + { salt = d "000102030405060708090a0b0c" + , ikm = d "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b" + , info = d "f0f1f2f3f4f5f6f7f8f9" + , out = d "3cb25f25faacd57a90434f64d0362f2a2d2d0a90cf1a5a4c5db02d56ecc4c5bf34007208d5b887185865" + } + +rfc5869_testCase2 = TestVector + { salt = d "606162636465666768696a6b6c6d6e6f707172737475767778797a7b7c7d7e7f808182838485868788898a8b8c8d8e8f909192939495969798999a9b9c9d9e9fa0a1a2a3a4a5a6a7a8a9aaabacadaeaf" + , ikm = d "000102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f202122232425262728292a2b2c2d2e2f303132333435363738393a3b3c3d3e3f404142434445464748494a4b4c4d4e4f" + , info = d "b0b1b2b3b4b5b6b7b8b9babbbcbdbebfc0c1c2c3c4c5c6c7c8c9cacbcccdcecfd0d1d2d3d4d5d6d7d8d9dadbdcdddedfe0e1e2e3e4e5e6e7e8e9eaebecedeeeff0f1f2f3f4f5f6f7f8f9fafbfcfdfeff" + , out = d "b11e398dc80327a1c8e7f78c596a49344f012eda2d4efad8a050cc4c19afa97c59045a99cac7827271cb41c65e590e09da3275600c2f09b8367793a9aca3db71cc30c58179ec3e87c14c01d5c1f3434f1d87" + } + +rfc5869_testCase3 = TestVector + { salt = "" + , ikm = d "0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b0b" + , info = "" + , out = d "8da4e775a563c18f715f802a063c5a31b8a11f5c5ee1879ec3454e5f3c738d2d9d201395faa4b61a96c8" + } diff --git a/test/HMAC.hs b/test/HMAC.hs new file mode 100644 --- /dev/null +++ b/test/HMAC.hs @@ -0,0 +1,97 @@ +-- Test Vectors for HMAC-SHA256 + +{-# LANGUAGE OverloadedStrings #-} + +module HMAC where + +import Data.ByteString(ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as B +import Data.Function((&)) +import Test.Tasty +import Test.Tasty.HUnit + +import Crypto.Sha256.Hmac + +d :: ByteString -> ByteString +d = B.decodeBase16Lenient + +tests :: [TestTree] +tests = + [ testGroup "rfc4231 test vectors" + [ testCase ("rfc4231-" ++ show n) (run x) + | (n,x) <- zip [1..] testVectors + ] + ] + where + run x = B.encodeBase16 (hmac (key x) (msg x)) @?= B.encodeBase16 (out x) + +testVectors :: [TestVector] +testVectors = + [ rfc4231_testCase1 + , rfc4231_testCase2 + , rfc4231_testCase3 + , rfc4231_testCase4 + , rfc4231_testCase5 + , rfc4231_testCase6 + , rfc4231_testCase7 + ] + +data TestVector = TestVector + { key :: !ByteString + , msg :: !ByteString + , out :: !ByteString + } + +rfc4231_testCase1 = TestVector + { key = B.replicate 20 0x0b + , msg = "Hi There" + , out = d "b0344c61d8db38535ca8afceaf0bf12b881dc200c9833da726e9376c2e32cff7" + } + +rfc4231_testCase2 = TestVector + { key = "Jefe" + , msg = "what do ya want for nothing?" + , out = d "5bdcc146bf60754e6a042426089575c75a003f089d2739839dec58b964ec3843" + } + +rfc4231_testCase3 = TestVector + { key = B.replicate 20 0xaa + , msg = B.replicate 50 0xdd + , out = d "773ea91e36800e46854db8ebd09181a72959098b3ef8c122d9635514ced565fe" + } + +rfc4231_testCase4 = TestVector + { key = d "0102030405060708090a0b0c0d0e0f10111213141516171819" + , msg = B.replicate 50 0xcd + , out = d "82558a389a443c0ea4cc819899f2083a85f0faa3e578f8077a2e3ff46729665b" + } + +{- + +RFC4231 doesn't provide the second half of the output. This seem odd. +Unlike HKDF, truncation is not explicitly part of the HMAC interface. +Is this test vector supposed teach that this is a safe way to use HMAC? + +To avoid unnecessary complications here, I just provided the (unofficial) +second half of the output. + +-} + +rfc4231_testCase5 = TestVector + { key = B.replicate 20 0x0c + , msg = "Test With Truncation" + , out = d "a3b6167473100ee06e0c796c2955552bfa6f7c0a6a8aef8b93f860aab0cd20c5" + } + +rfc4231_testCase6 = TestVector + { key = B.replicate 131 0xaa + , msg = "Test Using Larger Than Block-Size Key - Hash Key First" + , out = d "60e431591ee0b67f0d8a26aacbf5b77f8e0bc6213728c5140546040f0ee37f54" + } + +rfc4231_testCase7 = TestVector + { key = B.replicate 131 0xaa + , msg = "This is a test using a larger than block-size key and a larger than block-size data. The key needs to be hashed before being used by the HMAC algorithm." + , out = d "9b09ffa71b942fcb27635fbcd5b0e944bfdc63644f0713938a7f51535c3a35e2" + } diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} +import Data.ByteString(ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as B +import Data.Function((&)) +import Data.Word +import Test.Tasty +import Test.Tasty.HUnit + +import Crypto.Sha256 +import Crypto.Sha256.Hmac +import Crypto.Sha256.Hkdf +import qualified HMAC +import qualified HKDF +import qualified PBKDF2 + +d :: ByteString -> ByteString +d = B.decodeBase16Lenient + +main = do + defaultMain $ testGroup "toplevel" [ + testGroup "sha256" + [ testCase ("sha256-" ++ show n) (run x) + | (n,x) <- zip [1..] testVectors + ], + testGroup "hmac" HMAC.tests, + testGroup "hkdf" HKDF.tests, + testGroup "pbkdf2" PBKDF2.tests, + testGroup "bitstrings" testBitstrings + ] + where + run :: SHA256TestVector -> Assertion + run x = B.encodeBase16 (hash (msg x)) @?= B.encodeBase16 (out x) + +data SHA256TestVector = SHA256TestVector + { msg :: !ByteString + , out :: !ByteString + } + +testVectors :: [SHA256TestVector] +testVectors = + [ sha256_testCase1 + , sha256_testCase2 + , sha256_testCase3 + , sha256_testCase4 + , sha256_testCase5 + , sha256_testCase6 + ] + +sha256_testCase1 = SHA256TestVector + { msg = "abc" + , out = d "ba7816bf8f01cfea414140de5dae2223b00361a396177a9cb410ff61f20015ad" + } + +sha256_testCase2 = SHA256TestVector + { msg = "" + , out = d "e3b0c44298fc1c149afbf4c8996fb92427ae41e4649b934ca495991b7852b855" + } + +sha256_testCase3 = SHA256TestVector + { msg = "abcdbcdecdefdefgefghfghighijhijkijkljklmklmnlmnomnopnopq" + , out = d "248d6a61d20638b8e5c026930c3e6039a33ce45964ff2167f6ecedd419db06c1" + } + +sha256_testCase4 = SHA256TestVector + { msg = "abcdefghbcdefghicdefghijdefghijkefghijklfghijklmghijklmnhijklmnoijklmnopjklmnopqklmnopqrlmnopqrsmnopqrstnopqrstu" + , out = d "cf5b16a778af8380036ce59e7b0492370b249b11e8f07a51afac45037afee9d1" + } + +sha256_testCase5 = SHA256TestVector + { msg = "0123456789ABCDEF0123456789abcdef0123456789ABCDEF0123456789abcde" + , out = d "a518fbe53475606f8cdf66dfeae0c416f774694843647c810c6f89fd7d24ae4c" + } + +sha256_testCase6 = SHA256TestVector + { msg = "0123456789ABCDEF0123456789abcdef0123456789ABCDEF0123456789abcdef" + , out = d "37e68bd16eb5be2f6d591cef9c099db166faf048122f736307fb92a1670ef552" + } + +testBitstrings :: [TestTree] +testBitstrings = [testCase "bitstrings-0" (out @?= "731590e201d1e0c020e78c6d8dbacf6e1e7ab8eae42de9e5dc370d96270f1c32")] + where + bitstring :: ByteString + bitstring = hkdf (d "0102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f202122232425262728292a2b2c2d2e2f303132333435363738393a3b3c3d3e3f4041") "" "" 128 + myKey = hmacKey (d "0102030405060708090a0b0c0d0e0f101112131415161718191a1b1c1d1e1f202122232425262728292a2b2c2d2e2f303132333435363738393a3b3c3d3e3f40") + sha256bits :: ByteString -> Word64 -> ByteString + sha256bits x len = sha256_init & + sha256_finalizeBits_toByteString x len + hmacbits :: ByteString -> Word64 -> ByteString + hmacbits x len = hmacCtx_init myKey & + hmacCtx_finalizeBits_toByteString x len + out = sha256_init & + sha256_feeds [ sha256bits bitstring n | n <- [0..1024] ] & + sha256_feeds [ hmacbits bitstring n | n <- [0..1024] ] & + sha256_finalize diff --git a/test/PBKDF2.hs b/test/PBKDF2.hs new file mode 100644 --- /dev/null +++ b/test/PBKDF2.hs @@ -0,0 +1,113 @@ +-- Test Vectors for PBKDF2-HMAC-SHA256 + +{-# LANGUAGE OverloadedStrings #-} + +module PBKDF2 where + +import Data.Base16.Types +import Data.ByteString(ByteString) +import qualified Data.ByteString as B +import qualified Data.ByteString.Base16 as B +import qualified Data.ByteString.Short as SB +import Data.Function((&)) +import Data.Int +import Data.Word +import Test.Tasty +import Test.Tasty.HUnit + +import Crypto.HashString (HashString(..)) +import qualified Crypto.HashString as HS +import Crypto.Sha256.Pbkdf2 + +d :: ByteString -> ByteString +d = B.decodeBase16Lenient + +tests :: [TestTree] +tests = + [ testGroup "test vectors" + [ testCase (show n) (run x) + | (n,x) <- zip ([1..3]++[5..]) testVectors + ] + ] + where + run x = HS.toBase16 (pbkdf2 (password x) (salt x) (rounds x) (B.length (out x))) @?= extractBase16 (B.encodeBase16' (out x)) + +testVectors :: [TestVector] +testVectors = + [ testCase1 + , testCase2 + , testCase3 + , testCase5 + , testCase6 + , testCase7 + , testCase8 + , testCase9 + ] + +data TestVector = TestVector + { password :: !ByteString + , salt :: !ByteString + , rounds :: !Word64 + , out :: !ByteString + } + +-- Borrowed from: +-- https://github.com/brycx/Test-Vector-Generation/blob/72810c03e22af1b26fe5b254340e9ae5d9e44b06/PBKDF2/pbkdf2-hmac-sha2-test-vectors.md + +-- FIXME: the code coverage of these test vectors leaves much to be desired. + +testCase1 = TestVector + { password = "password" + , salt = "salt" + , rounds = 1 + , out = d "120fb6cffcf8b32c43e7225256c4f837a86548c9" + } + +testCase2 = TestVector + { password = "password" + , salt = "salt" + , rounds = 2 + , out = d "ae4d0c95af6b46d32d0adff928f06dd02a303f8e" + } + +testCase3 = TestVector + { password = "password" + , salt = "salt" + , rounds = 4096 + , out = d "c5e478d59288c841aa530db6845c4c8d962893a0" + } + +testCase5 = TestVector + { password = "passwordPASSWORDpassword" + , salt = "saltSALTsaltSALTsaltSALTsaltSALTsalt" + , rounds = 4096 + , out = d "348c89dbcbd32b2f32d814b8116e84cf2b17347ebc1800181c" + } + +testCase6 = TestVector + { password = "pass\x00word" + , salt = "sa\x00lt" + , rounds = 4096 + , out = d "89b69d0516f829893c696226650a8687" + } + +testCase7 = TestVector + { password = "passwd" + , salt = "salt" + , rounds = 1 + , out = d "55ac046e56e3089fec1691c22544b605f94185216dde0465e68b9d57c20dacbc49ca9cccf179b645991664b39d77ef317c71b845b1e30bd509112041d3a19783c294e850150390e1160c34d62e9665d659ae49d314510fc98274cc79681968104b8f89237e69b2d549111868658be62f59bd715cac44a1147ed5317c9bae6b2a" + } + +testCase8 = TestVector + { password = "Password" + , salt = "NaCl" + , rounds = 80000 + , out = d "4ddcd8f60b98be21830cee5ef22701f9641a4418d04c0414aeff08876b34ab56a1d425a1225833549adb841b51c9b3176a272bdebba1d078478f62b397f33c8d62aae85a11cdde829d89cb6ffd1ab0e63a981f8747d2f2f9fe5874165c83c168d2eed1d2d5ca4052dec2be5715623da019b8c0ec87dc36aa751c38f9893d15c3" + } + +testCase9 = TestVector + { password = "Password" + , salt = "sa\x00lt" + , rounds = 4096 + , out = d "436c82c6af9010bb0fdb274791934ac7dee21745dd11fb57bb90112ab187c495ad82df776ad7cefb606f34fedca59baa5922a57f3e91bc0e11960da7ec87ed0471b456a0808b60dff757b7d313d4068bf8d337a99caede24f3248f87d1bf16892b70b076a07dd163a8a09db788ae34300ff2f2d0a92c9e678186183622a636f4cbce15680dfea46f6d224e51c299d4946aa2471133a649288eef3e4227b609cf203dba65e9fa69e63d35b6ff435ff51664cbd6773d72ebc341d239f0084b004388d6afa504eee6719a7ae1bb9daf6b7628d851fab335f1d13948e8ee6f7ab033a32df447f8d0950809a70066605d6960847ed436fa52cdfbcf261b44d2a87061" + }