From 1ffb694513f33ba043d93bae87ee71b026ccb62f Mon Sep 17 00:00:00 2001 From: curiecrypt <36852463+curiecrypt@users.noreply.github.com> Date: Thu, 4 May 2023 19:41:25 +0300 Subject: [PATCH 01/75] bls test vectors (#397) Include rust script to generate test vectors of the BLS12-381 curve using zkcrypto's implementation of BLS12-381. The generated test vectors themselves are also included as part of cardano-base. Co-authored-by: iquerejeta --- .../bls12-381-test-vectors/Cargo.toml | 13 + .../bls12-381-test-vectors/README.md | 108 ++++++++ .../bls12-381-test-vectors/src/main.rs | 259 ++++++++++++++++++ .../test_vectors/bls_sig_aug_test_vectors | 2 + .../test_vectors/ec_operations_test_vectors | 12 + .../test_vectors/pairing_test_vectors | 8 + .../test_vectors/serde_test_vectors | 7 + 7 files changed, 409 insertions(+) create mode 100644 cardano-crypto-tests/bls12-381-test-vectors/Cargo.toml create mode 100644 cardano-crypto-tests/bls12-381-test-vectors/README.md create mode 100644 cardano-crypto-tests/bls12-381-test-vectors/src/main.rs create mode 100644 cardano-crypto-tests/bls12-381-test-vectors/test_vectors/bls_sig_aug_test_vectors create mode 100644 cardano-crypto-tests/bls12-381-test-vectors/test_vectors/ec_operations_test_vectors create mode 100644 cardano-crypto-tests/bls12-381-test-vectors/test_vectors/pairing_test_vectors create mode 100644 cardano-crypto-tests/bls12-381-test-vectors/test_vectors/serde_test_vectors diff --git a/cardano-crypto-tests/bls12-381-test-vectors/Cargo.toml b/cardano-crypto-tests/bls12-381-test-vectors/Cargo.toml new file mode 100644 index 000000000..ac9139a73 --- /dev/null +++ b/cardano-crypto-tests/bls12-381-test-vectors/Cargo.toml @@ -0,0 +1,13 @@ +[package] +name = "bls12-381-test-vectors" +version = "0.1.0" +edition = "2021" + +[dependencies] +bls12_381 = { version = "0.8.0", features = ["default", "experimental"] } +rand_chacha = "0.3.1" +ff = "0.13.0" +group = "0.13.0" +hex = "0.4.3" +blst = "0.3.10" +sha2 = "0.9" diff --git a/cardano-crypto-tests/bls12-381-test-vectors/README.md b/cardano-crypto-tests/bls12-381-test-vectors/README.md new file mode 100644 index 000000000..da64b6bc6 --- /dev/null +++ b/cardano-crypto-tests/bls12-381-test-vectors/README.md @@ -0,0 +1,108 @@ +## Test vectors for BLS +This is a rust script to generate test vectors for the following: +- Using [bls12_381](https://github.com/zkcrypto/bls12_381) + - Pairing properties + - Elliptic curve operations + - Deserialization/decompression + - BLS signature with `aug` and `dst`. + +The results are in hex encoding and stored under the folder `test_vectors`. + +### 1- Test vectors for pairing properties +The properties to be tested: +- `e([a]P, Q) = e(P, [a]Q)` +- `e([a]P, [b]Q) = e([b]P, [a]Q)` +- `e([a]P, [b]Q) = e([a * b]P, Q)` +- `e([a]P, Q) * e([b]P, Q) = e([a + b]P, Q)` +- `e([a]P, [b]Q) = e(P, [a * b]Q)` +- `e(P, [a]Q) * e(P, [b]Q) = e(P, [a + b]Q)` + +The values used to generate test vectors: +``` +P = 840463aa2f2cda89985b1f3f5eb43b9c29809765d2747d60734b19d6f90610effdfc500af7d458a3e78cee0945ddc669 // G1 point +Q = b67029fbf3ab8e62ab6b499f541537fc07d9466e668392df2bc19762d7dc48b64be09a448cd46dbfe21819a91cd0ab3205f1316ad1cc32853f3f1a1d06497f5cfbc2d753dfc01bff177adeb93f24d452045435dc6eb29f5610b66cd0dd3fb352 // G2 point +a = 0x0e51216fa879b2ce727b596d065dd9b7fd8a84d94ffacf9ca30ad114304272d3 // scalar +b = 0x437c2d7d852637c2ef23645a5abcbb308d6150bfcccbf3a8fdbc9daaa91496ef // scalar +aplusb = 0x51cd4eed2d9fea91619ebdc7611a94e88aebd5991cc6c345a0c76ebed95709c2 // scalar +atimesb = 0x2d70bbc706812d56e805ae67934b3275ff67f304a76ea9b3c96d31b9c0d607ba // scalar +``` + +Order of the values printed on `pairing_test_vectors`: +- `[a]P` +- `[b]P` +- `[a + b]P` +- `[a * b]P` +- `[a]Q` +- `[b]Q` +- `[a + b]Q` +- `[a * b]Q` + + + +### 2- Test vectors for elliptic curve operations +Operations to be tested: +- Addition +- Subtraction +- Scalar multiplication +- Negation + +The scalar used in scalar multiplication: +``` +0x40df499974f62e2f268cd5096b0d952073900054122ffce0a27c9d96932891a5 +``` + +Order of the values printed on `ec_operations_test_vectors`: + +- `G1_P` - random point on `G_1` +- `G1_Q` - random point on `G_1` +- `G1_ADD = G1_P + G1_Q` +- `G1_SUB = G1_P - G1_Q` +- `G1_MULL = [scalar]G1_Q` +- `G1_NEG = -G1_P` +- `G2_P` - random point on `G_2` +- `G2_Q` - random point on `G_2` +- `G2_ADD = G2_P + G2_Q` +- `G2_SUB = G2_P - G2_Q` +- `G2_MULL = [scalar]G2_Q` +- `G2_NEG = -G2_P` + + +### 3- Test vectors for deserialization/decompression +- Point not in curve should fail deserialisation +- Point not in group should fail deserialisation +- Point not in curve should fail decompression +- Point not in group should fail decompression + +Order of the values printed on `serde_test_vectors`: +- `G1_uncomp_not_on_curve` +- `G1_comp_not_on_curve` +- `G1_comp_not_on_group` +- `G1_uncomp_not_on_group` +- `G2_uncomp_not_on_curve` +- `G2_comp_not_on_curve` +- `G2_comp_not_on_group` +- `G2_uncomp_not_on_group` + +### 4- BLS Signature +Test vectors for BLS signature, with successful validation using [blst](https://github.com/supranational/blst). + +The explicit usage of `aug` is not allowed in Cardano-base bindings. Therefore, before verification, they need to be appended into the message by following [hash-to-curve](https://datatracker.ietf.org/doc/html/draft-irtf-cfrg-hash-to-curve#name-expand_message) spec. + +`DST` and `msg` values used to generate test vectors: + +```rust +let dst = b"BLS_SIG_BLS12381G2_XMD:SHA-256_SSWU_RO_NUL_"; +let msg = b"blst is such a blast"; +let aug = b"Random value for test aug. "; +``` +Order of the values printed on the files `bls_sig_aug_test_vectors` (BLS signature with `aug`): + +- `sig` +- `pk` + +To validate these test vectors, one needs to proceed as follows: +``` +let hashed_msg = HashToG1Curve(aug || msg, dst); + +assert!(pairing(sig, G2Generator) == pairing(hashed_msg, pk)) +``` diff --git a/cardano-crypto-tests/bls12-381-test-vectors/src/main.rs b/cardano-crypto-tests/bls12-381-test-vectors/src/main.rs new file mode 100644 index 000000000..cbe70ef24 --- /dev/null +++ b/cardano-crypto-tests/bls12-381-test-vectors/src/main.rs @@ -0,0 +1,259 @@ +#![warn(missing_docs)] +#![doc = include_str!("../README.md")] +#![allow(non_snake_case)] + +use bls12_381::{G1Affine, G1Projective, G2Affine, G2Projective, Scalar}; +use blst::min_sig::*; +use blst::BLST_ERROR; +use ff::Field; +use group::{Curve, Group}; +use rand_chacha::rand_core::{RngCore, SeedableRng}; +use rand_chacha::ChaCha20Rng; +use std::fs::File; +use std::io::prelude::*; +use bls12_381::hash_to_curve::{ExpandMsgXmd, HashToCurve}; + +fn pairing_properties(mut rng: R) -> std::io::Result<()> { + let P = G1Projective::random(&mut rng); + let Q = G2Projective::random(&mut rng); + + let a = Scalar::random(&mut rng); + let b = Scalar::random(&mut rng); + let aplusb = a + b; + let atimesb = a * b; + + let aP = a * P; + let bQ = b * Q; + let bP = b * P; + let aQ = a * Q; + + let aplusbP = aplusb * P; + let atimesbP = atimesb * P; + let aplusbQ = aplusb * Q; + let atimesbQ = atimesb * Q; + + write_hex_to_file( + "././test_vectors/pairing_test_vectors", + &[ + [aP, bP, aplusbP, atimesbP].map(|a| hex::encode(G1Affine::from(a).to_compressed())), + [aQ, bQ, aplusbQ, atimesbQ].map(|a| hex::encode(G2Affine::from(a).to_compressed())), + ] + .concat(), + ) +} + +fn ec_operations(mut rng: R) -> std::io::Result<()> { + let scalar = Scalar::random(&mut rng); + + let G1_P = G1Projective::random(&mut rng); + let G1_Q = G1Projective::random(&mut rng); + let G1_ADD = G1_P + G1_Q; + let G1_SUB = G1_P - G1_Q; + let G1_MUL = scalar * G1_Q; + let G1_NEG = -G1_P; + + let G2_P = G2Projective::random(&mut rng); + let G2_Q = G2Projective::random(&mut rng); + let G2_ADD = G2_P + G2_Q; + let G2_SUB = G2_P + G2_Q; + let G2_MUL = scalar * G2_Q; + let G2_NEG = -G2_P; + + write_hex_to_file( + "././test_vectors/ec_operations_test_vectors", + &[ + [G1_P, G1_Q, G1_ADD, G1_SUB, G1_MUL, G1_NEG] + .map(|a| hex::encode(G1Affine::from(a).to_compressed())), + [G2_P, G2_Q, G2_ADD, G2_SUB, G2_MUL, G2_NEG] + .map(|a| hex::encode(G2Affine::from(a).to_compressed())), + ] + .concat(), + ) +} + +fn serde(mut rng: R) -> std::io::Result<()> { + // vector to store the hex strings of invalid points + let mut hex_strings = Vec::new(); + + //---- G1---- + let G1_P = G1Affine::from(G1Projective::random(&mut rng)); + let mut G1_bytes = G1_P.to_uncompressed(); + G1_bytes[4] ^= 1; + assert_eq!( + G1Affine::from_uncompressed(&G1_bytes).is_none().unwrap_u8(), + 1 + ); + + hex_strings.push(hex::encode(G1_bytes)); + + let mut G1_compressed = G1_P.to_compressed(); + G1_compressed[4] ^= 1; + assert_eq!( + G1Affine::from_compressed(&G1_compressed) + .is_none() + .unwrap_u8(), + 1 + ); + + hex_strings.push(hex::encode(G1_compressed)); + + let mut G1_random_bytes = [0u8; 48]; + + for _ in 0..10 { + rng.fill_bytes(&mut G1_random_bytes); + G1_random_bytes[0] |= 0b10000000; + G1_random_bytes[0] &= 0b10011111; + let G1_try_out_group = G1Affine::from_compressed_unchecked(&G1_random_bytes); + if G1_try_out_group.is_some().unwrap_u8() == 1 + && G1_try_out_group.unwrap().is_torsion_free().unwrap_u8() == 0 + { + assert_eq!( + G1Affine::from_compressed(&G1_random_bytes) + .is_none() + .unwrap_u8(), + 1 + ); + hex_strings.push(hex::encode(G1_random_bytes)); + break; + } + } + + for _ in 0..10 { + rng.fill_bytes(&mut G1_random_bytes); + G1_random_bytes[0] |= 0b10000000; + G1_random_bytes[0] &= 0b10011111; + let G1_try_out_group = G1Affine::from_compressed_unchecked(&G1_random_bytes); + if G1_try_out_group.is_some().unwrap_u8() == 1 + && G1_try_out_group.unwrap().is_torsion_free().unwrap_u8() == 0 + { + assert_eq!( + G1Affine::from_compressed(&G1_random_bytes) + .is_none() + .unwrap_u8(), + 1 + ); + + let G1_affine_pt = G1Affine::from_compressed_unchecked(&G1_random_bytes).unwrap(); + hex_strings.push(hex::encode(G1_affine_pt.to_uncompressed())); + break; + } + } + //----------------------------------------------------------- + + //---- G2---- + let G2_P = G2Affine::from(G2Projective::random(&mut rng)); + let mut G2_bytes = G2_P.to_uncompressed(); + G2_bytes[4] ^= 1; + assert_eq!( + G2Affine::from_uncompressed(&G2_bytes).is_none().unwrap_u8(), + 1 + ); + + hex_strings.push(hex::encode(G2_bytes)); + + let mut G2_compressed = G2_P.to_compressed(); + G2_compressed[4] ^= 1; + assert_eq!( + G2Affine::from_compressed(&G2_compressed) + .is_none() + .unwrap_u8(), + 1 + ); + + hex_strings.push(hex::encode(G2_compressed)); + + let mut G2_random_bytes = [0u8; 96]; + for _ in 0..10 { + rng.fill_bytes(&mut G2_random_bytes); + G2_random_bytes[0] |= 0b10000000; + G2_random_bytes[0] &= 0b10011111; + let G2_try_out_group = G2Affine::from_compressed_unchecked(&G2_random_bytes); + if G2_try_out_group.is_some().unwrap_u8() == 1 + && G2_try_out_group.unwrap().is_torsion_free().unwrap_u8() == 0 + { + assert_eq!( + G2Affine::from_compressed(&G2_random_bytes) + .is_none() + .unwrap_u8(), + 1 + ); + hex_strings.push(hex::encode(G2_random_bytes)); + break; + } + } + + for _ in 0..100 { + rng.fill_bytes(&mut G2_random_bytes); + G2_random_bytes[0] |= 0b10000000; + G2_random_bytes[0] &= 0b10011111; + let G2_try_out_group = G2Affine::from_compressed_unchecked(&G2_random_bytes); + if G2_try_out_group.is_some().unwrap_u8() == 1 + && G2_try_out_group.unwrap().is_torsion_free().unwrap_u8() == 0 + { + assert_eq!( + G2Affine::from_compressed(&G2_random_bytes) + .is_none() + .unwrap_u8(), + 1 + ); + + let G2_affine_pt = G2Affine::from_compressed_unchecked(&G2_random_bytes).unwrap(); + hex_strings.push(hex::encode(G2_affine_pt.to_uncompressed())); + break; + } + } + + //----------------------------------------------------------- + + write_hex_to_file("././test_vectors/serde_test_vectors", &hex_strings) +} + +fn bls_sig_with_dst_aug(mut rng: R) -> std::io::Result<()> { + let mut ikm = [0u8; 32]; + rng.fill_bytes(&mut ikm); + + let sk = Scalar::random(rng); + let pk = sk * G2Projective::generator(); + + let dst = b"BLS_SIG_BLS12381G2_XMD:SHA-256_SSWU_RO_NUL_"; + let aug = b"Random value for test aug. "; + let msg = b"blst is such a blast"; + let mut concat_msg_aug = Vec::new(); + concat_msg_aug.extend_from_slice(aug); + concat_msg_aug.extend_from_slice(msg); + let hashed_msg = >>::hash_to_curve(concat_msg_aug, dst); + + let sig = sk * hashed_msg; + + let blst_sig = Signature::from_bytes(&sig.to_affine().to_compressed()).expect("Invalid conversion from zkcrypto to blst"); + let blst_pk = PublicKey::from_bytes(&pk.to_affine().to_compressed()).expect("Invalid conversion from zkcrypto to blst"); + let err = blst_sig.verify(true, msg, dst, aug, &blst_pk, true); + assert_eq!(err, BLST_ERROR::BLST_SUCCESS); + + let sig_hex = hex::encode(sig.to_affine().to_compressed()); + let pk_hex = hex::encode(pk.to_affine().to_compressed()); + let mut file = File::create("././test_vectors/bls_sig_aug_test_vectors")?; + file.write_all(sig_hex.as_ref())?; + file.write_all(b"\n")?; + file.write_all(pk_hex.as_ref())?; + + Ok(()) +} + +fn write_hex_to_file(file_name: &str, hex_strings: &[String]) -> std::io::Result<()> { + let mut file = File::create(file_name)?; + + for string in hex_strings { + file.write_all(string.as_ref())?; + file.write_all(b"\n")?; + } + Ok(()) +} + +fn main() { + let mut rng = ChaCha20Rng::from_seed([0u8; 32]); + pairing_properties(&mut rng).expect("Failed to create test vectors!"); + ec_operations(&mut rng).expect("Failed to create test vectors!"); + serde(&mut rng).expect("Failed to create test vectors!"); + bls_sig_with_dst_aug(&mut rng).expect("Failed to create test vectors!"); +} diff --git a/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/bls_sig_aug_test_vectors b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/bls_sig_aug_test_vectors new file mode 100644 index 000000000..2ba0993d9 --- /dev/null +++ b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/bls_sig_aug_test_vectors @@ -0,0 +1,2 @@ +a96dd76db93e504b5604c191c9fa7b8a0f1a1facdcffb2f79b6b94a0d5fd4aa0a911ffef333d79ec679572ae10e6125d +9455244a8fbb3a180e22bb6df0b4c8ce4ef6a0751498f996cbdf8e7bc12be24665c8adc950f59f35b5c4c38aaebff8ae0d43f51033f9ab6850694e32a479be70969cc6bd35f6fa57acf23da92998f57af71aa4c00542d8dc17e28b0b8ffd022b \ No newline at end of file diff --git a/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/ec_operations_test_vectors b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/ec_operations_test_vectors new file mode 100644 index 000000000..862ed88a2 --- /dev/null +++ b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/ec_operations_test_vectors @@ -0,0 +1,12 @@ +b93105d0cff4c3f6a42ab790900a26bb1843f4b07fc83d527a66e4a2ddf6c49ea86fe37b1106dbd20dc280ec5996dadf +a077246742bfbffdefc1193aba17434d337f231478bf63173065c1e09c34429e76877983ae5f3add1438e5d237f63724 +9863eb0a7f8b092fca1a4333866ae3579ad2a4edef84bfcdf736333b3adf0100820c7603b002bf911b564cf032392f07 +b7fbd72bc365d8b7ea3954d0203bb4c6539cdec8feef30e6f44a3c67b2480e922a70b382bd5642737095c433938529bf +a07796202c3fcad405a5da58d99f0194c8ee21999dd03291f0bfe97e68eb4e69077cf8052b9f5d9cbc4a1394baa0e0d8 +993105d0cff4c3f6a42ab790900a26bb1843f4b07fc83d527a66e4a2ddf6c49ea86fe37b1106dbd20dc280ec5996dadf +b5ed6482bf5486831a9eb445b8b9a77aa6330005b8b432523c69fee7085d3032856de9f857c55ac9745eabcf14894205149cc67393687289e6c2728be69ad1f8ea1a6c0a5a65bf93eca984f3dac5da1abc6f7156ccbc5a33c655f7b17724eb19 +a6cc0f01663fd65a95d1359758ebe3a412ce05f4242b0c1f5964351b38e188362a8ceb6c2f86d3f7e5f73b60cd04288005d2a50f8ddf1751d7a915515054276fbae7569c3f18c614c9954177d8e745e98404654cf759d4747b0c806bbd336b7d +b3db03681aaf0d218be32f7cc94bd6a975c6870b4a1d4e461b77b60eee2461ca367154b0c4583b2d5f81124aa21fdf3e09ff6b54ce7c57572283a175fba381a32ac6f46abaf11cdbaeb206dcd7d4269caa4d0ebbb3adc1b8fce42ccfa855ea83 +b3db03681aaf0d218be32f7cc94bd6a975c6870b4a1d4e461b77b60eee2461ca367154b0c4583b2d5f81124aa21fdf3e09ff6b54ce7c57572283a175fba381a32ac6f46abaf11cdbaeb206dcd7d4269caa4d0ebbb3adc1b8fce42ccfa855ea83 +89b8e839c317ab3c735c6a65122fff4654f469c30c480701f6e4d9f311f3c5f3411c7cd2876c539bf56f983d14e550b5172765f62bba1235394a33413c21667a57214e9a6f2516f8d7bf57321c20bf8cd8ecd290691ad6bd5ab9e391304240a4 +95ed6482bf5486831a9eb445b8b9a77aa6330005b8b432523c69fee7085d3032856de9f857c55ac9745eabcf14894205149cc67393687289e6c2728be69ad1f8ea1a6c0a5a65bf93eca984f3dac5da1abc6f7156ccbc5a33c655f7b17724eb19 diff --git a/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/pairing_test_vectors b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/pairing_test_vectors new file mode 100644 index 000000000..b9d515eb9 --- /dev/null +++ b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/pairing_test_vectors @@ -0,0 +1,8 @@ +8baa4f3fcd895033f93494b040ccd7dfb77cb759cd2e150bfff4264873174509cd22230423b70896b17c8fc3660f6b21 +a4a925cb9c0580c14cbc8ec54447eb20070336a61c349c6a64b0d87e4db89d77734021cd88e2da369bdd85c0518c66c4 +aecf54083187026a6b689e70af54375ab7cc6d0d311acb6203730a2904654d6e92f82e62006c0d5e21094155eb93cc98 +b2bb2433441c452b78f5be911aa136dd2c886a9ac329cb6c805e50d5255891fcc389b1190432f16a109c6f431f0f8023 +a80f311db6f2fdc45404870f4c55b65a9a59a35efcfa2a7c595f3955226076bbaa33e403c0d4749495d9423b806f9dbe08cca770e08fa535daefb6dba2edb62f8b9aff6bae83bf48819bcdf98f07e79de8635e8521ddecae19b01a6777bc4684 +9906a15ff959b496f478dd17348b32c033236db5a7437768a30c5ce87d9b6adfa7bf2223a0721c93a92f33abac9b2faf00d25e48b0f3cc52595264ef9ad0aa7b81e20b3c8634d577883ff5fc2373a021a1e57826f420a74f3ce0fbd2dcf79415 +a63be4a1a776cadc7fc2e2d823bcc905f8f9cb0ebe662360d28d9964b022a99ce34a48b2e93cfceebc9bc1d79a3338da03a41393717239e66d4db06a87510b99fe04b0840c87c4051030b25e56ba34248d9ed30c82e8e501a616097299eefd62 +82606f4c771ca685bfc1bb9c51c886d0daa0f63fbb0f6a24b512a1b9b92d401e556cbffdc204c0a85192c865ed73f8090da58ecd1690d5a3b236cc5d40a98988f9602a6d114edb59954ef4e21692f2d48219aeacb964604849336059ceece69f diff --git a/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/serde_test_vectors b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/serde_test_vectors new file mode 100644 index 000000000..41a94b79c --- /dev/null +++ b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/serde_test_vectors @@ -0,0 +1,7 @@ +01b9c03c6442d982638c5315601a5d6a223aaff50adda5c536d5c5c5422fa3edeed5d577dc9a28739855062290aca8c001f61d43310d73546199246604a2cd8a7ba7ad7fe6cda05c3c2b1e558de2b31c32cde225579761cfd4ccc05925510ee2 +81b9c03c6442d982638c5315601a5d6a223aaff50adda5c536d5c5c5422fa3edeed5d577dc9a28739855062290aca8c0 +8fe2c13c6248d3d73d4d66d9c8587ac68a7976a3bbb8b5808320607400dbdb1918e3d3b90cfc38c4ddfade990a213d20 +0fbf7898334f4deed7e5830fd266751315435ae19bb94f4d3dc92652f243dd1f96f3595ab473d2356d8fa8f6d64cc4f600f228affa623bf3ff9155ec12d5bfa6ca7497f358198536d82111bcd5a5ea67a3c44b6eeadbc8bc3a65737e940b8bec +0863867c7a25395947962834307ec2b5a9f1ee979c27cfb21da212a27747ae334dca80b17b5c4e9f64c0da456ed5212f14431e912601a8a55fcdab4561d0721839f2d878505ec18c1cda03ddc714931c98e509536c53d2c6c606c29469865d6109d9674858f81bb51f19ed08baaf4b2af1f8ee2f18a96af2041d4a6e93814e48deecd6a317034baa1b9a7242ba66990117c13d95e56afe3a741b7287cd829e81df84cd838b892ceb15c3fdb5233325f431a6eb727630f01fb279b9920bda8bc9 +8863867c7a25395947962834307ec2b5a9f1ee979c27cfb21da212a27747ae334dca80b17b5c4e9f64c0da456ed5212f14431e912601a8a55fcdab4561d0721839f2d878505ec18c1cda03ddc714931c98e509536c53d2c6c606c29469865d61 +17a9d476c70c490004e8de0b23263255253ded4949d4f33a26ca3c7445b54c654afb26d16ab12b7b891bacc12adb06110abc5baa2091e24a3c5d60b3489d9c5772ef343a4807467e389b59f697f8ad32868758a7b33c9befb66b3501d92a576503b782f7174b7489a83c39a7a94337ca52da26cc8075894cc39924d62404deda7f446f0ab67a874a03589d405e2e015a0c6944037842147c8f8a3047a18d537c49dfa33fae6439c8ac047cd1254ce2fef65d0ac9dfa9750df9166f6dcc436093 From e64551f135e6e968609be2e32e87cf7e962a0288 Mon Sep 17 00:00:00 2001 From: Daniel Firth Date: Fri, 5 May 2023 16:13:13 +0000 Subject: [PATCH 02/75] cardano-mempool/Setup.hs: get rid of #endif statement --- cardano-mempool/Setup.hs | 2 -- 1 file changed, 2 deletions(-) diff --git a/cardano-mempool/Setup.hs b/cardano-mempool/Setup.hs index 059175c09..00bfe1fe4 100644 --- a/cardano-mempool/Setup.hs +++ b/cardano-mempool/Setup.hs @@ -2,5 +2,3 @@ import Distribution.Simple main :: IO () main = defaultMain -#endif - From 1ae0c6e95c95c362ce0e46a9296c15438a3f8b63 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Thu, 11 May 2023 06:42:21 +1000 Subject: [PATCH 03/75] CI: Remove cruft from GHA This cruft was cargo culted from the nightly build of the node. --- .github/workflows/haskell.yml | 6 ------ 1 file changed, 6 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index f30da522f..91f658d43 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -62,13 +62,7 @@ jobs: - name: Configure build shell: bash run: | - if [ "${{github.event.inputs.tests}}" == "all" ]; then - echo "Reconfigure cabal projects to run tests for all dependencies" - sed -i 's|tests: False|tests: True|g' cabal.project - fi - cp ".github/workflows/cabal.project.local.ci.$(uname -s)" cabal.project.local - echo "# cabal.project.local" cat cabal.project.local From 1c6ef46fc569f688f78c7489a4bf29179cd9c6f8 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 19 Apr 2023 13:16:44 +0100 Subject: [PATCH 04/75] Add script to generate haddocks in a new folder --- scripts/haddocks.sh | 110 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 110 insertions(+) create mode 100755 scripts/haddocks.sh diff --git a/scripts/haddocks.sh b/scripts/haddocks.sh new file mode 100755 index 000000000..354ef0797 --- /dev/null +++ b/scripts/haddocks.sh @@ -0,0 +1,110 @@ +#!/usr/bin/env bash + +# Build haddock documentation and an index for all projects in +# `cardano-base` repository. +# +# usage: +# ./haddocks.sh directory [true|false] +# +# $1 - where to put the generated pages, this directory contents will be wiped +# out (so don't pass `/` or `./` - the latter will delete your 'dist-newstyle') +# (the default is './haddocks') +# $2 - whether to re-build haddocks with `cabal haddock` command or a component name +# (the default is true) +# + +set -euo pipefail + +OUTPUT_DIR=${1:-"./haddocks"} +REGENERATE=${2:-"true"} + +BUILD_DIR="dist-newstyle" +GHC_VERSION=$(ghc --numeric-version) +OS_ARCH="$(cat dist-newstyle/cache/plan.json | jq -r '.arch + "-" + .os' | head -n 1 | xargs)" + + +# Generate `doc-index.json` and `doc-index.html` per package, to assemble them later at the top level. +HADDOCK_OPTS=( + --builddir "${BUILD_DIR}" + --haddock-all + --haddock-internal + --haddock-html + --haddock-quickjump + --haddock-hyperlink-source + --haddock-option "--show-all" + --haddock-option "--use-unicode" + --haddock-option="--base-url=.." + ) + +# build documentation of all modules +if [ ${REGENERATE} == "true" ]; then + cabal haddock "${HADDOCK_OPTS[@]}" all +elif [ ${REGENERATE} != "false" ]; then + cabal haddock "${HADDOCK_OPTS[@]}" ${REGENERATE} +fi + +if [[ !( -d ${OUTPUT_DIR} ) ]]; then + mkdir -p ${OUTPUT_DIR} +fi + +# make all files user writable +chmod -R u+w "${OUTPUT_DIR}" + +# copy the new docs +for dir in $(ls "${BUILD_DIR}/build/${OS_ARCH}/ghc-${GHC_VERSION}"); do + package=$(echo "${dir}" | sed 's/-[0-9]\+\(\.[0-9]\+\)*//') + if [ -d "${BUILD_DIR}/build/${OS_ARCH}/ghc-${GHC_VERSION}/${dir}/doc/html/${package}" ]; then + cp -r "${BUILD_DIR}/build/${OS_ARCH}/ghc-${GHC_VERSION}/${dir}/doc/html/${package}" ${OUTPUT_DIR} + else continue; + fi + # copy test packages documentation when it exists + if [ -d "${BUILD_DIR}/build/${OS_ARCH}/ghc-${GHC_VERSION}/${dir}/t" ]; then + for test_package in $(ls "${BUILD_DIR}/build/${OS_ARCH}/ghc-${GHC_VERSION}/${dir}/t"); do + if [ -d "${BUILD_DIR}/build/${OS_ARCH}/ghc-${GHC_VERSION}/${dir}/t/${test_package}/doc/html/${package}/${test_package}" ]; then + cp -r "${BUILD_DIR}/build/${OS_ARCH}/ghc-${GHC_VERSION}/${dir}/t/${test_package}/doc/html/${package}/${test_package}" "${OUTPUT_DIR}/${package}:${test_package}" + cp -n "${BUILD_DIR}/build/${OS_ARCH}/ghc-${GHC_VERSION}/${dir}/doc/html/${package}"/{*.css,*.js} "${OUTPUT_DIR}/${package}:${test_package}" && true + fi + done + fi + # copy lib packages documentation when it exists + if [ -d "${BUILD_DIR}/build/${OS_ARCH}/ghc-${GHC_VERSION}/${dir}/l" ]; then + for lib_package in $(ls "${BUILD_DIR}/build/${OS_ARCH}/ghc-${GHC_VERSION}/${dir}/l"); do + if [ -d "${BUILD_DIR}/build/${OS_ARCH}/ghc-${GHC_VERSION}/${dir}/l/${lib_package}/doc/html/${package}" ]; then + cp -r "${BUILD_DIR}/build/${OS_ARCH}/ghc-${GHC_VERSION}/${dir}/l/${lib_package}/doc/html/${package}" "${OUTPUT_DIR}/${package}:${lib_package}" + cp -n "${BUILD_DIR}/build/${OS_ARCH}/ghc-${GHC_VERSION}/${dir}/doc/html/${package}"/{*.css,*.js} "${OUTPUT_DIR}/${package}:${lib_package}" && true + fi + done + fi +done + +# build read-interface arguments for haddock +interface_options () { + for package in $(ls "${OUTPUT_DIR}"); do + if [[ -d "${OUTPUT_DIR}/${package}" ]]; then + haddock_file=$(ls -1 ${OUTPUT_DIR}/${package}/*.haddock | head -1) + echo "--read-interface=${package},${haddock_file}" + fi + done +} + +# Generate top level index using interface files +haddock \ + -o ${OUTPUT_DIR} \ + --title "cardano-base" \ + --package-name "Cardano Base" \ + --gen-index \ + --gen-contents \ + --quickjump \ + $(interface_options) + +# Assemble a toplevel `doc-index.json` from package level ones. +echo "[]" > "${OUTPUT_DIR}/doc-index.json" +for file in $(ls $OUTPUT_DIR/*/doc-index.json); do + project=$(basename $(dirname $file)); + jq -s \ + ".[0] + [.[1][] | (. + {link: (\"${project}/\" + .link)}) ]" \ + "${OUTPUT_DIR}/doc-index.json" \ + ${file} \ + > /tmp/doc-index.json + mv /tmp/doc-index.json "${OUTPUT_DIR}/doc-index.json" +done From 3bc424985d71e33735fbe2912a3e91aa93da927a Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 19 Apr 2023 13:19:46 +0100 Subject: [PATCH 05/75] Add script to generate a prolog listing all packages --- scripts/haddocks.sh | 3 +++ scripts/mkprolog.sh | 24 ++++++++++++++++++++++++ 2 files changed, 27 insertions(+) create mode 100755 scripts/mkprolog.sh diff --git a/scripts/haddocks.sh b/scripts/haddocks.sh index 354ef0797..e2ae3f7c6 100755 --- a/scripts/haddocks.sh +++ b/scripts/haddocks.sh @@ -87,6 +87,8 @@ interface_options () { done } +./scripts/mkprolog.sh ./haddocks ./scripts/prolog + # Generate top level index using interface files haddock \ -o ${OUTPUT_DIR} \ @@ -95,6 +97,7 @@ haddock \ --gen-index \ --gen-contents \ --quickjump \ + --prolog ./scripts/prolog \ $(interface_options) # Assemble a toplevel `doc-index.json` from package level ones. diff --git a/scripts/mkprolog.sh b/scripts/mkprolog.sh new file mode 100755 index 000000000..ba8209fbf --- /dev/null +++ b/scripts/mkprolog.sh @@ -0,0 +1,24 @@ +#!/usr/bin/env bash + +set -euo pipefail + +HADDOCKS_DIR=${1:-"./haddocks"} +PROLOG_FILE=${2:-"./scripts/prolog"} + +> ${PROLOG_FILE} + +cat > ${PROLOG_FILE} << EOF += Cardano Ledger Repository Hackage Documentation + +[skip to module list](#module-list) + +This site contains Haskell documentation of: + +EOF + +for dir in $(ls ${HADDOCKS_DIR}); do + if [[ -d ${HADDOCKS_DIR}/${dir} ]]; then + link=$(echo "${dir}" | sed "s/:/%3A/g") + echo "* __[${dir}](${link}/index.html)__" >> ${PROLOG_FILE} + fi +done From 7b6b32a69c359711afa011310d2d29da1dd737ef Mon Sep 17 00:00:00 2001 From: teodanciu Date: Wed, 19 Apr 2023 13:20:04 +0100 Subject: [PATCH 06/75] Add github action to deploy haddocks on github pages --- .github/workflows/gh-pages.yml | 42 ++++++++++++++++++++++++++++++++++ 1 file changed, 42 insertions(+) create mode 100644 .github/workflows/gh-pages.yml diff --git a/.github/workflows/gh-pages.yml b/.github/workflows/gh-pages.yml new file mode 100644 index 000000000..05c8421b8 --- /dev/null +++ b/.github/workflows/gh-pages.yml @@ -0,0 +1,42 @@ +name: Github Pages + +on: + push: + branches: [ "master" ] + workflow_dispatch: + +jobs: + gh-pages: + runs-on: ubuntu-latest + permissions: + contents: write + + steps: + - uses: actions/checkout@v3 + - name: Install nix + uses: cachix/install-nix-action@v20 + with: + nix_path: nixpkgs=channel:nixos-unstable + extra_nix_config: | + experimental-features = nix-command flakes + trusted-public-keys = hydra.iohk.io:f/Ea+s+dFdN+3Y/G+FDgSq+a5NEWhJGzdjvKNGv0/EQ= cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY= loony-tools:pr9m4BkM/5/eSTZlkQyRt57Jz7OMBxNSUiMC4FkcNfk= + substituters = https://cache.iog.io https://cache.nixos.org/ https://cache.zw3rk.com + - name: Build projects and haddocks + run: nix develop --command bash -c "cabal update && cabal build --enable-documentation all && ./scripts/haddocks.sh" + - name: Add files + run: | + git config --local user.name ${{ github.actor }} + git config --local user.email "${{ github.actor }}@users.noreply.github.com" + cp -r ./haddocks/* ./ + rm -rf haddocks + git add -A --force + git commit -m "Updated" + + - name: Push to gh-pages + uses: ad-m/github-push-action@v0.6.0 + with: + github_token: ${{ secrets.GITHUB_TOKEN }} + branch: gh-pages + force: true + directory: . + From cd15225fee9cab88b6d4c9fb6185e91ddd270682 Mon Sep 17 00:00:00 2001 From: teodanciu Date: Thu, 20 Apr 2023 13:19:32 +0100 Subject: [PATCH 07/75] Update README with haddocks landing page --- README.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/README.md b/README.md index 5f2f5a094..eb8858241 100644 --- a/README.md +++ b/README.md @@ -12,3 +12,5 @@ All releases for packages found in this repository are recorded in [Cardano Hask package repository](https://github.com/input-output-hk/cardano-haskell-packages) See the [wiki](https://github.com/input-output-hk/cardano-base/wiki) for more documentation. + +Haddock code documentation of the latest master branch is available [here](https://input-output-hk.github.io/cardano-base). From f855e4b571de47865341590196b712c7e20cf0d0 Mon Sep 17 00:00:00 2001 From: Moritz Angermann Date: Fri, 12 May 2023 18:32:39 +0800 Subject: [PATCH 08/75] Bring back c-sources: cbits/blst_util.c (#412) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit In #255 we somehow removed the ``` c-sources: cbits/blst_util.c ``` from the library. This included the symbol: `size_blst_p1`, which _is_ used in `cardano-crypto-class` 😱 . E.g. https://github.com/input-output-hk/cardano-base/blob/e48f2ec561713f7a0863e58e34004b8099079cab/cardano-crypto-class/src/Cardano/Crypto/EllipticCurve/BLS12_381/Internal.hs#L372 And thus we now run into undefined symbols issues 🤯 --- cardano-crypto-class/cardano-crypto-class.cabal | 1 + 1 file changed, 1 insertion(+) diff --git a/cardano-crypto-class/cardano-crypto-class.cabal b/cardano-crypto-class/cardano-crypto-class.cabal index d28ab9ac8..cb12d9577 100644 --- a/cardano-crypto-class/cardano-crypto-class.cabal +++ b/cardano-crypto-class/cardano-crypto-class.cabal @@ -124,6 +124,7 @@ library integer-gmp pkgconfig-depends: libsodium, libblst + c-sources: cbits/blst_util.c if flag(secp256k1-support) exposed-modules: From 37dc90646e86ee1213c4107346db368b29032a9d Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Thu, 18 May 2023 09:30:56 +0200 Subject: [PATCH 09/75] BLS test vectors (#408) * Include Haskell tests for BLS12-381 test vectors --------- Co-authored-by: iquerejeta Co-authored-by: Moritz Angermann --- .../bls12-381-test-vectors/README.md | 52 +++- .../bls12-381-test-vectors/src/main.rs | 247 +++++++++++------- .../test_vectors/bls_sig_aug_test_vectors | 4 +- .../test_vectors/ec_operations_test_vectors | 2 +- .../test_vectors/h2c_large_dst | 3 + .../test_vectors/pairing_test_vectors | 2 + .../test_vectors/serde_test_vectors | 15 +- .../cardano-crypto-tests.cabal | 9 + .../src/Test/Crypto/EllipticCurve.hs | 196 ++++++++++++++ cardano-crypto-tests/src/Test/Crypto/Util.hs | 13 +- cardano-crypto-tests/test/Main.hs | 4 +- flake.lock | 76 +++++- 12 files changed, 485 insertions(+), 138 deletions(-) create mode 100644 cardano-crypto-tests/bls12-381-test-vectors/test_vectors/h2c_large_dst diff --git a/cardano-crypto-tests/bls12-381-test-vectors/README.md b/cardano-crypto-tests/bls12-381-test-vectors/README.md index da64b6bc6..1d963def8 100644 --- a/cardano-crypto-tests/bls12-381-test-vectors/README.md +++ b/cardano-crypto-tests/bls12-381-test-vectors/README.md @@ -1,12 +1,11 @@ ## Test vectors for BLS This is a rust script to generate test vectors for the following: - Using [bls12_381](https://github.com/zkcrypto/bls12_381) - - Pairing properties - - Elliptic curve operations - - Deserialization/decompression - - BLS signature with `aug` and `dst`. - -The results are in hex encoding and stored under the folder `test_vectors`. + - Pairing properties + - Elliptic curve operations + - Deserialization/decompression +- Using [blst](https://github.com/supranational/blst) bindings from [bls12_381](https://github.com/zkcrypto/bls12_381) BLS signature with `aug` and `dst`. + The results are in hex encoding and stored under the folder `test_vectors`. ### 1- Test vectors for pairing properties The properties to be tested: @@ -19,8 +18,6 @@ The properties to be tested: The values used to generate test vectors: ``` -P = 840463aa2f2cda89985b1f3f5eb43b9c29809765d2747d60734b19d6f90610effdfc500af7d458a3e78cee0945ddc669 // G1 point -Q = b67029fbf3ab8e62ab6b499f541537fc07d9466e668392df2bc19762d7dc48b64be09a448cd46dbfe21819a91cd0ab3205f1316ad1cc32853f3f1a1d06497f5cfbc2d753dfc01bff177adeb93f24d452045435dc6eb29f5610b66cd0dd3fb352 // G2 point a = 0x0e51216fa879b2ce727b596d065dd9b7fd8a84d94ffacf9ca30ad114304272d3 // scalar b = 0x437c2d7d852637c2ef23645a5abcbb308d6150bfcccbf3a8fdbc9daaa91496ef // scalar aplusb = 0x51cd4eed2d9fea91619ebdc7611a94e88aebd5991cc6c345a0c76ebed95709c2 // scalar @@ -28,10 +25,12 @@ atimesb = 0x2d70bbc706812d56e805ae67934b3275ff67f304a76ea9b3c96d31b9c0d607ba // ``` Order of the values printed on `pairing_test_vectors`: -- `[a]P` +- `P` +- `[a]P` - `[b]P` - `[a + b]P` - `[a * b]P` +- `Q` - `[a]Q` - `[b]Q` - `[a + b]Q` @@ -41,10 +40,10 @@ Order of the values printed on `pairing_test_vectors`: ### 2- Test vectors for elliptic curve operations Operations to be tested: -- Addition +- Addition - Subtraction -- Scalar multiplication -- Negation +- Scalar multiplication +- Negation The scalar used in scalar multiplication: ``` @@ -84,7 +83,7 @@ Order of the values printed on `serde_test_vectors`: - `G2_uncomp_not_on_group` ### 4- BLS Signature -Test vectors for BLS signature, with successful validation using [blst](https://github.com/supranational/blst). +Test vectors for BLS signature, using `blst` bindings. The explicit usage of `aug` is not allowed in Cardano-base bindings. Therefore, before verification, they need to be appended into the message by following [hash-to-curve](https://datatracker.ietf.org/doc/html/draft-irtf-cfrg-hash-to-curve#name-expand_message) spec. @@ -93,7 +92,7 @@ The explicit usage of `aug` is not allowed in Cardano-base bindings. Therefore, ```rust let dst = b"BLS_SIG_BLS12381G2_XMD:SHA-256_SSWU_RO_NUL_"; let msg = b"blst is such a blast"; -let aug = b"Random value for test aug. "; +let aug = b"Random value for test aug"; ``` Order of the values printed on the files `bls_sig_aug_test_vectors` (BLS signature with `aug`): @@ -106,3 +105,28 @@ let hashed_msg = HashToG1Curve(aug || msg, dst); assert!(pairing(sig, G2Generator) == pairing(hashed_msg, pk)) ``` + +### 5- Hash to curve with large DST +The plutus bindings bound the DST to be at most 255 bytes, following the standard draft specification. If +applications require a domain separation tag that is longer than 255 bytes, they should convert it to a smaller +DST following the instructions of the standard draft (see [section 5.3.3](https://datatracker.ietf.org/doc/html/draft-irtf-cfrg-hash-to-curve#name-using-dsts-longer-than-255-)). + +We create test vectors to ensure that hashing to a curve by first hashing a large DST with SHA256, and then +hashing to the curve works as expected. The test vectors of this file are stored in `h2c_large_dst` with the +following order: + +- 'msg' +- 'large_dst' +- Compressed G1 'output' + +To validate these test vectors, one needs to proceed as follows: + +``` +let hashed_dst = Sha256(b"H2C-OVERSIZE-DST-" | large_dst); + +let hashed_output = HashToG1Curve(msg, hashed_dst); + +let expected_output = G1FromCompressed(output); + +assert!(expected_oputput == hashed_output); +``` diff --git a/cardano-crypto-tests/bls12-381-test-vectors/src/main.rs b/cardano-crypto-tests/bls12-381-test-vectors/src/main.rs index cbe70ef24..c1c6bc4c1 100644 --- a/cardano-crypto-tests/bls12-381-test-vectors/src/main.rs +++ b/cardano-crypto-tests/bls12-381-test-vectors/src/main.rs @@ -2,6 +2,7 @@ #![doc = include_str!("../README.md")] #![allow(non_snake_case)] +use bls12_381::hash_to_curve::{ExpandMsgXmd, HashToCurve}; use bls12_381::{G1Affine, G1Projective, G2Affine, G2Projective, Scalar}; use blst::min_sig::*; use blst::BLST_ERROR; @@ -11,7 +12,7 @@ use rand_chacha::rand_core::{RngCore, SeedableRng}; use rand_chacha::ChaCha20Rng; use std::fs::File; use std::io::prelude::*; -use bls12_381::hash_to_curve::{ExpandMsgXmd, HashToCurve}; +use sha2::{Digest, Sha256}; fn pairing_properties(mut rng: R) -> std::io::Result<()> { let P = G1Projective::random(&mut rng); @@ -35,8 +36,8 @@ fn pairing_properties(mut rng: R) -> std::io::Result<()> { write_hex_to_file( "././test_vectors/pairing_test_vectors", &[ - [aP, bP, aplusbP, atimesbP].map(|a| hex::encode(G1Affine::from(a).to_compressed())), - [aQ, bQ, aplusbQ, atimesbQ].map(|a| hex::encode(G2Affine::from(a).to_compressed())), + [P, aP, bP, aplusbP, atimesbP].map(|a| hex::encode(G1Affine::from(a).to_compressed())), + [Q, aQ, bQ, aplusbQ, atimesbQ].map(|a| hex::encode(G2Affine::from(a).to_compressed())), ] .concat(), ) @@ -55,7 +56,7 @@ fn ec_operations(mut rng: R) -> std::io::Result<()> { let G2_P = G2Projective::random(&mut rng); let G2_Q = G2Projective::random(&mut rng); let G2_ADD = G2_P + G2_Q; - let G2_SUB = G2_P + G2_Q; + let G2_SUB = G2_P - G2_Q; let G2_MUL = scalar * G2_Q; let G2_NEG = -G2_P; @@ -76,129 +77,120 @@ fn serde(mut rng: R) -> std::io::Result<()> { let mut hex_strings = Vec::new(); //---- G1---- - let G1_P = G1Affine::from(G1Projective::random(&mut rng)); - let mut G1_bytes = G1_P.to_uncompressed(); - G1_bytes[4] ^= 1; - assert_eq!( - G1Affine::from_uncompressed(&G1_bytes).is_none().unwrap_u8(), - 1 - ); - - hex_strings.push(hex::encode(G1_bytes)); - - let mut G1_compressed = G1_P.to_compressed(); - G1_compressed[4] ^= 1; - assert_eq!( - G1Affine::from_compressed(&G1_compressed) - .is_none() - .unwrap_u8(), - 1 - ); - - hex_strings.push(hex::encode(G1_compressed)); + // Uncompressed not on curve + let mut uncompressed_bytes = [0u8; 96]; + loop { + rng.fill_bytes(&mut uncompressed_bytes); + // We set the flags for the bytes + uncompressed_bytes[0] &= 0b00011111; // Uncompressed point, not at infinity + let G1_try_out_curve = G1Affine::from_uncompressed_unchecked(&uncompressed_bytes); + if G1_try_out_curve.is_some().unwrap_u8() == 1 && G1_try_out_curve.unwrap().is_on_curve().unwrap_u8() == 0 { + hex_strings.push(hex::encode(uncompressed_bytes)); + break; + } + } - let mut G1_random_bytes = [0u8; 48]; + // Compressed not on curve + let mut compressed_bytes = [0u8; 48]; + loop { + rng.fill_bytes(&mut compressed_bytes); + // We set the flags for the bytes + compressed_bytes[0] |= 0b10000000; + compressed_bytes[0] &= 0b10001111; // Compressed point, not at infinity. We don't care about the y sign (either both or neither will be on curve) + // We unset the 4th bit to make sure that the x-coordinate is canonical + if G1Affine::from_compressed_unchecked(&compressed_bytes).is_none().unwrap_u8() == 1 { + hex_strings.push(hex::encode(compressed_bytes)); + break; + } + } - for _ in 0..10 { - rng.fill_bytes(&mut G1_random_bytes); - G1_random_bytes[0] |= 0b10000000; - G1_random_bytes[0] &= 0b10011111; - let G1_try_out_group = G1Affine::from_compressed_unchecked(&G1_random_bytes); + // Compressed not in group + loop { + rng.fill_bytes(&mut compressed_bytes); + // We set the flags for the bytes + compressed_bytes[0] |= 0b10000000; + compressed_bytes[0] &= 0b10011111; // Compressed point, not at infinity. We don't care about the y sign (either both or neither will be in group) + let G1_try_out_group = G1Affine::from_compressed_unchecked(&compressed_bytes); if G1_try_out_group.is_some().unwrap_u8() == 1 && G1_try_out_group.unwrap().is_torsion_free().unwrap_u8() == 0 { - assert_eq!( - G1Affine::from_compressed(&G1_random_bytes) - .is_none() - .unwrap_u8(), - 1 - ); - hex_strings.push(hex::encode(G1_random_bytes)); + hex_strings.push(hex::encode(compressed_bytes)); break; } } - for _ in 0..10 { - rng.fill_bytes(&mut G1_random_bytes); - G1_random_bytes[0] |= 0b10000000; - G1_random_bytes[0] &= 0b10011111; - let G1_try_out_group = G1Affine::from_compressed_unchecked(&G1_random_bytes); + // Uncompressed not in group + loop { + rng.fill_bytes(&mut compressed_bytes); + // We set the flags for the bytes + compressed_bytes[0] |= 0b10000000; + compressed_bytes[0] &= 0b10011111; // Compressed point, not at infinity. We don't care about the y sign (either both or neither will be in group) + let G1_try_out_group = G1Affine::from_compressed_unchecked(&compressed_bytes); if G1_try_out_group.is_some().unwrap_u8() == 1 && G1_try_out_group.unwrap().is_torsion_free().unwrap_u8() == 0 { - assert_eq!( - G1Affine::from_compressed(&G1_random_bytes) - .is_none() - .unwrap_u8(), - 1 - ); - - let G1_affine_pt = G1Affine::from_compressed_unchecked(&G1_random_bytes).unwrap(); - hex_strings.push(hex::encode(G1_affine_pt.to_uncompressed())); + hex_strings.push(hex::encode(G1_try_out_group.unwrap().to_uncompressed())); break; } } //----------------------------------------------------------- //---- G2---- - let G2_P = G2Affine::from(G2Projective::random(&mut rng)); - let mut G2_bytes = G2_P.to_uncompressed(); - G2_bytes[4] ^= 1; - assert_eq!( - G2Affine::from_uncompressed(&G2_bytes).is_none().unwrap_u8(), - 1 - ); - - hex_strings.push(hex::encode(G2_bytes)); - - let mut G2_compressed = G2_P.to_compressed(); - G2_compressed[4] ^= 1; - assert_eq!( - G2Affine::from_compressed(&G2_compressed) - .is_none() - .unwrap_u8(), - 1 - ); + // Uncompressed not on curve + let mut uncompressed_bytes = [0u8; 192]; + loop { + rng.fill_bytes(&mut uncompressed_bytes); + // We set the flags for the bytes + uncompressed_bytes[0] &= 0b00011111; // Uncompressed point, not at infinity + let G2_try_out_curve = G2Affine::from_uncompressed_unchecked(&uncompressed_bytes); + if G2_try_out_curve.is_some().unwrap_u8() == 1 && G2_try_out_curve.unwrap().is_on_curve().unwrap_u8() == 0 { + hex_strings.push(hex::encode(uncompressed_bytes)); + break; + } + } - hex_strings.push(hex::encode(G2_compressed)); + // Compressed not on curve + let mut compressed_bytes = [0u8; 96]; + loop { + rng.fill_bytes(&mut compressed_bytes); + // We set the flags for the bytes + compressed_bytes[0] |= 0b10000000; + compressed_bytes[0] &= 0b10001111; // Compressed point, not at infinity. We don't care about the y sign (either both or neither will be in the curve) + // We unset the fourth bit to make sure that the first `Fp` of the x coordinate is canonical + compressed_bytes[48] &= 0b00001111; // We unset the fourth bit of the 48th byte to make sure that the second `Fp` of the x coordinate is canonical + + if G2Affine::from_compressed_unchecked(&compressed_bytes).is_none().unwrap_u8() == 1 { + hex_strings.push(hex::encode(compressed_bytes)); + break; + } + } - let mut G2_random_bytes = [0u8; 96]; - for _ in 0..10 { - rng.fill_bytes(&mut G2_random_bytes); - G2_random_bytes[0] |= 0b10000000; - G2_random_bytes[0] &= 0b10011111; - let G2_try_out_group = G2Affine::from_compressed_unchecked(&G2_random_bytes); + // Compressed not in group + loop { + rng.fill_bytes(&mut compressed_bytes); + // We set the flags for the bytes + compressed_bytes[0] |= 0b10000000; + compressed_bytes[0] &= 0b10011111; // Compressed point, not at infinity. We don't care about the y sign (either both or neither will be in group) + let G2_try_out_group = G2Affine::from_compressed_unchecked(&compressed_bytes); if G2_try_out_group.is_some().unwrap_u8() == 1 && G2_try_out_group.unwrap().is_torsion_free().unwrap_u8() == 0 { - assert_eq!( - G2Affine::from_compressed(&G2_random_bytes) - .is_none() - .unwrap_u8(), - 1 - ); - hex_strings.push(hex::encode(G2_random_bytes)); + hex_strings.push(hex::encode(compressed_bytes)); break; } } - for _ in 0..100 { - rng.fill_bytes(&mut G2_random_bytes); - G2_random_bytes[0] |= 0b10000000; - G2_random_bytes[0] &= 0b10011111; - let G2_try_out_group = G2Affine::from_compressed_unchecked(&G2_random_bytes); + // Uncompressed not in group + loop { + rng.fill_bytes(&mut compressed_bytes); + // We set the flags for the bytes + compressed_bytes[0] |= 0b10000000; + compressed_bytes[0] &= 0b10011111; // Compressed point, not at infinity. We don't care about the y sign (either both or neither will be in group) + let G2_try_out_group = G2Affine::from_compressed_unchecked(&compressed_bytes); if G2_try_out_group.is_some().unwrap_u8() == 1 && G2_try_out_group.unwrap().is_torsion_free().unwrap_u8() == 0 { - assert_eq!( - G2Affine::from_compressed(&G2_random_bytes) - .is_none() - .unwrap_u8(), - 1 - ); - - let G2_affine_pt = G2Affine::from_compressed_unchecked(&G2_random_bytes).unwrap(); - hex_strings.push(hex::encode(G2_affine_pt.to_uncompressed())); + hex_strings.push(hex::encode(G2_try_out_group.unwrap().to_uncompressed())); break; } } @@ -221,12 +213,17 @@ fn bls_sig_with_dst_aug(mut rng: R) -> std::io::Result<()> { let mut concat_msg_aug = Vec::new(); concat_msg_aug.extend_from_slice(aug); concat_msg_aug.extend_from_slice(msg); - let hashed_msg = >>::hash_to_curve(concat_msg_aug, dst); + let hashed_msg = >>::hash_to_curve( + concat_msg_aug, + dst, + ); let sig = sk * hashed_msg; - let blst_sig = Signature::from_bytes(&sig.to_affine().to_compressed()).expect("Invalid conversion from zkcrypto to blst"); - let blst_pk = PublicKey::from_bytes(&pk.to_affine().to_compressed()).expect("Invalid conversion from zkcrypto to blst"); + let blst_sig = Signature::from_bytes(&sig.to_affine().to_compressed()) + .expect("Invalid conversion from zkcrypto to blst"); + let blst_pk = PublicKey::from_bytes(&pk.to_affine().to_compressed()) + .expect("Invalid conversion from zkcrypto to blst"); let err = blst_sig.verify(true, msg, dst, aug, &blst_pk, true); assert_eq!(err, BLST_ERROR::BLST_SUCCESS); @@ -236,6 +233,55 @@ fn bls_sig_with_dst_aug(mut rng: R) -> std::io::Result<()> { file.write_all(sig_hex.as_ref())?; file.write_all(b"\n")?; file.write_all(pk_hex.as_ref())?; + file.write_all(b"\n")?; + + Ok(()) +} + +fn h2c_large_dst(rng: &mut R) -> std::io::Result<()> { + let msg = b"Testing large dst."; + let mut large_dst = [0u8; 300]; + rng.fill_bytes(&mut large_dst); + + let hash_output = >>::hash_to_curve( + msg, + &large_dst, + ); + + // Given that the DST is larger than 255 bytes, it will first be hashed. Here we test that we can perform that action + // manually. + // Sanity check + let hashed_dst = Sha256::new().chain(b"H2C-OVERSIZE-DST-").chain(&large_dst).finalize(); + + let manually_hashed_output = >>::hash_to_curve( + msg, + &hashed_dst, + ); + + assert_eq!(hash_output, manually_hashed_output); + + // Sanity check with blst lib + use blst::{blst_hash_to_g1, blst_p1, blst_p1_compress}; + + let mut out = blst_p1::default(); + unsafe { blst_hash_to_g1(&mut out, msg.as_ptr(), msg.len(), hashed_dst.as_ptr(), hashed_dst.len(), hashed_dst.as_ptr(), 0) }; + + let mut bytes = [0u8; 48]; + unsafe { blst_p1_compress(bytes.as_mut_ptr(), &out) } + + assert_eq!(bytes, hash_output.to_affine().to_compressed()); + + let msg_hex = hex::encode(msg); + let large_dst_hex = hex::encode(large_dst); + let hash_output_hex = hex::encode(hash_output.to_affine().to_compressed()); + + let mut file = File::create("././test_vectors/h2c_large_dst")?; + file.write_all(msg_hex.as_ref())?; + file.write_all(b"\n")?; + file.write_all(large_dst_hex.as_ref())?; + file.write_all(b"\n")?; + file.write_all(hash_output_hex.as_ref())?; + file.write_all(b"\n")?; Ok(()) } @@ -256,4 +302,5 @@ fn main() { ec_operations(&mut rng).expect("Failed to create test vectors!"); serde(&mut rng).expect("Failed to create test vectors!"); bls_sig_with_dst_aug(&mut rng).expect("Failed to create test vectors!"); + h2c_large_dst(&mut rng).expect("Failed to create large dst test vectors!"); } diff --git a/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/bls_sig_aug_test_vectors b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/bls_sig_aug_test_vectors index 2ba0993d9..7d93ed180 100644 --- a/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/bls_sig_aug_test_vectors +++ b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/bls_sig_aug_test_vectors @@ -1,2 +1,2 @@ -a96dd76db93e504b5604c191c9fa7b8a0f1a1facdcffb2f79b6b94a0d5fd4aa0a911ffef333d79ec679572ae10e6125d -9455244a8fbb3a180e22bb6df0b4c8ce4ef6a0751498f996cbdf8e7bc12be24665c8adc950f59f35b5c4c38aaebff8ae0d43f51033f9ab6850694e32a479be70969cc6bd35f6fa57acf23da92998f57af71aa4c00542d8dc17e28b0b8ffd022b \ No newline at end of file +83422fd1d8f134fbbc7ad2949a0b7c38dc1f85bfd398bc58ae824ad34ace68eaa49f438872ee22e90778513a91f9685e +b756d6223a92609cccf660b6f37e6e34fbb23972fc3955710f9bb202cc84cffacd337792700ebcb4324a99c7e7c9ed6d0e1cfdce8cd879a35300957c69c524c5365f6f0a85130735f27510618bbea605a1d024bb2d3bee2a5d68a827406f11c7 diff --git a/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/ec_operations_test_vectors b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/ec_operations_test_vectors index 862ed88a2..7046033e7 100644 --- a/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/ec_operations_test_vectors +++ b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/ec_operations_test_vectors @@ -7,6 +7,6 @@ a07796202c3fcad405a5da58d99f0194c8ee21999dd03291f0bfe97e68eb4e69077cf8052b9f5d9c b5ed6482bf5486831a9eb445b8b9a77aa6330005b8b432523c69fee7085d3032856de9f857c55ac9745eabcf14894205149cc67393687289e6c2728be69ad1f8ea1a6c0a5a65bf93eca984f3dac5da1abc6f7156ccbc5a33c655f7b17724eb19 a6cc0f01663fd65a95d1359758ebe3a412ce05f4242b0c1f5964351b38e188362a8ceb6c2f86d3f7e5f73b60cd04288005d2a50f8ddf1751d7a915515054276fbae7569c3f18c614c9954177d8e745e98404654cf759d4747b0c806bbd336b7d b3db03681aaf0d218be32f7cc94bd6a975c6870b4a1d4e461b77b60eee2461ca367154b0c4583b2d5f81124aa21fdf3e09ff6b54ce7c57572283a175fba381a32ac6f46abaf11cdbaeb206dcd7d4269caa4d0ebbb3adc1b8fce42ccfa855ea83 -b3db03681aaf0d218be32f7cc94bd6a975c6870b4a1d4e461b77b60eee2461ca367154b0c4583b2d5f81124aa21fdf3e09ff6b54ce7c57572283a175fba381a32ac6f46abaf11cdbaeb206dcd7d4269caa4d0ebbb3adc1b8fce42ccfa855ea83 +b0e55ab637ca0ed203af268bda8d681c04bd0696cf8cdba4e61c3ba2f3e4fa4ac5a2a7cb93a4a3feaea162506d73222d13caa80d0471afc79e8e5c97b1fccf27e024897545827c654a089d654c1987053b1baaaff3af25c5610d65c3345ae361 89b8e839c317ab3c735c6a65122fff4654f469c30c480701f6e4d9f311f3c5f3411c7cd2876c539bf56f983d14e550b5172765f62bba1235394a33413c21667a57214e9a6f2516f8d7bf57321c20bf8cd8ecd290691ad6bd5ab9e391304240a4 95ed6482bf5486831a9eb445b8b9a77aa6330005b8b432523c69fee7085d3032856de9f857c55ac9745eabcf14894205149cc67393687289e6c2728be69ad1f8ea1a6c0a5a65bf93eca984f3dac5da1abc6f7156ccbc5a33c655f7b17724eb19 diff --git a/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/h2c_large_dst b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/h2c_large_dst new file mode 100644 index 000000000..7031da4aa --- /dev/null +++ b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/h2c_large_dst @@ -0,0 +1,3 @@ +54657374696e67206c61726765206473742e +62f5804020e6a8e242c736d1c97bcd8262f91b88e1d70b00d10d5e315c8c6501ead0a7e367e5d394b9fcff9c15aa0f6a05e5085fdc56bcdee3865016f1c49b20e1e609a606eccabc9b9199a42345c25e06ae70028397f8fb95576f264239da3eb49629d5efeb1f1d74a3b1ac58608d893f98058f5ab870833489f5dfec52db5f92e70db05c9704cd9d644b1ae16aaafcc173d48db17e207d91308d3045b042b7241f87b8d42ac5df97d94fdf3f29d20ca2ae22c22e9c5b84b48d6daf1f7959c7c71d0169f370ebf2838479b3731885ff0d278deb632fcb83aef0ab593dddd4f5d21dac56abe08b8cb4aaf4235b1a292b91d6e8b90e39dc953c75fc460e7dd6d2bc8a372ac4efce161f5f18f861e67e5717c86805a05cc53ff493e91de2b85d3166b353f5bbc64bae0d2a4787 +a16b5778b5b88519b6caf05921d0d9b8b94a33d1daaa0c7fbfa66d52e801a5e798fae840bb9608aa31712e0b1b3a054a diff --git a/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/pairing_test_vectors b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/pairing_test_vectors index b9d515eb9..1e4803508 100644 --- a/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/pairing_test_vectors +++ b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/pairing_test_vectors @@ -1,7 +1,9 @@ +840463aa2f2cda89985b1f3f5eb43b9c29809765d2747d60734b19d6f90610effdfc500af7d458a3e78cee0945ddc669 8baa4f3fcd895033f93494b040ccd7dfb77cb759cd2e150bfff4264873174509cd22230423b70896b17c8fc3660f6b21 a4a925cb9c0580c14cbc8ec54447eb20070336a61c349c6a64b0d87e4db89d77734021cd88e2da369bdd85c0518c66c4 aecf54083187026a6b689e70af54375ab7cc6d0d311acb6203730a2904654d6e92f82e62006c0d5e21094155eb93cc98 b2bb2433441c452b78f5be911aa136dd2c886a9ac329cb6c805e50d5255891fcc389b1190432f16a109c6f431f0f8023 +b67029fbf3ab8e62ab6b499f541537fc07d9466e668392df2bc19762d7dc48b64be09a448cd46dbfe21819a91cd0ab3205f1316ad1cc32853f3f1a1d06497f5cfbc2d753dfc01bff177adeb93f24d452045435dc6eb29f5610b66cd0dd3fb352 a80f311db6f2fdc45404870f4c55b65a9a59a35efcfa2a7c595f3955226076bbaa33e403c0d4749495d9423b806f9dbe08cca770e08fa535daefb6dba2edb62f8b9aff6bae83bf48819bcdf98f07e79de8635e8521ddecae19b01a6777bc4684 9906a15ff959b496f478dd17348b32c033236db5a7437768a30c5ce87d9b6adfa7bf2223a0721c93a92f33abac9b2faf00d25e48b0f3cc52595264ef9ad0aa7b81e20b3c8634d577883ff5fc2373a021a1e57826f420a74f3ce0fbd2dcf79415 a63be4a1a776cadc7fc2e2d823bcc905f8f9cb0ebe662360d28d9964b022a99ce34a48b2e93cfceebc9bc1d79a3338da03a41393717239e66d4db06a87510b99fe04b0840c87c4051030b25e56ba34248d9ed30c82e8e501a616097299eefd62 diff --git a/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/serde_test_vectors b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/serde_test_vectors index 41a94b79c..333fe5147 100644 --- a/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/serde_test_vectors +++ b/cardano-crypto-tests/bls12-381-test-vectors/test_vectors/serde_test_vectors @@ -1,7 +1,8 @@ -01b9c03c6442d982638c5315601a5d6a223aaff50adda5c536d5c5c5422fa3edeed5d577dc9a28739855062290aca8c001f61d43310d73546199246604a2cd8a7ba7ad7fe6cda05c3c2b1e558de2b31c32cde225579761cfd4ccc05925510ee2 -81b9c03c6442d982638c5315601a5d6a223aaff50adda5c536d5c5c5422fa3edeed5d577dc9a28739855062290aca8c0 -8fe2c13c6248d3d73d4d66d9c8587ac68a7976a3bbb8b5808320607400dbdb1918e3d3b90cfc38c4ddfade990a213d20 -0fbf7898334f4deed7e5830fd266751315435ae19bb94f4d3dc92652f243dd1f96f3595ab473d2356d8fa8f6d64cc4f600f228affa623bf3ff9155ec12d5bfa6ca7497f358198536d82111bcd5a5ea67a3c44b6eeadbc8bc3a65737e940b8bec -0863867c7a25395947962834307ec2b5a9f1ee979c27cfb21da212a27747ae334dca80b17b5c4e9f64c0da456ed5212f14431e912601a8a55fcdab4561d0721839f2d878505ec18c1cda03ddc714931c98e509536c53d2c6c606c29469865d6109d9674858f81bb51f19ed08baaf4b2af1f8ee2f18a96af2041d4a6e93814e48deecd6a317034baa1b9a7242ba66990117c13d95e56afe3a741b7287cd829e81df84cd838b892ceb15c3fdb5233325f431a6eb727630f01fb279b9920bda8bc9 -8863867c7a25395947962834307ec2b5a9f1ee979c27cfb21da212a27747ae334dca80b17b5c4e9f64c0da456ed5212f14431e912601a8a55fcdab4561d0721839f2d878505ec18c1cda03ddc714931c98e509536c53d2c6c606c29469865d61 -17a9d476c70c490004e8de0b23263255253ded4949d4f33a26ca3c7445b54c654afb26d16ab12b7b891bacc12adb06110abc5baa2091e24a3c5d60b3489d9c5772ef343a4807467e389b59f697f8ad32868758a7b33c9befb66b3501d92a576503b782f7174b7489a83c39a7a94337ca52da26cc8075894cc39924d62404deda7f446f0ab67a874a03589d405e2e015a0c6944037842147c8f8a3047a18d537c49dfa33fae6439c8ac047cd1254ce2fef65d0ac9dfa9750df9166f6dcc436093 +16b8f1d20fe2c13c6248d3d73d4d66d9c8587ac68a7976a3bbb8b5808320607400dbdb1918e3d3b90cfc38c4ddfade990a213d208fbf7898334f4deed7e5830fd266751315435ae19bb94f4d3dc92652f243dd1f96f3595ab473d2356d8fa8f6 +864cc4f64b12ca99ecdd1962572e6add609d9c619aab678b3fc298bc2f0f81feb4f0d3ebad7e850a8bcb52ca467e649d +9483141c933166b61990a706aca07f467d22bc34c6552f5bba91cb1fc21db51d03dfff6523a5e1b4285d54c47660eda1 +04092fbc9b385639343cf26c9faf845e7a98cb1f2c9306e8200185d95de059f83ad17c4b97f8c62cf6c347dc6eb5f2b10c07b24a20cbcbd5121ba97f906bee018c34a71c6075ec91556ef67edda7e5ca42e3a785a183f630d7e330d7384a9ccd +14f2c0c96d9f70e48a42cdcdae542bae833eb4a976d4f98410b4a3d77857762d1527ec6714a040baaec3bec41bf9cff00e1cf81ce61e95d97792d7c0db7a88545f10d9b0a5940457018817725da257766906ffbc6172b9c4d2d32a14d00c0d1d01e15280074a4a9fd2d21393f078ef55b16cfea5327993263bffe8e99e56837b2763abd221ed85d83f9187af8b9e928f00deff423fffdadb786e6678a59af305cdc02546d0f8ab4681acc1f00069b0c47bbc9f13d12fd9411f8df532096d53e4 +87861839e602fc5dfa0d0b72232dd81d2b0e4b660a7eba353da27e66ceaf2d6c7734925247281866a12d67752a1edaad01ea59e4e86e2e85a81a573cd68f6dfb526558d81a8f488f261f355ddac23f6caf07d27fda71d8f3968d4ceeda89a09d +8bd83699f607412448d202d948bb111badd456d68086ff9a5906ea3b2cda4111d3638391f7a7b153eea77ab47215d6fe13b350f59f884c6e31ac087239d9145b816424cba2c8bcb7b3ed7e19638089d91e5c9136d2aefc8da165284b42229a70 +1120dda4e2d4bcc2fb6984277af23a282ceabebfcd847b8e6130b31c1f2febc638de2fb90d366743bcd4147a974235210462011fd256214f85e5591a3574a3003ec2eeff92634fd9fdd3a64dde1ecd92f0beb5f9eeb4697348a60921b6d3feb303a20332decaaa7fab892e34a43c5e6a2e90455a754b92a2cde128c3eeb46e8c9e22f1920d338f5107e86baa934c5c5f11589c6d345e5adefc0cd27d079e22f4d21f6f4a3f764c3d47062299c2f56bf49f5ff7e6cd2966aa3f2c1d125b76049c diff --git a/cardano-crypto-tests/cardano-crypto-tests.cabal b/cardano-crypto-tests/cardano-crypto-tests.cabal index 056c98cd6..2be302d9d 100644 --- a/cardano-crypto-tests/cardano-crypto-tests.cabal +++ b/cardano-crypto-tests/cardano-crypto-tests.cabal @@ -15,6 +15,11 @@ category: Currency build-type: Simple extra-source-files: README.md CHANGELOG.md +data-files: bls12-381-test-vectors/test_vectors/bls_sig_aug_test_vectors + bls12-381-test-vectors/test_vectors/ec_operations_test_vectors + bls12-381-test-vectors/test_vectors/h2c_large_dst + bls12-381-test-vectors/test_vectors/pairing_test_vectors + bls12-381-test-vectors/test_vectors/serde_test_vectors flag secp256k1-support description: Enable support for functions from libsecp256k1. Requires @@ -56,6 +61,7 @@ library Bench.Crypto.HASH Bench.Crypto.BenchData Test.Crypto.Vector.SerializationUtils + Paths_cardano_crypto_tests build-depends: base , bytestring >=0.10.12.0 @@ -100,6 +106,9 @@ test-suite test-crypto , tasty , tasty-quickcheck + if flag(secp256k1-support) + cpp-options: -DSECP256K1_ENABLED + ghc-options: -threaded -rtsopts -with-rtsopts=-N benchmark bench-crypto diff --git a/cardano-crypto-tests/src/Test/Crypto/EllipticCurve.hs b/cardano-crypto-tests/src/Test/Crypto/EllipticCurve.hs index 733f1d3c2..009916036 100644 --- a/cardano-crypto-tests/src/Test/Crypto/EllipticCurve.hs +++ b/cardano-crypto-tests/src/Test/Crypto/EllipticCurve.hs @@ -1,13 +1,20 @@ {-# OPTIONS_GHC -Wno-orphans #-} + {-# LANGUAGE TypeApplications #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} module Test.Crypto.EllipticCurve where +import Paths_cardano_crypto_tests + +import Test.Crypto.Util (eitherShowError) + import qualified Cardano.Crypto.EllipticCurve.BLS12_381 as BLS import qualified Cardano.Crypto.EllipticCurve.BLS12_381.Internal as BLS +import Cardano.Crypto.Hash (SHA256, digest) import Test.Crypto.Instances () import Test.QuickCheck ( (===), @@ -24,6 +31,8 @@ import Test.Tasty.QuickCheck (testProperty) import Test.Tasty.HUnit (testCase, assertBool, assertEqual) import Data.Proxy (Proxy (..)) import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Base16 as Base16 import System.IO.Unsafe (unsafePerformIO) import Data.Bits (shiftL) import Data.List (foldl') @@ -38,6 +47,7 @@ tests = , testBLSCurve "Curve 2" (Proxy @BLS.Curve2) , testPT "PT" , testPairing "Pairing" + , testVectors "Vectors" ] ] @@ -158,6 +168,192 @@ testPairing name = where pairingCheck (a, b) (c, d) = BLS.ptFinalVerify (BLS.millerLoop a b) (BLS.millerLoop c d) +loadHexFile :: String -> IO [BS.ByteString] +loadHexFile filename = do + mapM (either error pure . Base16.decode . BS8.filter (/= '\r')) . BS8.lines =<< BS.readFile filename + +testVectors :: String -> TestTree +testVectors name = + testGroup name + [ testVectorPairings "pairings" + , testVectorOperations "operations" + , testVectorSerDe "serialization/compression" + , testVectorSigAug "signature" + , testVectorLargeDst "large-dst" + ] + +testVectorPairings :: String -> TestTree +testVectorPairings name = + testCase name $ do + [ p_raw, + aP_raw, + bP_raw, + apbP_raw, + axbP_raw, + q_raw, + aQ_raw, + bQ_raw, + apbQ_raw, + axbQ_raw ] <- loadHexFile =<< getDataFileName "bls12-381-test-vectors/test_vectors/pairing_test_vectors" + + p <- eitherShowError $ BLS.blsUncompress p_raw + q <- eitherShowError $ BLS.blsUncompress q_raw + aP <- eitherShowError $ BLS.blsUncompress aP_raw + aQ <- eitherShowError $ BLS.blsUncompress aQ_raw + bP <- eitherShowError $ BLS.blsUncompress bP_raw + bQ <- eitherShowError $ BLS.blsUncompress bQ_raw + apbP <- eitherShowError $ BLS.blsUncompress apbP_raw + axbP <- eitherShowError $ BLS.blsUncompress axbP_raw + apbQ <- eitherShowError $ BLS.blsUncompress apbQ_raw + axbQ <- eitherShowError $ BLS.blsUncompress axbQ_raw + + assertBool "e([a]P, Q) = e(P, [a]Q)" $ + BLS.ptFinalVerify + (BLS.millerLoop aP q) + (BLS.millerLoop p aQ) + assertBool "e([a]P, [b]Q) = e([b]P, [a]Q)" $ + BLS.ptFinalVerify + (BLS.millerLoop aP bQ) + (BLS.millerLoop bP aQ) + assertBool "e([a]P, [b]Q) = e([a * b]P, Q)" $ + BLS.ptFinalVerify + (BLS.millerLoop aP bQ) + (BLS.millerLoop axbP q) + assertBool "e([a]P, Q) * e([b]P, Q) = e([a + b]P, Q)" $ + BLS.ptFinalVerify + (BLS.ptMult (BLS.millerLoop aP q) (BLS.millerLoop bP q)) + (BLS.millerLoop apbP q) + assertBool "e([a]P, [b]Q) = e(P, [a * b]Q)" $ + BLS.ptFinalVerify + (BLS.millerLoop aP bQ) + (BLS.millerLoop p axbQ) + assertBool "e(P, [a]Q) * e(P, [b]Q) = e(P, [a + b]Q)" $ + BLS.ptFinalVerify + (BLS.ptMult (BLS.millerLoop p aQ) (BLS.millerLoop p bQ)) + (BLS.millerLoop p apbQ) + +testVectorOperations :: String -> TestTree +testVectorOperations name = + testCase name $ do + [ g1p_raw, + g1q_raw, + g1add_raw, + g1sub_raw, + g1mul_raw, + g1neg_raw, + g2p_raw, + g2q_raw, + g2add_raw, + g2sub_raw, + g2mul_raw, + g2neg_raw ] <- loadHexFile =<< getDataFileName "bls12-381-test-vectors/test_vectors/ec_operations_test_vectors" + + let scalar = 0x40df499974f62e2f268cd5096b0d952073900054122ffce0a27c9d96932891a5 + g1p :: BLS.Point1 <- eitherShowError $ BLS.blsUncompress g1p_raw + g1q :: BLS.Point1 <- eitherShowError $ BLS.blsUncompress g1q_raw + g1add :: BLS.Point1 <- eitherShowError $ BLS.blsUncompress g1add_raw + g1sub :: BLS.Point1 <- eitherShowError $ BLS.blsUncompress g1sub_raw + g1mul :: BLS.Point1 <- eitherShowError $ BLS.blsUncompress g1mul_raw + g1neg :: BLS.Point1 <- eitherShowError $ BLS.blsUncompress g1neg_raw + g2p :: BLS.Point2 <- eitherShowError $ BLS.blsUncompress g2p_raw + g2q :: BLS.Point2 <- eitherShowError $ BLS.blsUncompress g2q_raw + g2add :: BLS.Point2 <- eitherShowError $ BLS.blsUncompress g2add_raw + g2sub :: BLS.Point2 <- eitherShowError $ BLS.blsUncompress g2sub_raw + g2mul :: BLS.Point2 <- eitherShowError $ BLS.blsUncompress g2mul_raw + g2neg :: BLS.Point2 <- eitherShowError $ BLS.blsUncompress g2neg_raw + + assertEqual "g1 add" + g1add (BLS.blsAddOrDouble g1p g1q) + assertEqual "g1 sub" + g1sub (BLS.blsAddOrDouble g1p (BLS.blsNeg g1q)) + assertEqual "g1 mul" + g1mul (BLS.blsMult g1q scalar) + assertEqual "g1 neg" + g1neg (BLS.blsNeg g1p) + + assertEqual "g2 add" + g2add (BLS.blsAddOrDouble g2p g2q) + assertEqual "g2 sub" + g2sub (BLS.blsAddOrDouble g2p (BLS.blsNeg g2q)) + assertEqual "g2 mul" + g2mul (BLS.blsMult g2q scalar) + assertEqual "g2 neg" + g2neg (BLS.blsNeg g2p) + +testVectorSerDe :: String -> TestTree +testVectorSerDe name = + testCase name $ do + [ g1UncompNotOnCurve, + g1CompNotOnCurve, + g1CompNotInGroup, + g1UncompNotInGroup, + g2UncompNotOnCurve, + g2CompNotOnCurve, + g2CompNotInGroup, + g2UncompNotInGroup ] <- loadHexFile =<< getDataFileName "bls12-381-test-vectors/test_vectors/serde_test_vectors" + + assertEqual "g1UncompNotOnCurve" + (Left BLS.BLST_POINT_NOT_ON_CURVE) + (BLS.blsDeserialize g1UncompNotOnCurve :: Either BLS.BLSTError BLS.Point1) + + assertEqual "g1CompNotInGroup" + (Left BLS.BLST_POINT_NOT_IN_GROUP) + (BLS.blsUncompress g1CompNotInGroup :: Either BLS.BLSTError BLS.Point1) + + assertEqual "g1CompNotOnCurve" + (Left BLS.BLST_POINT_NOT_ON_CURVE) + (BLS.blsUncompress g1CompNotOnCurve :: Either BLS.BLSTError BLS.Point1) + + assertEqual "g1UncompNotInGroup" + (Left BLS.BLST_POINT_NOT_IN_GROUP) + (BLS.blsDeserialize g1UncompNotInGroup :: Either BLS.BLSTError BLS.Point1) + + + assertEqual "g2UncompNotOnCurve" + (Left BLS.BLST_POINT_NOT_ON_CURVE) + (BLS.blsDeserialize g2UncompNotOnCurve :: Either BLS.BLSTError BLS.Point2) + + assertEqual "g2CompNotInGroup" + (Left BLS.BLST_POINT_NOT_IN_GROUP) + (BLS.blsUncompress g2CompNotInGroup :: Either BLS.BLSTError BLS.Point2) + + assertEqual "g2CompNotOnCurve" + (Left BLS.BLST_POINT_NOT_ON_CURVE) + (BLS.blsUncompress g2CompNotOnCurve :: Either BLS.BLSTError BLS.Point2) + + assertEqual "g2UncompNotInGroup" + (Left BLS.BLST_POINT_NOT_IN_GROUP) + (BLS.blsDeserialize g2UncompNotInGroup :: Either BLS.BLSTError BLS.Point2) + + +testVectorSigAug :: String -> TestTree +testVectorSigAug name = + testCase name $ do + [ sig_raw, pk_raw ] <- loadHexFile =<< getDataFileName "bls12-381-test-vectors/test_vectors/bls_sig_aug_test_vectors" + let dst = "BLS_SIG_BLS12381G2_XMD:SHA-256_SSWU_RO_NUL_" + let msg = "blst is such a blast" + let aug = "Random value for test aug. " + let hashedMsg = BLS.blsHash (aug <> msg) (Just dst) Nothing + sig <- eitherShowError $ BLS.blsUncompress sig_raw + pk <- eitherShowError $ BLS.blsUncompress pk_raw + + assertBool "valid signature" $ + BLS.ptFinalVerify + (BLS.millerLoop sig BLS.blsGenerator) + (BLS.millerLoop hashedMsg pk) + +testVectorLargeDst :: String -> TestTree +testVectorLargeDst name = + testCase name $ do + [ msg_raw, large_dst_raw, output_raw ] <- loadHexFile =<< getDataFileName "bls12-381-test-vectors/test_vectors/h2c_large_dst" + let prefix = "H2C-OVERSIZE-DST-" + let dst_sha = digest (Proxy @SHA256) (prefix <> large_dst_raw) + let hashedMsg = BLS.blsHash msg_raw (Just dst_sha) Nothing + expected_output :: BLS.Point1 <- eitherShowError $ BLS.blsUncompress output_raw + + assertEqual "expected hash output" + hashedMsg expected_output + testAssoc :: (Show a, Eq a) => (a -> a -> a) -> a -> a -> a -> Property testAssoc f a b c = f a (f b c) === f (f a b) c diff --git a/cardano-crypto-tests/src/Test/Crypto/Util.hs b/cardano-crypto-tests/src/Test/Crypto/Util.hs index 9ee41496a..1660f35dd 100644 --- a/cardano-crypto-tests/src/Test/Crypto/Util.hs +++ b/cardano-crypto-tests/src/Test/Crypto/Util.hs @@ -59,6 +59,9 @@ module Test.Crypto.Util , noExceptionsThrown , doesNotThrow + -- * Error handling + , eitherShowError + -- * Locking , Lock , withLock @@ -66,7 +69,6 @@ module Test.Crypto.Util ) where -import Numeric (showHex) import GHC.Exts (fromListN, fromList, toList) import Text.Show.Pretty (ppShow) import Data.Kind (Type) @@ -101,6 +103,8 @@ import Crypto.Random ) import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Base16 as Base16 import Data.Proxy (Proxy (Proxy)) import Data.Word (Word64) import NoThunks.Class (NoThunks, unsafeNoThunks, noThunks) @@ -127,6 +131,7 @@ import Control.Monad (guard, when) import GHC.TypeLits (Nat, KnownNat, natVal) import Formatting.Buildable (Buildable (..), build) import Control.Concurrent.MVar (MVar, withMVar, newMVar) +import GHC.Stack (HasCallStack) -------------------------------------------------------------------------------- -- Connecting MonadRandom to Gen @@ -343,7 +348,7 @@ showBadInputFor (BadInputFor (_, bs)) = hexBS :: ByteString -> String hexBS bs = - "0x" <> BS.foldr showHex "" bs <> " (length " <> show (BS.length bs) <> ")" + "0x" <> BS8.unpack (Base16.encode bs) <> " (length " <> show (BS.length bs) <> ")" -- | Return a property that always succeeds in some monad (typically 'IO'). -- This is useful to express that we are only interested in whether the side @@ -366,3 +371,7 @@ withLock (Lock v) = withMVar v . const mkLock :: IO Lock mkLock = Lock <$> newMVar () + +eitherShowError :: (HasCallStack, Show e) => Either e a -> IO a +eitherShowError (Left e) = error (show e) +eitherShowError (Right a) = return a diff --git a/cardano-crypto-tests/test/Main.hs b/cardano-crypto-tests/test/Main.hs index ef0c4269a..14c10439c 100644 --- a/cardano-crypto-tests/test/Main.hs +++ b/cardano-crypto-tests/test/Main.hs @@ -9,8 +9,8 @@ import qualified Test.Crypto.VRF import qualified Test.Crypto.Regressions #ifdef SECP256K1_ENABLED import qualified Test.Crypto.Vector.Secp256k1DSIGN -import qualified Test.Crypto.EllipticCurve #endif +import qualified Test.Crypto.EllipticCurve import Test.Tasty (TestTree, adjustOption, testGroup, defaultMain) import Test.Tasty.QuickCheck (QuickCheckTests (QuickCheckTests)) import Cardano.Crypto.Libsodium (sodiumInit) @@ -41,6 +41,6 @@ tests mlockLock = , Test.Crypto.Regressions.tests #ifdef SECP256K1_ENABLED , Test.Crypto.Vector.Secp256k1DSIGN.tests - , Test.Crypto.EllipticCurve.tests #endif + , Test.Crypto.EllipticCurve.tests ] diff --git a/flake.lock b/flake.lock index 5361513de..f5e95a733 100644 --- a/flake.lock +++ b/flake.lock @@ -48,6 +48,23 @@ "type": "github" } }, + "blst": { + "flake": false, + "locked": { + "lastModified": 1656163412, + "narHash": "sha256-xero1aTe2v4IhWIJaEDUsVDOfE77dOV5zKeHWntHogY=", + "owner": "supranational", + "repo": "blst", + "rev": "03b5124029979755c752eec45f3c29674b558446", + "type": "github" + }, + "original": { + "owner": "supranational", + "repo": "blst", + "rev": "03b5124029979755c752eec45f3c29674b558446", + "type": "github" + } + }, "cabal-32": { "flake": false, "locked": { @@ -460,14 +477,17 @@ }, "iohkNix": { "inputs": { - "nixpkgs": "nixpkgs_2" + "blst": "blst", + "nixpkgs": "nixpkgs_2", + "secp256k1": "secp256k1", + "sodium": "sodium" }, "locked": { - "lastModified": 1681957618, - "narHash": "sha256-6fo/QohImV8buYiIhnSniquMmBj4IgtgQrq0JDpsav4=", + "lastModified": 1684223806, + "narHash": "sha256-IyLoP+zhuyygLtr83XXsrvKyqqLQ8FHXTiySFf4FJOI=", "owner": "input-output-hk", "repo": "iohk-nix", - "rev": "26f56e32169dcc9ef72ac754eccdb3c96d714751", + "rev": "86421fdd89b3af43fa716ccd07638f96c6ecd1e4", "type": "github" }, "original": { @@ -770,16 +790,18 @@ }, "nixpkgs_2": { "locked": { - "lastModified": 1677021523, - "narHash": "sha256-0EhZjJ3rq8ZTTJ6Trrf/9hYtnIry0OsyY2NKoQoOS5Q=", - "owner": "NixOS", + "lastModified": 1684171562, + "narHash": "sha256-BMUWjVWAUdyMWKk0ATMC9H0Bv4qAV/TXwwPUvTiC5IQ=", + "owner": "nixos", "repo": "nixpkgs", - "rev": "5a5adc2ad7009851d7d0fc26311e42a93b171d2e", + "rev": "55af203d468a6f5032a519cba4f41acf5a74b638", "type": "github" }, "original": { - "id": "nixpkgs", - "type": "indirect" + "owner": "nixos", + "ref": "release-22.11", + "repo": "nixpkgs", + "type": "github" } }, "nixpkgs_3": { @@ -945,6 +967,40 @@ "tullia": "tullia" } }, + "secp256k1": { + "flake": false, + "locked": { + "lastModified": 1683999695, + "narHash": "sha256-9nJJVENMXjXEJZzw8DHzin1DkFkF8h9m/c6PuM7Uk4s=", + "owner": "bitcoin-core", + "repo": "secp256k1", + "rev": "acf5c55ae6a94e5ca847e07def40427547876101", + "type": "github" + }, + "original": { + "owner": "bitcoin-core", + "ref": "v0.3.2", + "repo": "secp256k1", + "type": "github" + } + }, + "sodium": { + "flake": false, + "locked": { + "lastModified": 1675156279, + "narHash": "sha256-0uRcN5gvMwO7MCXVYnoqG/OmeBFi8qRVnDWJLnBb9+Y=", + "owner": "input-output-hk", + "repo": "libsodium", + "rev": "dbb48cce5429cb6585c9034f002568964f1ce567", + "type": "github" + }, + "original": { + "owner": "input-output-hk", + "repo": "libsodium", + "rev": "dbb48cce5429cb6585c9034f002568964f1ce567", + "type": "github" + } + }, "stackage": { "flake": false, "locked": { From b0628fd4406fa9563517447a63146a2c302ded78 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 10 May 2023 23:50:36 +0300 Subject: [PATCH 10/75] Add contributing doc and update the readme --- CONTRBUTING.md | 165 +++++++++++++++++++++++++++++++++++++++++++++++++ README.md | 58 ++++++++++++++++- 2 files changed, 221 insertions(+), 2 deletions(-) create mode 100644 CONTRBUTING.md diff --git a/CONTRBUTING.md b/CONTRBUTING.md new file mode 100644 index 000000000..7cdaa7420 --- /dev/null +++ b/CONTRBUTING.md @@ -0,0 +1,165 @@ +# Contributing to the Cardano BAse + +## Roles and responsibilities + +Currently there are two core maintainers: + +* [@lehins](https://github.com/lehins) +* [@tdammers](https://github.com/tdammers) + +Anything crypto related should be directed at: + +* [@iquerejeta](https://github.com/iquerejeta) + +People who can help with issues regarding this repository's continuous integration and nix +infrastructure: + +* [@angerman](https://github.com/angerman) +* [@hamishmack](https://github.com/hamishmack) + +**For security related issues** please consult the security file in the +[Cardano engineering handbook](https://github.com/input-output-hk/cardano-engineering-handbook/blob/main/SECURITY.md). + +## Development + +We use trunk based developement. Normal development will branch off of master and be +merged back to master. + +### Releasing and versioning + +Packages from `cardano-base` are released to +[CHaP](https://github.com/input-output-hk/cardano-haskell-packages). + +See documentation on the adopted [release and versioning processes](./RELEASING.md) for +more information. + +Also see the CHaP README for [instructions](https://github.com/input-output-hk/cardano-haskell-packages#-from-github). + +## Building + +See the [Readme](https://github.com/input-output-hk/cardano-base#building) for +instructions on building. + +## Updating dependencies + +Our Haskell packages come from two package repositories: +- Hackage +- [CHaP](https://github.com/input-output-hk/cardano-haskell-packages) (which is + another alternative Hackage from Cardano) + +The `index-state` of each repository is pinned to a particular time in `cabal.project`. +This tells Cabal to treat the repository "as if" it was the specified time, ensuring +reproducibility. If you want to use a package version from repository X which was added +after the pinned index state time, you need to bump the index state for X. This is not a +big deal, since all it does is change what packages `cabal` considers to be available when +solving, but it will change what package versions cabal picks for the plan, and so +will likely result in significant recompilation, and potentially some breakage. That +typically just means that we need to fix the breakage (and add a lower-bound on the +problematic package), or add an upper-bound on the problematic package. + +Note that `cabal` itself keeps track of what index states it knows about, so when you bump +the pinned index state you may need to call `cabal update` in order for `cabal` to be happy. + +The Nix code which builds our packages also cares about the index state. This is +represented by inputs managed by `nix flake`: You can update these by running: +- `nix flake lock --update-input hackage` for Hackage +- `nix flake lock --update-input CHaP` for CHaP + +If you fail to do this you may get an error like this from Nix: +``` +error: Unknown index-state 2021-08-08T00:00:00Z, the latest index-state I know about is 2021-08-06T00:00:00Z. You may need to update to a newer hackage.nix. +``` + +### Use of `source-repository-package`s + +We *can* use Cabal's `source-repository-package` mechanism to pull in un-released package +versions. However, we should avoid this. In particular, we cannot release +our packages to CHaP while we depend on a `source-repository-package`. + +If we are stuck in a situation where we need a long-running fork of a package, we should +release it to CHaP instead (see the [CHaP +README](https://github.com/input-output-hk/cardano-haskell-packages) for more). + +If you do add a `source-repository-package`, you need to provide a `--sha256` comment in `cabal.project` so that Nix knows the hash of the content. + +## Warnings + +While building most compilation warnings will be turned into an error due to +`-Werror` flag. However during development it might be a bit inconvenient thus +can be disabled on per project basis: + +```shell +cabal configure --ghc-options="-Wwarn" +cabal build +``` + +### Additional documentation + +You can find additional documentation on the nix infrastructure used in this +repo in the following places: + +- [The haskell.nix user guide](https://github.com/input-output-hk/haskell.nix/blob/documentation/docs/user-guide.md) +- [The nix-tools repository](https://github.com/input-output-hk/nix-tools) +- [The iohk-nix repository](https://github.com/input-output-hk/iohk-nix) + +Note that the user guide linked above is incomplete and does not correctly refer +to projects built using `iohk-nix`, as this one is. A certain amount of trial +and error may be required to make substantive changes! + +## Working Conventions + +### Code formatting + +Very soon we will start using [`fourmolu`](https://github.com/fourmolu/fourmolu) for +formatting, but for now a rule of thumb is to follow whatever format is in a module that +is being modified. There is a script +[here](https://github.com/input-output-hk/cardano-base/blob/master/scripts/fourmolize.sh) +which uses nix to format the appropriate directories. + +### Compiler warnings + +The CI builds Haskell code with `-Werror`, so will fail if there are any compiler warnings. + +A particular warning can be turned off, if there is a compelling enough reason to do so, +but it should be done at the module level, rather than for a whole package. + +### Commit messages + +Summarize changes in around 72 characters or less. + +Provide more detailed explanatory text, if necessary. Wrap it to about 72 characters or +so. In some contexts, the first line is treated as the subject of the commit and the rest +of the text as the body. The blank line separating the summary from the body is critical +(unless you omit the body entirely); various tools like `log`, `shortlog` and `rebase` can +get confused if you run the two together. + +Explain the problem that this commit is solving, and use one commit per conceptual change. +Focus on why you are making this change as opposed to how (the code explains that). Are +there side effects or other unintuitive consequences of this change? Here's the place to +explain them. + +If you use an issue tracker, put references to them at the bottom, like this: + +Resolves: #123 +See also: #456, #789 + +### Commit signing + +Commits are required to be [signed](https://docs.github.com/en/authentication/managing-commit-signature-verification/signing-commits). + +### Pull Requests + +We require linear history in `master`, so every PR must be rebase on `master` before it +can be merged. There is a convenience button on a PR "Update branch", but make sure to +select "Update with Rebase" from the drop down. + +Keep commits to a single logical change where possible. The reviewer will be happier, and +you’ll be happier if you ever have to revert it. If you can’t do this (say because you +have a huge mess), best to just have one commit with everything in it. + +Keep your PRs to a single topic. Including unrelated changes makes things harder for your +reviewers, slowing them down, and makes it harder to integrate new changes. + +If you’re working on something that’s likely to conflict with someone else, talk to +them. It’s not a race. + diff --git a/README.md b/README.md index eb8858241..8da461ba4 100644 --- a/README.md +++ b/README.md @@ -8,9 +8,63 @@ A collection of miscellaneous packages used by Cardano that cover: Each sub-project has its own README. +Haddock for all packages from master branch can be found here: +[https://input-output-hk.github.io/cardano-base](https://input-output-hk.github.io/cardano-base/) + All releases for packages found in this repository are recorded in [Cardano Haskell package repository](https://github.com/input-output-hk/cardano-haskell-packages) -See the [wiki](https://github.com/input-output-hk/cardano-base/wiki) for more documentation. +## Building + +### With `nix` + +With nix it is as easy as: + +``` +$ nix develop +... +$ cabal build all +``` + +### Without `nix` + +Crypotgraphic depencencies needed for building Haskell packages: + +* [`libsodium`](https://github.com/jedisct1/libsodium) +* [`libsecp256k1`](https://github.com/bitcoin-core/secp256k1) +* [`libblst`](https://github.com/supranational/blst) + +We provide packaged versions for common Operating Systems for all of the above +dependencies: [Download](https://github.com/input-output-hk/iohk-nix/releases/tag/latest) + + +## GHC + +Default version of GHC used in `nix` is `9.2.7`, but we do support other GHC versions +`8.10.7` and `9.6.1`. + + +### Testing + +This is a command to run test suites for all packages: + +``` +$ cabal build all +``` + +The test suites use [Tasty](https://github.com/feuerbach/tasty), +which allows for running specific tests. +This is done by passing the `-p` flag to the test program, followed by an `awk` pattern. +You can alternatively use the `TASTY_PATTERN` environment variable with a pattern. +For example, the `cardano-crypto-tests` can be run with: + +```shell +$ cabal test cardano-crypto-tests --test-options '-p blake2b_256' +``` + +or + +```shell +$ TASTY_PATTERN="blake2b_256" cabal test cardano-crypto-tests +``` -Haddock code documentation of the latest master branch is available [here](https://input-output-hk.github.io/cardano-base). From 6cca8ce3c2e6139ef683328a9627b84c237cb5e9 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Fri, 19 May 2023 08:46:11 +1000 Subject: [PATCH 11/75] Reduce use of allow-newer in cabal.project file --- cabal.project | 7 ++----- flake.lock | 6 +++--- 2 files changed, 5 insertions(+), 8 deletions(-) diff --git a/cabal.project b/cabal.project index 63b148f3f..b09cf8c4e 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,7 @@ repository cardano-haskell-packages -- The hackage index-state index-state: 2023-04-18T07:23:09Z -- The CHaP index-state -index-state: cardano-haskell-packages 2023-04-24T15:32:00Z +index-state: cardano-haskell-packages 2023-05-18T20:27:48Z packages: base-deriving-via @@ -37,10 +37,7 @@ program-options if impl(ghc >= 9.6) allow-newer: , *:base - , *:ghc-prim - , *:template-haskell - , hedgehog:* + , protolude:ghc-prim , protolude:binary , protolude:bytestring , protolude:text - , th-compat:* diff --git a/flake.lock b/flake.lock index f5e95a733..c49aa7254 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1682094054, - "narHash": "sha256-k9YXHH3X53r3t83Qufu4r0JBq73xUODmNnVXlJdMQM4=", + "lastModified": 1684408157, + "narHash": "sha256-hgHBZ+3HPitr71KBhQ/rhVGfZoUm9PgVntvOrDkkcg0=", "owner": "input-output-hk", "repo": "cardano-haskell-packages", - "rev": "cbfcbe87db0a704520a2f69dd9d6b1cc3712dc35", + "rev": "ef8e5093f0ea0f1e59f944fa502c685b1bf085c2", "type": "github" }, "original": { From ea957cde537c753e67502318f1ebb782243405f5 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 19 May 2023 23:06:10 +0300 Subject: [PATCH 12/75] Remove upper bound on vector. Fix #327 --- cardano-crypto-class/cardano-crypto-class.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cardano-crypto-class/cardano-crypto-class.cabal b/cardano-crypto-class/cardano-crypto-class.cabal index cb12d9577..cf9b91db1 100644 --- a/cardano-crypto-class/cardano-crypto-class.cabal +++ b/cardano-crypto-class/cardano-crypto-class.cabal @@ -117,7 +117,7 @@ library , th-compat , text , transformers - , vector < 0.13 + , vector if impl(ghc < 9.0.0) build-depends: From 39859fd19badc7686b3d265bc166d4f5a463d33c Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Tue, 18 Apr 2023 13:55:57 +0200 Subject: [PATCH 13/75] Simplify secure forgetting Changes: - Remove MonadSodium typeclass - Express mlocked memory operations in terms of MonadST - Get rid of ForgetMock testing (has been moot since we no longer depend on GC to reclaim mlocked memory) - Remove `m` parameter from mlocked memory based typeclasses (KES, DSIGN) - Simplify KES and DSIGN typeclass hierarchies --- .../cardano-crypto-class.cabal | 7 +- .../src/Cardano/Crypto/DSIGN/Ed25519ML.hs | 72 +-- .../src/Cardano/Crypto/DSIGNM/Class.hs | 86 +++- .../src/Cardano/Crypto/{MEqOrd.hs => EqST.hs} | 39 +- .../src/Cardano/Crypto/KES/Class.hs | 135 ++++-- .../src/Cardano/Crypto/KES/CompactSingle.hs | 18 +- .../src/Cardano/Crypto/KES/CompactSum.hs | 75 ++- .../src/Cardano/Crypto/KES/Mock.hs | 20 +- .../src/Cardano/Crypto/KES/NeverUsed.hs | 14 +- .../src/Cardano/Crypto/KES/Simple.hs | 34 +- .../src/Cardano/Crypto/KES/Single.hs | 20 +- .../src/Cardano/Crypto/KES/Sum.hs | 72 ++- .../src/Cardano/Crypto/Libsodium.hs | 40 +- .../src/Cardano/Crypto/Libsodium/Hash.hs | 21 +- .../Cardano/Crypto/Libsodium/MLockedBytes.hs | 6 + .../Crypto/Libsodium/MLockedBytes/Internal.hs | 92 ++-- .../Cardano/Crypto/Libsodium/MLockedSeed.hs | 84 ++++ .../src/Cardano/Crypto/Libsodium/Memory.hs | 25 + .../Crypto/Libsodium/Memory/Internal.hs | 230 ++++++++-- .../src/Cardano/Crypto/MLockedSeed.hs | 64 --- .../src/Cardano/Crypto/MonadSodium.hs | 64 --- .../src/Cardano/Crypto/MonadSodium/Alloc.hs | 77 ---- .../src/Cardano/Crypto/MonadSodium/Class.hs | 62 --- .../src/Cardano/Crypto/PinnedSizedBytes.hs | 37 +- .../cardano-crypto-tests.cabal | 2 - cardano-crypto-tests/src/Bench/Crypto/KES.hs | 16 +- .../src/Cardano/Crypto/KES/ForgetMock.hs | 169 ------- .../src/Test/Crypto/AllocLog.hs | 105 +---- cardano-crypto-tests/src/Test/Crypto/DSIGN.hs | 56 +-- .../src/Test/Crypto/Instances.hs | 18 +- cardano-crypto-tests/src/Test/Crypto/KES.hs | 428 ++++++------------ cardano-crypto-tests/src/Test/Crypto/Util.hs | 4 +- cardano-mempool/src/Cardano/Memory/Pool.hs | 249 +++++----- .../tests/Test/Cardano/Memory/PoolTests.hs | 16 +- 34 files changed, 1125 insertions(+), 1332 deletions(-) rename cardano-crypto-class/src/Cardano/Crypto/{MEqOrd.hs => EqST.hs} (54%) create mode 100644 cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedSeed.hs delete mode 100644 cardano-crypto-class/src/Cardano/Crypto/MLockedSeed.hs delete mode 100644 cardano-crypto-class/src/Cardano/Crypto/MonadSodium.hs delete mode 100644 cardano-crypto-class/src/Cardano/Crypto/MonadSodium/Alloc.hs delete mode 100644 cardano-crypto-class/src/Cardano/Crypto/MonadSodium/Class.hs delete mode 100644 cardano-crypto-tests/src/Cardano/Crypto/KES/ForgetMock.hs diff --git a/cardano-crypto-class/cardano-crypto-class.cabal b/cardano-crypto-class/cardano-crypto-class.cabal index cf9b91db1..4451c600e 100644 --- a/cardano-crypto-class/cardano-crypto-class.cabal +++ b/cardano-crypto-class/cardano-crypto-class.cabal @@ -77,12 +77,9 @@ library Cardano.Crypto.Libsodium.Memory.Internal Cardano.Crypto.Libsodium.MLockedBytes Cardano.Crypto.Libsodium.MLockedBytes.Internal + Cardano.Crypto.Libsodium.MLockedSeed Cardano.Crypto.Libsodium.UnsafeC - Cardano.Crypto.MEqOrd - Cardano.Crypto.MLockedSeed - Cardano.Crypto.MonadSodium - Cardano.Crypto.MonadSodium.Class - Cardano.Crypto.MonadSodium.Alloc + Cardano.Crypto.EqST Cardano.Crypto.PinnedSizedBytes Cardano.Crypto.Seed Cardano.Crypto.Util diff --git a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs b/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs index 923264a55..a4cbc2e2f 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs @@ -39,22 +39,29 @@ import Control.Monad.ST.Unsafe (unsafeIOToST) import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Cardano.Foreign -import Cardano.Crypto.PinnedSizedBytes import Cardano.Crypto.Libsodium.C -import Cardano.Crypto.Libsodium (MLockedSizedBytes) -import Cardano.Crypto.MonadSodium - ( MonadSodium (..) +import Cardano.Crypto.Libsodium + ( MLockedSizedBytes , mlsbToByteString - , mlsbFromByteStringCheck + , mlsbFromByteStringCheckWith , mlsbUseAsSizedPtr - , mlsbNew + , mlsbNewWith , mlsbFinalize - , mlsbCopy - , MEq (..) + , mlsbCopyWith + ) +import Cardano.Crypto.PinnedSizedBytes + ( PinnedSizedBytes + , psbUseAsSizedPtr + , psbToByteString + , psbFromByteStringCheck + , psbCreateSizedResult + ) +import Cardano.Crypto.EqST + ( EqST (..) ) import Cardano.Crypto.DSIGNM.Class -import Cardano.Crypto.MLockedSeed +import Cardano.Crypto.Libsodium.MLockedSeed import Cardano.Crypto.Util (SignableRepresentation(..)) data Ed25519DSIGNM @@ -83,8 +90,8 @@ cOrError action = do else Just <$> unsafeIOToST getErrno --- | Throws an appropriate 'IOException' when 'Just' an 'Errno' is given. -throwOnErrno :: (MonadThrow m) => String -> String -> Maybe Errno -> m () +-- | Throws an error when 'Just' an 'Errno' is given. +throwOnErrno :: MonadThrow m => String -> String -> Maybe Errno -> m () throwOnErrno contextDesc cFunName maybeErrno = do case maybeErrno of Just errno -> throwIO $ errnoToIOError (contextDesc ++ ": " ++ cFunName) errno Nothing Nothing @@ -171,7 +178,7 @@ instance DSIGNMAlgorithmBase Ed25519DSIGNM where -- reflects this. -- -- Various libsodium primitives, particularly 'MLockedSizedBytes' primitives, --- are used via the 'MonadSodium' typeclass, which is responsible for +-- are used via the 'MonadST' typeclass, which is responsible for -- guaranteeing orderly execution of these actions. We avoid using these -- primitives inside 'unsafeIOToST', as well as any 'IO' actions that would be -- unsafe to use inside 'unsafePerformIO'. @@ -186,14 +193,13 @@ instance DSIGNMAlgorithmBase Ed25519DSIGNM where -- memory passed to them via C pointers. -- - 'getErrno'; however, 'ST' guarantees sequentiality in the context where -- we use 'getErrno', so this is fine. --- - 'BS.useAsCStringLen', which is fine and shouldn't require 'IO' to begin --- with, but unfortunately, for historical reasons, does. -instance (MonadST m, MonadSodium m, MonadThrow m) => DSIGNMAlgorithm m Ed25519DSIGNM where +instance DSIGNMAlgorithm Ed25519DSIGNM where deriveVerKeyDSIGNM (SignKeyEd25519DSIGNM sk) = VerKeyEd25519DSIGNM <$!> do mlsbUseAsSizedPtr sk $ \skPtr -> do - (psb, maybeErrno) <- withLiftST $ \fromST -> fromST $ do - psbCreateSizedResult $ \pkPtr -> + (psb, maybeErrno) <- + psbCreateSizedResult $ \pkPtr -> + withLiftST $ \fromST -> fromST $ do cOrError $ unsafeIOToST $ c_crypto_sign_ed25519_sk_to_pk pkPtr skPtr throwOnErrno "deriveVerKeyDSIGNM @Ed25519DSIGNM" "c_crypto_sign_ed25519_sk_to_pk" maybeErrno @@ -204,8 +210,9 @@ instance (MonadST m, MonadSodium m, MonadThrow m) => DSIGNMAlgorithm m Ed25519DS let bs = getSignableRepresentation a in SigEd25519DSIGNM <$!> do mlsbUseAsSizedPtr sk $ \skPtr -> do - (psb, maybeErrno) <- withLiftST $ \fromST -> fromST $ do - psbCreateSizedResult $ \sigPtr -> do + (psb, maybeErrno) <- + psbCreateSizedResult $ \sigPtr -> do + withLiftST $ \fromST -> fromST $ do cOrError $ unsafeIOToST $ do BS.useAsCStringLen bs $ \(ptr, len) -> c_crypto_sign_ed25519_detached sigPtr nullPtr (castPtr ptr) (fromIntegral len) skPtr @@ -215,9 +222,9 @@ instance (MonadST m, MonadSodium m, MonadThrow m) => DSIGNMAlgorithm m Ed25519DS -- -- Key generation -- - {-# NOINLINE genKeyDSIGNM #-} - genKeyDSIGNM seed = SignKeyEd25519DSIGNM <$!> do - sk <- mlsbNew + {-# NOINLINE genKeyDSIGNMWith #-} + genKeyDSIGNMWith allocator seed = SignKeyEd25519DSIGNM <$!> do + sk <- mlsbNewWith allocator mlsbUseAsSizedPtr sk $ \skPtr -> mlockedSeedUseAsCPtr seed $ \seedPtr -> do maybeErrno <- withLiftST $ \fromST -> @@ -230,11 +237,11 @@ instance (MonadST m, MonadSodium m, MonadThrow m) => DSIGNMAlgorithm m Ed25519DS allocaSizedST k = unsafeIOToST $ allocaSized $ \ptr -> stToIO $ k ptr - cloneKeyDSIGNM (SignKeyEd25519DSIGNM sk) = - SignKeyEd25519DSIGNM <$!> mlsbCopy sk + cloneKeyDSIGNMWith allocator (SignKeyEd25519DSIGNM sk) = + SignKeyEd25519DSIGNM <$!> mlsbCopyWith allocator sk - getSeedDSIGNM _ (SignKeyEd25519DSIGNM sk) = do - seed <- mlockedSeedNew + getSeedDSIGNMWith allocator _ (SignKeyEd25519DSIGNM sk) = do + seed <- mlockedSeedNewWith allocator mlsbUseAsSizedPtr sk $ \skPtr -> mlockedSeedUseAsSizedPtr seed $ \seedPtr -> do maybeErrno <- withLiftST $ \fromST -> @@ -247,13 +254,12 @@ instance (MonadST m, MonadSodium m, MonadThrow m) => DSIGNMAlgorithm m Ed25519DS -- -- Secure forgetting -- - forgetSignKeyDSIGNM (SignKeyEd25519DSIGNM sk) = do - mlsbFinalize sk + forgetSignKeyDSIGNMWith _ (SignKeyEd25519DSIGNM sk) = mlsbFinalize sk deriving via (MLockedSizedBytes (SizeSignKeyDSIGNM Ed25519DSIGNM)) - instance (MonadST m, MonadSodium m) => MEq m (SignKeyDSIGNM Ed25519DSIGNM) + instance EqST (SignKeyDSIGNM Ed25519DSIGNM) -instance (MonadST m, MonadSodium m, MonadThrow m) => UnsoundDSIGNMAlgorithm m Ed25519DSIGNM where +instance UnsoundDSIGNMAlgorithm Ed25519DSIGNM where -- -- Ser/deser (dangerous - do not use in production code) -- @@ -266,12 +272,12 @@ instance (MonadST m, MonadSodium m, MonadThrow m) => UnsoundDSIGNMAlgorithm m Ed mlockedSeedFinalize seed return raw - rawDeserialiseSignKeyDSIGNM raw = do - mseed <- fmap MLockedSeed <$> mlsbFromByteStringCheck raw + rawDeserialiseSignKeyDSIGNMWith allocator raw = do + mseed <- fmap MLockedSeed <$> mlsbFromByteStringCheckWith allocator raw case mseed of Nothing -> return Nothing Just seed -> do - sk <- Just <$> genKeyDSIGNM seed + sk <- Just <$> genKeyDSIGNMWith allocator seed mlockedSeedFinalize seed return sk diff --git a/cardano-crypto-class/src/Cardano/Crypto/DSIGNM/Class.hs b/cardano-crypto-class/src/Cardano/Crypto/DSIGNM/Class.hs index d53020645..68c1fe580 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/DSIGNM/Class.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/DSIGNM/Class.hs @@ -2,7 +2,6 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -11,6 +10,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} -- | Abstract digital signatures. module Cardano.Crypto.DSIGNM.Class @@ -23,6 +23,10 @@ module Cardano.Crypto.DSIGNM.Class , sizeVerKeyDSIGNM , sizeSignKeyDSIGNM , sizeSigDSIGNM + , genKeyDSIGNM + , cloneKeyDSIGNM + , getSeedDSIGNM + , forgetSignKeyDSIGNM -- * 'SignedDSIGNM' wrapper , SignedDSIGNM (..) @@ -46,6 +50,7 @@ module Cardano.Crypto.DSIGNM.Class , UnsoundDSIGNMAlgorithm (..) , encodeSignKeyDSIGNM , decodeSignKeyDSIGNM + , rawDeserialiseSignKeyDSIGNM ) where @@ -56,14 +61,17 @@ import Data.Proxy (Proxy(..)) import Data.Typeable (Typeable) import GHC.Exts (Constraint) import GHC.Generics (Generic) -import GHC.Stack +import GHC.Stack (HasCallStack) import GHC.TypeLits (KnownNat, Nat, natVal, TypeError, ErrorMessage (..)) import NoThunks.Class (NoThunks) +import Control.Monad.Class.MonadST (MonadST) +import Control.Monad.Class.MonadThrow (MonadThrow) import Cardano.Binary (Decoder, decodeBytes, Encoding, encodeBytes, Size, withWordSize) import Cardano.Crypto.Util (Empty) -import Cardano.Crypto.MLockedSeed +import Cardano.Crypto.Libsodium.MLockedSeed +import Cardano.Crypto.Libsodium (MLockedAllocator, mlockedMalloc) import Cardano.Crypto.Hash.Class (HashAlgorithm, Hash, hashWith) class ( Typeable v @@ -135,23 +143,20 @@ class ( Typeable v rawDeserialiseVerKeyDSIGNM :: ByteString -> Maybe (VerKeyDSIGNM v) rawDeserialiseSigDSIGNM :: ByteString -> Maybe (SigDSIGNM v) -class ( DSIGNMAlgorithmBase v - , Monad m - ) - => DSIGNMAlgorithm m v where +class DSIGNMAlgorithmBase v => DSIGNMAlgorithm v where -- -- Metadata and basic key operations -- - deriveVerKeyDSIGNM :: SignKeyDSIGNM v -> m (VerKeyDSIGNM v) + deriveVerKeyDSIGNM :: (MonadThrow m, MonadST m) => SignKeyDSIGNM v -> m (VerKeyDSIGNM v) -- -- Core algorithm operations -- signDSIGNM - :: (SignableM v a, HasCallStack) + :: (SignableM v a, MonadST m, MonadThrow m) => ContextDSIGNM v -> a -> SignKeyDSIGNM v @@ -161,29 +166,69 @@ class ( DSIGNMAlgorithmBase v -- Key generation -- - genKeyDSIGNM :: MLockedSeed (SeedSizeDSIGNM v) -> m (SignKeyDSIGNM v) + genKeyDSIGNMWith :: (MonadST m, MonadThrow m) + => MLockedAllocator m + -> MLockedSeed (SeedSizeDSIGNM v) + -> m (SignKeyDSIGNM v) - cloneKeyDSIGNM :: SignKeyDSIGNM v -> m (SignKeyDSIGNM v) + cloneKeyDSIGNMWith :: MonadST m => MLockedAllocator m -> SignKeyDSIGNM v -> m (SignKeyDSIGNM v) - getSeedDSIGNM :: Proxy v -> SignKeyDSIGNM v -> m (MLockedSeed (SeedSizeDSIGNM v)) + getSeedDSIGNMWith :: (MonadST m, MonadThrow m) + => MLockedAllocator m + -> Proxy v + -> SignKeyDSIGNM v + -> m (MLockedSeed (SeedSizeDSIGNM v)) -- -- Secure forgetting -- - forgetSignKeyDSIGNM :: SignKeyDSIGNM v -> m () + forgetSignKeyDSIGNMWith :: (MonadST m, MonadThrow m) => MLockedAllocator m -> SignKeyDSIGNM v -> m () + + +forgetSignKeyDSIGNM :: (DSIGNMAlgorithm v, MonadST m, MonadThrow m) => SignKeyDSIGNM v -> m () +forgetSignKeyDSIGNM = forgetSignKeyDSIGNMWith mlockedMalloc + + +genKeyDSIGNM :: + (DSIGNMAlgorithm v, MonadST m, MonadThrow m) + => MLockedSeed (SeedSizeDSIGNM v) + -> m (SignKeyDSIGNM v) +genKeyDSIGNM = genKeyDSIGNMWith mlockedMalloc + +cloneKeyDSIGNM :: + (DSIGNMAlgorithm v, MonadST m) => SignKeyDSIGNM v -> m (SignKeyDSIGNM v) +cloneKeyDSIGNM = cloneKeyDSIGNMWith mlockedMalloc + +getSeedDSIGNM :: + (DSIGNMAlgorithm v, MonadST m, MonadThrow m) + => Proxy v + -> SignKeyDSIGNM v + -> m (MLockedSeed (SeedSizeDSIGNM v)) +getSeedDSIGNM = getSeedDSIGNMWith mlockedMalloc + -- | Unsound operations on DSIGNM sign keys. These operations violate secure -- forgetting constraints by leaking secrets to unprotected memory. Consider -- using the 'DirectSerialise' / 'DirectDeserialise' APIs instead. -class DSIGNMAlgorithm m v => UnsoundDSIGNMAlgorithm m v where +class DSIGNMAlgorithm v => UnsoundDSIGNMAlgorithm v where -- -- Serialisation/(de)serialisation in fixed-size raw format -- - rawSerialiseSignKeyDSIGNM :: SignKeyDSIGNM v -> m ByteString + rawSerialiseSignKeyDSIGNM :: + (MonadST m, MonadThrow m) => SignKeyDSIGNM v -> m ByteString + + rawDeserialiseSignKeyDSIGNMWith :: + (MonadST m, MonadThrow m) => MLockedAllocator m -> ByteString -> m (Maybe (SignKeyDSIGNM v)) + +rawDeserialiseSignKeyDSIGNM :: + (UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m) + => ByteString + -> m (Maybe (SignKeyDSIGNM v)) +rawDeserialiseSignKeyDSIGNM = + rawDeserialiseSignKeyDSIGNMWith mlockedMalloc - rawDeserialiseSignKeyDSIGNM :: ByteString -> m (Maybe (SignKeyDSIGNM v)) -- -- Do not provide Ord instances for keys, see #38 @@ -221,7 +266,10 @@ sizeSigDSIGNM _ = fromInteger (natVal (Proxy @(SizeSigDSIGNM v))) encodeVerKeyDSIGNM :: DSIGNMAlgorithmBase v => VerKeyDSIGNM v -> Encoding encodeVerKeyDSIGNM = encodeBytes . rawSerialiseVerKeyDSIGNM -encodeSignKeyDSIGNM :: (UnsoundDSIGNMAlgorithm m v) => SignKeyDSIGNM v -> m Encoding +encodeSignKeyDSIGNM :: + (UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m) + => SignKeyDSIGNM v + -> m Encoding encodeSignKeyDSIGNM = fmap encodeBytes . rawSerialiseSignKeyDSIGNM encodeSigDSIGNM :: DSIGNMAlgorithmBase v => SigDSIGNM v -> Encoding @@ -242,7 +290,7 @@ decodeVerKeyDSIGNM = do actual = BS.length bs decodeSignKeyDSIGNM :: forall m v s - . (UnsoundDSIGNMAlgorithm m v) + . (UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m) => Decoder s (m (SignKeyDSIGNM v)) decodeSignKeyDSIGNM = do bs <- decodeBytes @@ -282,7 +330,7 @@ instance DSIGNMAlgorithmBase v => NoThunks (SignedDSIGNM v a) -- use generic instance signedDSIGNM - :: (DSIGNMAlgorithm m v, SignableM v a) + :: (DSIGNMAlgorithm v, SignableM v a, MonadST m, MonadThrow m) => ContextDSIGNM v -> a -> SignKeyDSIGNM v diff --git a/cardano-crypto-class/src/Cardano/Crypto/MEqOrd.hs b/cardano-crypto-class/src/Cardano/Crypto/EqST.hs similarity index 54% rename from cardano-crypto-class/src/Cardano/Crypto/MEqOrd.hs rename to cardano-crypto-class/src/Cardano/Crypto/EqST.hs index f041a6fc5..ffdae7e0b 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/MEqOrd.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/EqST.hs @@ -1,57 +1,58 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -module Cardano.Crypto.MEqOrd -where +module Cardano.Crypto.EqST where + +import Control.Monad.Class.MonadST (MonadST) -- | Monadic flavor of 'Eq', for things that can only be compared in a monadic --- context. +-- context that satisfies 'MonadST'. -- This is needed because we cannot have a sound 'Eq' instance on mlocked --- memory types. -class MEq m a where - equalsM :: a -> a -> m Bool +-- memory types, but we do need to compare them for equality in tests. +class EqST a where + equalsM :: MonadST m => a -> a -> m Bool -nequalsM :: (Functor m, MEq m a) => a -> a -> m Bool +nequalsM :: (MonadST m, EqST a) => a -> a -> m Bool nequalsM a b = not <$> equalsM a b -- | Infix version of 'equalsM' -(==!) :: MEq m a => a -> a -> m Bool +(==!) :: (MonadST m, EqST a) => a -> a -> m Bool (==!) = equalsM infix 4 ==! -- | Infix version of 'nequalsM' -(!=!) :: (Functor m, MEq m a) => a -> a -> m Bool +(!=!) :: (MonadST m, EqST a) => a -> a -> m Bool (!=!) = nequalsM infix 4 !=! -instance (Applicative m, MEq m a) => MEq m (Maybe a) where +instance EqST a => EqST (Maybe a) where equalsM Nothing Nothing = pure True equalsM (Just a) (Just b) = equalsM a b equalsM _ _ = pure False -instance (Applicative m, MEq m a, MEq m b) => MEq m (Either a b) where +instance (EqST a, EqST b) => EqST (Either a b) where equalsM (Left x) (Left y) = equalsM x y equalsM (Right x) (Right y) = equalsM x y equalsM _ _ = pure False -instance (Applicative m, MEq m a, MEq m b) => MEq m (a, b) where +instance (EqST a, EqST b) => EqST (a, b) where equalsM (a, b) (a', b') = (&&) <$> equalsM a a' <*> equalsM b b' -instance (Applicative m, MEq m a, MEq m b, MEq m c) => MEq m (a, b, c) where +instance (EqST a, EqST b, EqST c) => EqST (a, b, c) where equalsM (a, b, c) (a', b', c') = equalsM ((a, b), c) ((a', b'), c') -instance (Applicative m, MEq m a, MEq m b, MEq m c, MEq m d) => MEq m (a, b, c, d) where +instance (EqST a, EqST b, EqST c, EqST d) => EqST (a, b, c, d) where equalsM (a, b, c, d) (a', b', c', d') = equalsM ((a, b, c), d) ((a', b', c'), d') -- TODO: If anyone needs larger tuples, add more instances here... --- | Helper newtype, useful for defining 'MEq' in terms of 'Eq' for types that +-- | Helper newtype, useful for defining 'EqST' in terms of 'Eq' for types that -- have sound 'Eq' instances, using @DerivingVia@. An 'Applicative' context -- must be provided for such instances to work, so this will generally require -- @StandaloneDeriving@ as well. -- --- Ex.: @deriving via PureEq Int instance Applicative m => MEq m Int@ -newtype PureMEq a = PureMEq a +-- Ex.: @deriving via PureEq Int instance Applicative m => EqST m Int@ +newtype PureEqST a = PureEqST a -instance (Applicative m, Eq a) => MEq m (PureMEq a) where - equalsM (PureMEq a) (PureMEq b) = pure (a == b) +instance Eq a => EqST (PureEqST a) where + equalsM (PureEqST a) (PureEqST b) = pure (a == b) diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Class.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Class.hs index 18f721728..6e61adb94 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Class.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/Class.hs @@ -9,6 +9,7 @@ {-# LANGUAGE TypeApplications #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE RankNTypes #-} -- | Abstract key evolving signatures. module Cardano.Crypto.KES.Class @@ -16,6 +17,9 @@ module Cardano.Crypto.KES.Class -- * KES algorithm class KESAlgorithm (..) , KESSignAlgorithm (..) + , genKeyKES + , updateKES + , forgetSignKeyKES , Period , OptimizedKESAlgorithm (..) @@ -49,6 +53,7 @@ module Cardano.Crypto.KES.Class , UnsoundKESSignAlgorithm (..) , encodeSignKeyKES , decodeSignKeyKES + , rawDeserialiseSignKeyKES -- * Utility functions -- These are used between multiple KES implementations. User code will @@ -71,11 +76,14 @@ import GHC.Generics (Generic) import GHC.Stack import GHC.TypeLits (Nat, KnownNat, natVal, TypeError, ErrorMessage (..)) import NoThunks.Class (NoThunks) +import Control.Monad.Class.MonadST (MonadST) +import Control.Monad.Class.MonadThrow (MonadThrow) import Cardano.Binary (Decoder, decodeBytes, Encoding, encodeBytes, Size, withWordSize) import Cardano.Crypto.Util (Empty) -import Cardano.Crypto.MLockedSeed +import Cardano.Crypto.Libsodium.MLockedSeed +import Cardano.Crypto.Libsodium (MLockedAllocator, mlockedMalloc) import Cardano.Crypto.Hash.Class (HashAlgorithm, Hash, hashWith) import Cardano.Crypto.DSIGN.Class (failSizeCheck) @@ -172,58 +180,39 @@ seedSizeKES :: forall v proxy. KESAlgorithm v => proxy v -> Word seedSizeKES _ = fromInteger (natVal (Proxy @(SeedSizeKES v))) -class ( KESAlgorithm v - , Monad m - ) - => KESSignAlgorithm m v where +class KESAlgorithm v => KESSignAlgorithm v where data SignKeyKES v :: Type - deriveVerKeyKES :: SignKeyKES v -> m (VerKeyKES v) + deriveVerKeyKES :: (MonadST m, MonadThrow m) => SignKeyKES v -> m (VerKeyKES v) -- -- Core algorithm operations -- signKES - :: forall a. (Signable v a, HasCallStack) + :: forall a m. (Signable v a, MonadST m, MonadThrow m) => ContextKES v -> Period -- ^ The /current/ period for the key -> a -> SignKeyKES v -> m (SigKES v) - -- | Update the KES signature key to the /next/ period, given the /current/ - -- period. - -- - -- It returns 'Nothing' if the cannot be evolved any further. - -- - -- The precondition (to get a 'Just' result) is that the current KES period - -- of the input key is not the last period. The given period must be the - -- current KES period of the input key (not the next or target). - -- - -- The postcondition is that in case a key is returned, its current KES - -- period is incremented by one compared to before. - -- - -- Note that you must track the current period separately, and to skip to a - -- later period requires repeated use of this function, since it only - -- increments one period at once. - -- - updateKES - :: HasCallStack - => ContextKES v + updateKESWith + :: (MonadST m, MonadThrow m) + => MLockedAllocator m + -> ContextKES v -> SignKeyKES v -> Period -- ^ The /current/ period for the key, not the target period. -> m (Maybe (SignKeyKES v)) - -- - -- Key generation - -- - - genKeyKES - :: MLockedSeed (SeedSizeKES v) + genKeyKESWith + :: (MonadST m, MonadThrow m) + => MLockedAllocator m + -> MLockedSeed (SeedSizeKES v) -> m (SignKeyKES v) + -- -- Secure forgetting -- @@ -234,16 +223,75 @@ class ( KESAlgorithm v -- -- The precondition is that this key value will not be used again. -- - forgetSignKeyKES - :: SignKeyKES v + forgetSignKeyKESWith + :: (MonadST m, MonadThrow m) + => MLockedAllocator m + -> SignKeyKES v -> m () +-- | Forget a signing key synchronously, rather than waiting for GC. In some +-- non-mock instances this provides a guarantee that the signing key is no +-- longer in memory. +-- +-- The precondition is that this key value will not be used again. +-- +forgetSignKeyKES + :: (KESSignAlgorithm v, MonadST m, MonadThrow m) + => SignKeyKES v + -> m () +forgetSignKeyKES = forgetSignKeyKESWith mlockedMalloc + +-- | Key generation +-- +genKeyKES + :: forall v m. (KESSignAlgorithm v, MonadST m, MonadThrow m) + => MLockedSeed (SeedSizeKES v) + -> m (SignKeyKES v) +genKeyKES = genKeyKESWith mlockedMalloc + + +-- | Update the KES signature key to the /next/ period, given the /current/ +-- period. +-- +-- It returns 'Nothing' if the cannot be evolved any further. +-- +-- The precondition (to get a 'Just' result) is that the current KES period +-- of the input key is not the last period. The given period must be the +-- current KES period of the input key (not the next or target). +-- +-- The postcondition is that in case a key is returned, its current KES +-- period is incremented by one compared to before. +-- +-- Note that you must track the current period separately, and to skip to a +-- later period requires repeated use of this function, since it only +-- increments one period at once. +-- +updateKES + :: forall v m. (KESSignAlgorithm v, MonadST m, MonadThrow m) + => ContextKES v + -> SignKeyKES v + -> Period -- ^ The /current/ period for the key, not the target period. + -> m (Maybe (SignKeyKES v)) +updateKES = updateKESWith mlockedMalloc + + -- | Unsound operations on KES sign keys. These operations violate secure -- forgetting constraints by leaking secrets to unprotected memory. Consider -- using the 'DirectSerialise' / 'DirectDeserialise' APIs instead. -class (KESSignAlgorithm m v) => UnsoundKESSignAlgorithm m v where - rawDeserialiseSignKeyKES :: ByteString -> m (Maybe (SignKeyKES v)) - rawSerialiseSignKeyKES :: SignKeyKES v -> m ByteString +class KESSignAlgorithm v => UnsoundKESSignAlgorithm v where + rawDeserialiseSignKeyKESWith :: (MonadST m, MonadThrow m) + => MLockedAllocator m + -> ByteString + -> m (Maybe (SignKeyKES v)) + + rawSerialiseSignKeyKES :: (MonadST m, MonadThrow m) => SignKeyKES v -> m ByteString + +rawDeserialiseSignKeyKES :: + (UnsoundKESSignAlgorithm v, MonadST m, MonadThrow m) + => ByteString + -> m (Maybe (SignKeyKES v)) +rawDeserialiseSignKeyKES = rawDeserialiseSignKeyKESWith mlockedMalloc + -- | Subclass for KES algorithms that embed a copy of the VerKey into the -- signature itself, rather than relying on the externally supplied VerKey @@ -315,7 +363,10 @@ encodeVerKeyKES = encodeBytes . rawSerialiseVerKeyKES encodeSigKES :: KESAlgorithm v => SigKES v -> Encoding encodeSigKES = encodeBytes . rawSerialiseSigKES -encodeSignKeyKES :: forall v m. (UnsoundKESSignAlgorithm m v) => SignKeyKES v -> m Encoding +encodeSignKeyKES :: + forall v m. (UnsoundKESSignAlgorithm v, MonadST m, MonadThrow m) + => SignKeyKES v + -> m Encoding encodeSignKeyKES = fmap encodeBytes . rawSerialiseSignKeyKES decodeVerKeyKES :: forall v s. KESAlgorithm v => Decoder s (VerKeyKES v) @@ -334,7 +385,9 @@ decodeSigKES = do Nothing -> failSizeCheck "decodeSigKES" "signature" bs (sizeSigKES (Proxy :: Proxy v)) {-# INLINE decodeSigKES #-} -decodeSignKeyKES :: forall v s m. (UnsoundKESSignAlgorithm m v) => Decoder s (m (Maybe (SignKeyKES v))) +decodeSignKeyKES :: + forall v s m. (UnsoundKESSignAlgorithm v, MonadST m, MonadThrow m) + => Decoder s (m (Maybe (SignKeyKES v))) decodeSignKeyKES = do bs <- decodeBytes let expected = fromIntegral (sizeSignKeyKES (Proxy @v)) @@ -362,13 +415,13 @@ instance KESAlgorithm v => NoThunks (SignedKES v a) -- use generic instance signedKES - :: (KESSignAlgorithm m v, Signable v a) + :: (KESSignAlgorithm v, Signable v a, MonadST m, MonadThrow m) => ContextKES v -> Period -> a -> SignKeyKES v -> m (SignedKES v a) -signedKES ctxt time a key = SignedKES <$> (signKES ctxt time a key) +signedKES ctxt time a key = SignedKES <$> signKES ctxt time a key verifySignedKES :: (KESAlgorithm v, Signable v a) diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs index 2a58a480b..07cc9a9a9 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs @@ -141,10 +141,10 @@ instance ( DSIGNMAlgorithmBase d off_sig = 0 :: Word off_vk = size_sig -instance ( DSIGNMAlgorithm m d -- needed for secure forgetting +instance ( DSIGNMAlgorithm d -- needed for secure forgetting , KnownNat (SizeSigDSIGNM d + SizeVerKeyDSIGNM d) ) - => KESSignAlgorithm m (CompactSingleKES d) where + => KESSignAlgorithm (CompactSingleKES d) where newtype SignKeyKES (CompactSingleKES d) = SignKeyCompactSingleKES (SignKeyDSIGNM d) deriveVerKeyKES (SignKeyCompactSingleKES v) = @@ -157,19 +157,19 @@ instance ( DSIGNMAlgorithm m d -- needed for secure forgetting assert (t == 0) $ SigCompactSingleKES <$!> signDSIGNM ctxt a sk <*> deriveVerKeyDSIGNM sk - updateKES _ctx (SignKeyCompactSingleKES _sk) _to = return Nothing + updateKESWith _allocator _ctx (SignKeyCompactSingleKES _sk) _to = return Nothing -- -- Key generation -- - genKeyKES seed = SignKeyCompactSingleKES <$!> genKeyDSIGNM seed + genKeyKESWith allocator seed = SignKeyCompactSingleKES <$!> genKeyDSIGNMWith allocator seed -- -- forgetting -- - forgetSignKeyKES (SignKeyCompactSingleKES v) = - forgetSignKeyDSIGNM v + forgetSignKeyKESWith allocator (SignKeyCompactSingleKES v) = + forgetSignKeyDSIGNMWith allocator v instance ( KESAlgorithm (CompactSingleKES d) , DSIGNMAlgorithmBase d @@ -182,10 +182,10 @@ instance ( KESAlgorithm (CompactSingleKES d) assert (t == 0) $ VerKeyCompactSingleKES vk -instance (KESSignAlgorithm m (CompactSingleKES d), UnsoundDSIGNMAlgorithm m d) - => UnsoundKESSignAlgorithm m (CompactSingleKES d) where +instance (KESSignAlgorithm (CompactSingleKES d), UnsoundDSIGNMAlgorithm d) + => UnsoundKESSignAlgorithm (CompactSingleKES d) where rawSerialiseSignKeyKES (SignKeyCompactSingleKES sk) = rawSerialiseSignKeyDSIGNM sk - rawDeserialiseSignKeyKES bs = fmap SignKeyCompactSingleKES <$> rawDeserialiseSignKeyDSIGNM bs + rawDeserialiseSignKeyKESWith allocator bs = fmap SignKeyCompactSingleKES <$> rawDeserialiseSignKeyDSIGNMWith allocator bs -- diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs index bb4075ec4..6f7e247e2 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs @@ -1,6 +1,5 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} @@ -8,7 +7,6 @@ {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} @@ -97,10 +95,8 @@ import Cardano.Crypto.Hash.Class import Cardano.Crypto.KES.Class import Cardano.Crypto.KES.CompactSingle (CompactSingleKES) import Cardano.Crypto.Util -import Cardano.Crypto.MLockedSeed -import qualified Cardano.Crypto.MonadSodium as NaCl -import Control.Monad.Class.MonadST (MonadST) -import Control.Monad.Class.MonadThrow (MonadThrow) +import Cardano.Crypto.Libsodium.MLockedSeed +import Cardano.Crypto.Libsodium import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Control.Monad.Trans (lift) import Control.DeepSeq (NFData (..)) @@ -150,7 +146,7 @@ instance (NFData (SignKeyKES d), NFData (VerKeyKES d)) => rnf (sk, r, vk1, vk2) instance ( OptimizedKESAlgorithm d - , NaCl.SodiumHashAlgorithm h -- needed for secure forgetting + , SodiumHashAlgorithm h -- needed for secure forgetting , SizeHash h ~ SeedSizeKES d -- can be relaxed , NoThunks (VerKeyKES (CompactSumKES h d)) , KnownNat (SizeVerKeyKES (CompactSumKES h d)) @@ -249,18 +245,15 @@ instance ( OptimizedKESAlgorithm d off_vk = size_sig instance ( OptimizedKESAlgorithm d - , KESSignAlgorithm m d - , NaCl.SodiumHashAlgorithm h -- needed for secure forgetting + , KESSignAlgorithm d + , SodiumHashAlgorithm h -- needed for secure forgetting , SizeHash h ~ SeedSizeKES d -- can be relaxed - , NaCl.MonadSodium m - , MonadST m -- only needed for unsafe raw ser/deser - , MonadThrow m , NoThunks (VerKeyKES (CompactSumKES h d)) , KnownNat (SizeVerKeyKES (CompactSumKES h d)) , KnownNat (SizeSignKeyKES (CompactSumKES h d)) , KnownNat (SizeSigKES (CompactSumKES h d)) ) - => KESSignAlgorithm m (CompactSumKES h d) where + => KESSignAlgorithm (CompactSumKES h d) where -- | From Figure 3: @(sk_0, r_1, vk_0, vk_1)@ -- data SignKeyKES (CompactSumKES h d) = @@ -284,22 +277,22 @@ instance ( OptimizedKESAlgorithm d _T = totalPeriodsKES (Proxy :: Proxy d) - {-# NOINLINE updateKES #-} - updateKES ctx (SignKeyCompactSumKES sk r_1 vk_0 vk_1) t + {-# NOINLINE updateKESWith #-} + updateKESWith allocator ctx (SignKeyCompactSumKES sk r_1 vk_0 vk_1) t | t+1 < _T = runMaybeT $! do - sk' <- MaybeT $! updateKES ctx sk t - r_1' <- lift $! mlockedSeedCopy r_1 + sk' <- MaybeT $! updateKESWith allocator ctx sk t + r_1' <- lift $! mlockedSeedCopyWith allocator r_1 return $! SignKeyCompactSumKES sk' r_1' vk_0 vk_1 | t+1 == _T = do - sk' <- genKeyKES r_1 - zero <- mlockedSeedNewZero + sk' <- genKeyKESWith allocator r_1 + zero <- mlockedSeedNewZeroWith allocator return $! Just $! SignKeyCompactSumKES sk' zero vk_0 vk_1 | otherwise = runMaybeT $! do - sk' <- MaybeT $! updateKES ctx sk (t - _T) - r_1' <- lift $! mlockedSeedCopy r_1 + sk' <- MaybeT $! updateKESWith allocator ctx sk (t - _T) + r_1' <- lift $! mlockedSeedCopyWith allocator r_1 return $! SignKeyCompactSumKES sk' r_1' vk_0 vk_1 where _T = totalPeriodsKES (Proxy :: Proxy d) @@ -308,14 +301,14 @@ instance ( OptimizedKESAlgorithm d -- Key generation -- - {-# NOINLINE genKeyKES #-} - genKeyKES r = do - (r0raw, r1raw) <- NaCl.expandHash (Proxy :: Proxy h) (mlockedSeedMLSB r) + {-# NOINLINE genKeyKESWith #-} + genKeyKESWith allocator r = do + (r0raw, r1raw) <- expandHashWith allocator (Proxy :: Proxy h) (mlockedSeedMLSB r) let r0 = MLockedSeed r0raw r1 = MLockedSeed r1raw - sk_0 <- genKeyKES r0 + sk_0 <- genKeyKESWith allocator r0 vk_0 <- deriveVerKeyKES sk_0 - sk_1 <- genKeyKES r1 + sk_1 <- genKeyKESWith allocator r1 vk_1 <- deriveVerKeyKES sk_1 forgetSignKeyKES sk_1 mlockedSeedFinalize r0 @@ -324,15 +317,13 @@ instance ( OptimizedKESAlgorithm d -- -- forgetting -- - forgetSignKeyKES (SignKeyCompactSumKES sk_0 r1 _ _) = do - forgetSignKeyKES sk_0 + forgetSignKeyKESWith allocator (SignKeyCompactSumKES sk_0 r1 _ _) = do + forgetSignKeyKESWith allocator sk_0 mlockedSeedFinalize r1 -instance ( KESSignAlgorithm m (CompactSumKES h d) - , UnsoundKESSignAlgorithm m d - , NaCl.MonadSodium m - , MonadST m - ) => UnsoundKESSignAlgorithm m (CompactSumKES h d) where +instance ( KESSignAlgorithm (CompactSumKES h d) + , UnsoundKESSignAlgorithm d + ) => UnsoundKESSignAlgorithm (CompactSumKES h d) where -- -- Raw serialise/deserialise - dangerous, do not use in production code. -- @@ -340,7 +331,7 @@ instance ( KESSignAlgorithm m (CompactSumKES h d) {-# NOINLINE rawSerialiseSignKeyKES #-} rawSerialiseSignKeyKES (SignKeyCompactSumKES sk r_1 vk_0 vk_1) = do ssk <- rawSerialiseSignKeyKES sk - sr1 <- NaCl.mlsbToByteString . mlockedSeedMLSB $ r_1 + sr1 <- mlsbToByteString . mlockedSeedMLSB $ r_1 return $ mconcat [ ssk , sr1 @@ -348,11 +339,11 @@ instance ( KESSignAlgorithm m (CompactSumKES h d) , rawSerialiseVerKeyKES vk_1 ] - {-# NOINLINE rawDeserialiseSignKeyKES #-} - rawDeserialiseSignKeyKES b = runMaybeT $ do + {-# NOINLINE rawDeserialiseSignKeyKESWith #-} + rawDeserialiseSignKeyKESWith allocator b = runMaybeT $ do guard (BS.length b == fromIntegral size_total) - sk <- MaybeT $ rawDeserialiseSignKeyKES b_sk - r <- MaybeT $ NaCl.mlsbFromByteStringCheck b_r + sk <- MaybeT $ rawDeserialiseSignKeyKESWith allocator b_sk + r <- MaybeT $ mlsbFromByteStringCheckWith allocator b_r vk_0 <- MaybeT . return $ rawDeserialiseVerKeyKES b_vk0 vk_1 <- MaybeT . return $ rawDeserialiseVerKeyKES b_vk1 return (SignKeyCompactSumKES sk (MLockedSeed r) vk_0 vk_1) @@ -406,7 +397,7 @@ deriving via OnlyCheckWhnfNamed "SignKeyKES (CompactSumKES h d)" (SignKeyKES (Co instance (KESAlgorithm d) => NoThunks (VerKeyKES (CompactSumKES h d)) instance ( OptimizedKESAlgorithm d - , NaCl.SodiumHashAlgorithm h + , SodiumHashAlgorithm h , SizeHash h ~ SeedSizeKES d , NoThunks (VerKeyKES (CompactSumKES h d)) , KnownNat (SizeVerKeyKES (CompactSumKES h d)) @@ -418,7 +409,7 @@ instance ( OptimizedKESAlgorithm d encodedSizeExpr _size = encodedVerKeyKESSizeExpr instance ( OptimizedKESAlgorithm d - , NaCl.SodiumHashAlgorithm h + , SodiumHashAlgorithm h , SizeHash h ~ SeedSizeKES d , NoThunks (VerKeyKES (CompactSumKES h d)) , KnownNat (SizeVerKeyKES (CompactSumKES h d)) @@ -458,7 +449,7 @@ deriving instance KESAlgorithm d => Eq (SigKES (CompactSumKES h d)) instance KESAlgorithm d => NoThunks (SigKES (CompactSumKES h d)) instance ( OptimizedKESAlgorithm d - , NaCl.SodiumHashAlgorithm h + , SodiumHashAlgorithm h , SizeHash h ~ SeedSizeKES d , NoThunks (VerKeyKES (CompactSumKES h d)) , KnownNat (SizeVerKeyKES (CompactSumKES h d)) @@ -470,7 +461,7 @@ instance ( OptimizedKESAlgorithm d encodedSizeExpr _size = encodedSigKESSizeExpr instance ( OptimizedKESAlgorithm d - , NaCl.SodiumHashAlgorithm h + , SodiumHashAlgorithm h , SizeHash h ~ SeedSizeKES d , NoThunks (VerKeyKES (CompactSumKES h d)) , KnownNat (SizeVerKeyKES (CompactSumKES h d)) diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs index 17c8e9cac..ed0d7480d 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs @@ -33,8 +33,10 @@ import Cardano.Crypto.Hash import Cardano.Crypto.Seed import Cardano.Crypto.KES.Class import Cardano.Crypto.Util -import Cardano.Crypto.MLockedSeed -import Cardano.Crypto.MonadSodium (mlsbAsByteString) +import Cardano.Crypto.Libsodium.MLockedSeed +import Cardano.Crypto.Libsodium + ( mlsbAsByteString + ) data MockKES (t :: Nat) @@ -122,7 +124,7 @@ instance KnownNat t => KESAlgorithm (MockKES t) where | otherwise = Nothing -instance (Monad m, KnownNat t) => KESSignAlgorithm m (MockKES t) where +instance KnownNat t => KESSignAlgorithm (MockKES t) where data SignKeyKES (MockKES t) = SignKeyMockKES !(VerKeyKES (MockKES t)) !Period deriving stock (Show, Eq, Generic) @@ -130,11 +132,11 @@ instance (Monad m, KnownNat t) => KESSignAlgorithm m (MockKES t) where deriveVerKeyKES (SignKeyMockKES vk _) = return $! vk - updateKES () (SignKeyMockKES vk t') t = + updateKESWith _allocator () (SignKeyMockKES vk t') t = assert (t == t') $! if t+1 < totalPeriodsKES (Proxy @(MockKES t)) then return $! Just $! SignKeyMockKES vk (t+1) - else return $! Nothing + else return Nothing -- | Produce valid signature only with correct key, i.e., same iteration and -- allowed KES period. @@ -148,17 +150,17 @@ instance (Monad m, KnownNat t) => KESSignAlgorithm m (MockKES t) where -- Key generation -- - genKeyKES seed = do + genKeyKESWith _allocator seed = do let vk = VerKeyMockKES (runMonadRandomWithSeed (mkSeedFromBytes . mlsbAsByteString . mlockedSeedMLSB $ seed) getRandomWord64) return $! SignKeyMockKES vk 0 - forgetSignKeyKES = const $ return () + forgetSignKeyKESWith _ = const $ return () -instance (Monad m, KnownNat t) => UnsoundKESSignAlgorithm m (MockKES t) where +instance KnownNat t => UnsoundKESSignAlgorithm (MockKES t) where rawSerialiseSignKeyKES sk = return $ rawSerialiseSignKeyMockKES sk - rawDeserialiseSignKeyKES bs = + rawDeserialiseSignKeyKESWith _alloc bs = return $ rawDeserialiseSignKeyMockKES bs rawDeserialiseSignKeyMockKES :: KnownNat t diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/NeverUsed.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/NeverUsed.hs index 40f4bc74f..8aaf910ab 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/NeverUsed.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/NeverUsed.hs @@ -49,20 +49,20 @@ instance KESAlgorithm NeverKES where rawDeserialiseVerKeyKES _ = Just NeverUsedVerKeyKES rawDeserialiseSigKES _ = Just NeverUsedSigKES -instance Monad m => KESSignAlgorithm m NeverKES where +instance KESSignAlgorithm NeverKES where data SignKeyKES NeverKES = NeverUsedSignKeyKES deriving (Show, Eq, Generic, NoThunks) - deriveVerKeyKES _ = return $! NeverUsedVerKeyKES + deriveVerKeyKES _ = return NeverUsedVerKeyKES signKES = error "KES not available" - updateKES = error "KES not available" + updateKESWith _ = error "KES not available" - genKeyKES _ = return $! NeverUsedSignKeyKES + genKeyKESWith _ _ = return NeverUsedSignKeyKES - forgetSignKeyKES = const $ return () + forgetSignKeyKESWith _ = const $ return () -instance Monad m => UnsoundKESSignAlgorithm m NeverKES where +instance UnsoundKESSignAlgorithm NeverKES where rawSerialiseSignKeyKES _ = return mempty - rawDeserialiseSignKeyKES _ = return $ Just NeverUsedSignKeyKES + rawDeserialiseSignKeyKESWith _ _ = return $ Just NeverUsedSignKeyKES diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs index 1ace81793..c40bcffc1 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs @@ -33,19 +33,17 @@ import GHC.Generics (Generic) import GHC.TypeNats (Nat, KnownNat, natVal, type (*)) import NoThunks.Class (NoThunks) import Control.Monad.Trans.Maybe -import Control.Monad.Class.MonadThrow (MonadEvaluate) -import Control.Monad.Class.MonadST (MonadST) import Control.Monad ( (<$!>) ) import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Cardano.Crypto.DSIGN import Cardano.Crypto.KES.Class -import Cardano.Crypto.MLockedSeed +import Cardano.Crypto.Libsodium.MLockedSeed import Cardano.Crypto.Libsodium.MLockedBytes import Cardano.Crypto.Util import Data.Unit.Strict (forceElemsToWHNF) -import Cardano.Crypto.MonadSodium (MonadSodium (..), MEq (..)) +import Cardano.Crypto.EqST (EqST (..)) data SimpleKES d (t :: Nat) @@ -144,14 +142,11 @@ instance ( DSIGNMAlgorithmBase d instance ( KESAlgorithm (SimpleKES d t) - , DSIGNMAlgorithm m d + , DSIGNMAlgorithm d , KnownNat t , KnownNat (SeedSizeDSIGNM d * t) - , MonadEvaluate m - , MonadSodium m - , MonadST m ) => - KESSignAlgorithm m (SimpleKES d t) where + KESSignAlgorithm (SimpleKES d t) where newtype SignKeyKES (SimpleKES d t) = ThunkySignKeySimpleKES (Vector (SignKeyDSIGNM d)) deriving Generic @@ -166,9 +161,9 @@ instance ( KESAlgorithm (SimpleKES d t) Nothing -> error ("SimpleKES.signKES: period out of range " ++ show j) Just sk -> SigSimpleKES <$!> (signDSIGNM ctxt a $! sk) - updateKES _ (ThunkySignKeySimpleKES sk) t + updateKESWith allocator _ (ThunkySignKeySimpleKES sk) t | t+1 < fromIntegral (natVal (Proxy @t)) = do - sk' <- Vec.mapM cloneKeyDSIGNM sk + sk' <- Vec.mapM (cloneKeyDSIGNMWith allocator) sk return $! Just $! SignKeySimpleKES sk' | otherwise = return Nothing @@ -177,24 +172,25 @@ instance ( KESAlgorithm (SimpleKES d t) -- Key generation -- - genKeyKES (MLockedSeed mlsb) = do + genKeyKESWith allocator (MLockedSeed mlsb) = do let seedSize = seedSizeDSIGNM (Proxy :: Proxy d) duration = fromIntegral (natVal (Proxy @t)) sks <- Vec.generateM duration $ \t -> do withMLSBChunk mlsb (fromIntegral t * fromIntegral seedSize) $ \mlsb' -> do - genKeyDSIGNM (MLockedSeed mlsb') + genKeyDSIGNMWith allocator (MLockedSeed mlsb') return $! SignKeySimpleKES sks -- -- Forgetting -- - forgetSignKeyKES (SignKeySimpleKES sks) = Vec.mapM_ forgetSignKeyDSIGNM sks + forgetSignKeyKESWith allocator (SignKeySimpleKES sks) = + Vec.mapM_ (forgetSignKeyDSIGNMWith allocator) sks -instance ( UnsoundDSIGNMAlgorithm m d, KnownNat t, KESSignAlgorithm m (SimpleKES d t)) - => UnsoundKESSignAlgorithm m (SimpleKES d t) where +instance ( UnsoundDSIGNMAlgorithm d, KnownNat t, KESSignAlgorithm (SimpleKES d t)) + => UnsoundKESSignAlgorithm (SimpleKES d t) where -- -- raw serialise/deserialise -- @@ -203,13 +199,13 @@ instance ( UnsoundDSIGNMAlgorithm m d, KnownNat t, KESSignAlgorithm m (SimpleKES BS.concat <$!> mapM rawSerialiseSignKeyDSIGNM (Vec.toList sks) - rawDeserialiseSignKeyKES bs + rawDeserialiseSignKeyKESWith allocator bs | let duration = fromIntegral (natVal (Proxy :: Proxy t)) sizeKey = fromIntegral (sizeSignKeyDSIGNM (Proxy :: Proxy d)) , skbs <- splitsAt (replicate duration sizeKey) bs , length skbs == duration = runMaybeT $ do - sks <- mapM (MaybeT . rawDeserialiseSignKeyDSIGNM) skbs + sks <- mapM (MaybeT . rawDeserialiseSignKeyDSIGNMWith allocator) skbs return $! SignKeySimpleKES (Vec.fromList sks) | otherwise @@ -222,7 +218,7 @@ deriving instance DSIGNMAlgorithmBase d => Show (SigKES (SimpleKES d t)) deriving instance DSIGNMAlgorithmBase d => Eq (VerKeyKES (SimpleKES d t)) deriving instance DSIGNMAlgorithmBase d => Eq (SigKES (SimpleKES d t)) -instance (Monad m, MEq m (SignKeyDSIGNM d)) => MEq m (SignKeyKES (SimpleKES d t)) where +instance EqST (SignKeyDSIGNM d) => EqST (SignKeyKES (SimpleKES d t)) where equalsM (ThunkySignKeySimpleKES a) (ThunkySignKeySimpleKES b) = -- No need to check that lengths agree, the types already guarantee this. Vec.and <$> Vec.zipWithM equalsM a b diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs index 85045adce..c2c8aced2 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs @@ -111,8 +111,7 @@ instance (DSIGNMAlgorithmBase d) => KESAlgorithm (SingleKES d) where {-# INLINE rawDeserialiseSigKES #-} -instance ( DSIGNMAlgorithm m d -- needed for secure forgetting - ) => KESSignAlgorithm m (SingleKES d) where +instance DSIGNMAlgorithm d => KESSignAlgorithm (SingleKES d) where newtype SignKeyKES (SingleKES d) = SignKeySingleKES (SignKeyDSIGNM d) deriveVerKeyKES (SignKeySingleKES v) = @@ -126,27 +125,28 @@ instance ( DSIGNMAlgorithm m d -- needed for secure forgetting assert (t == 0) $! SigSingleKES <$!> signDSIGNM ctxt a sk - updateKES _ctx (SignKeySingleKES _sk) _to = return Nothing + updateKESWith _allocator _ctx (SignKeySingleKES _sk) _to = return Nothing -- -- Key generation -- - genKeyKES seed = SignKeySingleKES <$!> genKeyDSIGNM seed + genKeyKESWith allocator seed = + SignKeySingleKES <$!> genKeyDSIGNMWith allocator seed -- -- forgetting -- - forgetSignKeyKES (SignKeySingleKES v) = - forgetSignKeyDSIGNM v + forgetSignKeyKESWith allocator (SignKeySingleKES v) = + forgetSignKeyDSIGNMWith allocator v -instance (KESSignAlgorithm m (SingleKES d), UnsoundDSIGNMAlgorithm m d) - => UnsoundKESSignAlgorithm m (SingleKES d) where +instance (KESSignAlgorithm (SingleKES d), UnsoundDSIGNMAlgorithm d) + => UnsoundKESSignAlgorithm (SingleKES d) where rawSerialiseSignKeyKES (SignKeySingleKES sk) = rawSerialiseSignKeyDSIGNM sk - rawDeserialiseSignKeyKES bs = - fmap SignKeySingleKES <$> rawDeserialiseSignKeyDSIGNM bs + rawDeserialiseSignKeyKESWith allocator bs = + fmap SignKeySingleKES <$> rawDeserialiseSignKeyDSIGNMWith allocator bs -- -- VerKey instances diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs index ff0381c1b..23de3f54b 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs @@ -63,14 +63,13 @@ import Cardano.Crypto.Hash.Class import Cardano.Crypto.KES.Class import Cardano.Crypto.KES.Single (SingleKES) import Cardano.Crypto.Util -import Cardano.Crypto.MLockedSeed -import qualified Cardano.Crypto.MonadSodium as NaCl -import Control.Monad.Class.MonadST (MonadST) -import Control.Monad.Class.MonadThrow (MonadThrow) +import Cardano.Crypto.Libsodium.MLockedSeed +import Cardano.Crypto.Libsodium import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Control.DeepSeq (NFData (..)) import GHC.TypeLits (KnownNat, type (+), type (*)) + -- | A 2^0 period KES type Sum0KES d = SingleKES d @@ -115,7 +114,7 @@ instance (NFData (SignKeyKES d), NFData (VerKeyKES d)) => rnf (sk, r, vk1, vk2) instance ( KESAlgorithm d - , NaCl.SodiumHashAlgorithm h -- needed for secure forgetting + , SodiumHashAlgorithm h -- needed for secure forgetting , SizeHash h ~ SeedSizeKES d -- can be relaxed , KnownNat ((SizeSignKeyKES d + SeedSizeKES d) + (2 * SizeVerKeyKES d)) , KnownNat (SizeSigKES d + (SizeVerKeyKES d * 2)) @@ -221,16 +220,13 @@ instance ( KESAlgorithm d off_vk1 = off_vk0 + size_vk {-# INLINEABLE rawDeserialiseSigKES #-} -instance ( KESSignAlgorithm m d - , NaCl.SodiumHashAlgorithm h -- needed for secure forgetting +instance ( KESSignAlgorithm d + , SodiumHashAlgorithm h -- needed for secure forgetting , SizeHash h ~ SeedSizeKES d -- can be relaxed - , NaCl.MonadSodium m - , MonadST m -- only needed for unsafe raw ser/deser - , MonadThrow m , KnownNat ((SizeSignKeyKES d + SeedSizeKES d) + (2 * SizeVerKeyKES d)) , KnownNat (SizeSigKES d + (SizeVerKeyKES d * 2)) ) - => KESSignAlgorithm m (SumKES h d) where + => KESSignAlgorithm (SumKES h d) where -- | From Figure 3: @(sk_0, r_1, vk_0, vk_1)@ -- data SignKeyKES (SumKES h d) = @@ -253,21 +249,21 @@ instance ( KESSignAlgorithm m d _T = totalPeriodsKES (Proxy :: Proxy d) - {-# NOINLINE updateKES #-} - updateKES ctx (SignKeySumKES sk r_1 vk_0 vk_1) t + {-# NOINLINE updateKESWith #-} + updateKESWith allocator ctx (SignKeySumKES sk r_1 vk_0 vk_1) t | t+1 < _T = runMaybeT $! do - sk' <- MaybeT $! updateKES ctx sk t + sk' <- MaybeT $! updateKESWith allocator ctx sk t r_1' <- MaybeT $! Just <$!> mlockedSeedCopy r_1 return $! SignKeySumKES sk' r_1' vk_0 vk_1 | t+1 == _T = do - sk' <- genKeyKES r_1 - r_1' <- mlockedSeedNewZero + sk' <- genKeyKESWith allocator r_1 + r_1' <- mlockedSeedNewZeroWith allocator return $! Just $! SignKeySumKES sk' r_1' vk_0 vk_1 | otherwise = runMaybeT $ do - sk' <- MaybeT $! updateKES ctx sk (t - _T) - r_1' <- MaybeT $! Just <$!> mlockedSeedCopy r_1 + sk' <- MaybeT $! updateKESWith allocator ctx sk (t - _T) + r_1' <- MaybeT $! Just <$!> mlockedSeedCopyWith allocator r_1 return $! SignKeySumKES sk' r_1' vk_0 vk_1 where _T = totalPeriodsKES (Proxy :: Proxy d) @@ -276,14 +272,14 @@ instance ( KESSignAlgorithm m d -- Key generation -- - {-# NOINLINE genKeyKES #-} - genKeyKES r = do - (r0raw, r1raw) <- NaCl.expandHash (Proxy :: Proxy h) (mlockedSeedMLSB r) + {-# NOINLINE genKeyKESWith #-} + genKeyKESWith allocator r = do + (r0raw, r1raw) <- expandHashWith allocator (Proxy :: Proxy h) (mlockedSeedMLSB r) let r0 = MLockedSeed r0raw r1 = MLockedSeed r1raw - sk_0 <- genKeyKES r0 + sk_0 <- genKeyKESWith allocator r0 vk_0 <- deriveVerKeyKES sk_0 - sk_1 <- genKeyKES r1 + sk_1 <- genKeyKESWith allocator r1 vk_1 <- deriveVerKeyKES sk_1 forgetSignKeyKES sk_1 mlockedSeedFinalize r0 @@ -292,15 +288,13 @@ instance ( KESSignAlgorithm m d -- -- forgetting -- - forgetSignKeyKES (SignKeySumKES sk_0 r1 _ _) = do - forgetSignKeyKES sk_0 + forgetSignKeyKESWith allocator (SignKeySumKES sk_0 r1 _ _) = do + forgetSignKeyKESWith allocator sk_0 mlockedSeedFinalize r1 -instance ( KESSignAlgorithm m (SumKES h d) - , UnsoundKESSignAlgorithm m d - , NaCl.MonadSodium m - , MonadST m - ) => UnsoundKESSignAlgorithm m (SumKES h d) where +instance ( KESSignAlgorithm (SumKES h d) + , UnsoundKESSignAlgorithm d + ) => UnsoundKESSignAlgorithm (SumKES h d) where -- -- Raw serialise/deserialise - dangerous, do not use in production code. -- @@ -308,7 +302,7 @@ instance ( KESSignAlgorithm m (SumKES h d) {-# NOINLINE rawSerialiseSignKeyKES #-} rawSerialiseSignKeyKES (SignKeySumKES sk r_1 vk_0 vk_1) = do ssk <- rawSerialiseSignKeyKES sk - sr1 <- NaCl.mlsbToByteString . mlockedSeedMLSB $ r_1 + sr1 <- mlsbToByteString . mlockedSeedMLSB $ r_1 return $ mconcat [ ssk , sr1 @@ -316,11 +310,11 @@ instance ( KESSignAlgorithm m (SumKES h d) , rawSerialiseVerKeyKES vk_1 ] - {-# NOINLINE rawDeserialiseSignKeyKES #-} - rawDeserialiseSignKeyKES b = runMaybeT $ do + {-# NOINLINE rawDeserialiseSignKeyKESWith #-} + rawDeserialiseSignKeyKESWith allocator b = runMaybeT $ do guard (BS.length b == fromIntegral size_total) - sk <- MaybeT $ rawDeserialiseSignKeyKES b_sk - r <- MaybeT $ NaCl.mlsbFromByteStringCheck b_r + sk <- MaybeT $ rawDeserialiseSignKeyKESWith allocator b_sk + r <- MaybeT $ mlsbFromByteStringCheckWith allocator b_r vk_0 <- MaybeT . return $ rawDeserialiseVerKeyKES b_vk0 vk_1 <- MaybeT . return $ rawDeserialiseVerKeyKES b_vk1 return (SignKeySumKES sk (MLockedSeed r) vk_0 vk_1) @@ -348,12 +342,12 @@ instance ( KESSignAlgorithm m (SumKES h d) deriving instance HashAlgorithm h => Show (VerKeyKES (SumKES h d)) deriving instance Eq (VerKeyKES (SumKES h d)) -instance (KESAlgorithm (SumKES h d), NaCl.SodiumHashAlgorithm h, SizeHash h ~ SeedSizeKES d) +instance (KESAlgorithm (SumKES h d), SodiumHashAlgorithm h, SizeHash h ~ SeedSizeKES d) => ToCBOR (VerKeyKES (SumKES h d)) where toCBOR = encodeVerKeyKES encodedSizeExpr _size = encodedVerKeyKESSizeExpr -instance (KESAlgorithm (SumKES h d), NaCl.SodiumHashAlgorithm h, SizeHash h ~ SeedSizeKES d) +instance (KESAlgorithm (SumKES h d), SodiumHashAlgorithm h, SizeHash h ~ SeedSizeKES d) => FromCBOR (VerKeyKES (SumKES h d)) where fromCBOR = decodeVerKeyKES {-# INLINE fromCBOR #-} @@ -388,12 +382,12 @@ deriving instance (KESAlgorithm d, KESAlgorithm (SumKES h d)) => Eq (SigKES (Sum instance KESAlgorithm d => NoThunks (SigKES (SumKES h d)) -instance (KESAlgorithm (SumKES h d), NaCl.SodiumHashAlgorithm h, SizeHash h ~ SeedSizeKES d) +instance (KESAlgorithm (SumKES h d), SodiumHashAlgorithm h, SizeHash h ~ SeedSizeKES d) => ToCBOR (SigKES (SumKES h d)) where toCBOR = encodeSigKES encodedSizeExpr _size = encodedSigKESSizeExpr -instance (KESAlgorithm (SumKES h d), NaCl.SodiumHashAlgorithm h, SizeHash h ~ SeedSizeKES d) +instance (KESAlgorithm (SumKES h d), SodiumHashAlgorithm h, SizeHash h ~ SeedSizeKES d) => FromCBOR (SigKES (SumKES h d)) where fromCBOR = decodeSigKES {-# INLINE fromCBOR #-} diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium.hs index 0201f7fc7..eaad15d05 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium.hs @@ -1,26 +1,48 @@ module Cardano.Crypto.Libsodium ( -- * Initialization sodiumInit, + -- * MLocked memory management MLockedForeignPtr, - withMLockedForeignPtr, - mlockedAllocForeignPtr, + MLockedAllocator, + finalizeMLockedForeignPtr, + mlockedAllocForeignPtr, + mlockedMalloc, traceMLockedForeignPtr, - -- * MLocked bytes + withMLockedForeignPtr, + + -- * MLocked bytes ('MLockedSizedBytes') MLockedSizedBytes, + + mlsbAsByteString, + mlsbCompare, + mlsbCopy, + mlsbCopyWith, + mlsbEq, + mlsbFinalize, mlsbFromByteString, mlsbFromByteStringCheck, - mlsbAsByteString, + mlsbFromByteStringCheckWith, + mlsbFromByteStringWith, + mlsbNew, + mlsbNewWith, + mlsbNewZero, + mlsbNewZeroWith, mlsbToByteString, - mlsbFinalize, - mlsbCopy, + mlsbUseAsCPtr, + mlsbUseAsSizedPtr, + mlsbZero, + -- * Hashing - SodiumHashAlgorithm (..), - digestMLockedStorable, digestMLockedBS, + digestMLockedStorable, expandHash, + expandHashWith, + SodiumHashAlgorithm (..), ) where import Cardano.Crypto.Libsodium.Init -import Cardano.Crypto.MonadSodium +import Cardano.Crypto.Libsodium.Memory +import Cardano.Crypto.Libsodium.Hash +import Cardano.Crypto.Libsodium.MLockedBytes diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Hash.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Hash.hs index fc9bd8073..87d89cf50 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Hash.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Hash.hs @@ -9,6 +9,7 @@ module Cardano.Crypto.Libsodium.Hash ( digestMLockedStorable, digestMLockedBS, expandHash, + expandHashWith, ) where import Data.Proxy (Proxy (..)) @@ -19,10 +20,9 @@ import Data.Word (Word8) import GHC.TypeLits import Cardano.Crypto.Hash (HashAlgorithm(SizeHash)) +import Cardano.Crypto.Libsodium.Memory import Cardano.Crypto.Libsodium.Hash.Class import Cardano.Crypto.Libsodium.MLockedBytes.Internal -import Cardano.Crypto.MonadSodium.Class -import Cardano.Crypto.MonadSodium.Alloc import Control.Monad.Class.MonadST (MonadST (..)) import Control.Monad.Class.MonadThrow (MonadThrow) import Control.Monad.ST.Unsafe (unsafeIOToST) @@ -33,19 +33,28 @@ import Control.Monad.ST.Unsafe (unsafeIOToST) expandHash :: forall h m proxy. - (SodiumHashAlgorithm h, MonadSodium m, MonadST m, MonadThrow m) + (SodiumHashAlgorithm h, MonadST m, MonadThrow m) => proxy h -> MLockedSizedBytes (SizeHash h) -> m (MLockedSizedBytes (SizeHash h), MLockedSizedBytes (SizeHash h)) -expandHash h (MLSB sfptr) = do +expandHash = expandHashWith mlockedMalloc + +expandHashWith + :: forall h m proxy. + (SodiumHashAlgorithm h, MonadST m, MonadThrow m) + => MLockedAllocator m + -> proxy h + -> MLockedSizedBytes (SizeHash h) + -> m (MLockedSizedBytes (SizeHash h), MLockedSizedBytes (SizeHash h)) +expandHashWith allocator h (MLSB sfptr) = do withMLockedForeignPtr sfptr $ \ptr -> do - l <- mlockedAlloca size1 $ \ptr' -> do + l <- mlockedAllocaWith allocator size1 $ \ptr' -> do withLiftST $ \liftST -> liftST . unsafeIOToST $ do poke ptr' (1 :: Word8) copyMem (castPtr (plusPtr ptr' 1)) ptr size naclDigestPtr h ptr' (fromIntegral size1) - r <- mlockedAlloca size1 $ \ptr' -> do + r <- mlockedAllocaWith allocator size1 $ \ptr' -> do withLiftST $ \liftST -> liftST . unsafeIOToST $ do poke ptr' (2 :: Word8) copyMem (castPtr (plusPtr ptr' 1)) ptr size diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes.hs index 48ac366d4..a08391552 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes.hs @@ -17,6 +17,12 @@ module Cardano.Crypto.Libsodium.MLockedBytes ( traceMLSB, mlsbCompare, mlsbEq, + + mlsbNewWith, + mlsbNewZeroWith, + mlsbCopyWith, + mlsbFromByteStringWith, + mlsbFromByteStringCheckWith, ) where import Cardano.Crypto.Libsodium.MLockedBytes.Internal diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes/Internal.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes/Internal.hs index 69c03f2c6..1d50ac25f 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes/Internal.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes/Internal.hs @@ -1,12 +1,13 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} -{-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} {-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RankNTypes #-} + module Cardano.Crypto.Libsodium.MLockedBytes.Internal ( -- * The MLockesSizedBytes type MLockedSizedBytes (..), @@ -25,12 +26,18 @@ module Cardano.Crypto.Libsodium.MLockedBytes.Internal ( withMLSB, withMLSBChunk, + mlsbNewWith, + mlsbNewZeroWith, + mlsbCopyWith, + -- * Dangerous Functions traceMLSB, mlsbFromByteString, mlsbFromByteStringCheck, mlsbAsByteString, mlsbToByteString, + mlsbFromByteStringWith, + mlsbFromByteStringCheckWith, ) where import Control.DeepSeq (NFData (..)) @@ -45,11 +52,10 @@ import GHC.TypeLits (KnownNat, Nat, natVal) import NoThunks.Class (NoThunks) import Cardano.Foreign -import Cardano.Crypto.MonadSodium.Class -import Cardano.Crypto.MonadSodium.Alloc +import Cardano.Crypto.Libsodium.Memory import Cardano.Crypto.Libsodium.Memory.Internal (MLockedForeignPtr (..)) import Cardano.Crypto.Libsodium.C -import Cardano.Crypto.MEqOrd +import Cardano.Crypto.EqST import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BSI @@ -78,7 +84,7 @@ instance KnownNat n => Show (MLockedSizedBytes n) where -- hexstr = concatMap (printf "%02x") bytes -- in "MLSB " ++ hexstr -instance (MonadSodium m, MonadST m, KnownNat n) => MEq m (MLockedSizedBytes n) where +instance KnownNat n => EqST (MLockedSizedBytes n) where equalsM = mlsbEq nextPowerOf2 :: forall n. (Num n, Ord n, Bits n) => n -> n @@ -94,11 +100,11 @@ traceMLSB :: KnownNat n => MLockedSizedBytes n -> IO () traceMLSB = print {-# DEPRECATED traceMLSB "Don't leave traceMLockedForeignPtr in production" #-} -withMLSB :: forall b n m. (MonadSodium m) => MLockedSizedBytes n -> (Ptr (SizedVoid n) -> m b) -> m b +withMLSB :: forall b n m. (MonadST m) => MLockedSizedBytes n -> (Ptr (SizedVoid n) -> m b) -> m b withMLSB (MLSB fptr) action = withMLockedForeignPtr fptr action withMLSBChunk :: forall b n n' m. - (MonadSodium m, MonadST m, KnownNat n, KnownNat n') + (MonadST m, KnownNat n, KnownNat n') => MLockedSizedBytes n -> Int -> (MLockedSizedBytes n' -> m b) @@ -123,9 +129,12 @@ mlsbSize mlsb = fromInteger (natVal mlsb) -- | Allocate a new 'MLockedSizedBytes'. The caller is responsible for -- deallocating it ('mlsbFinalize') when done with it. The contents of the -- memory block is undefined. -mlsbNew :: forall n m. (KnownNat n, MonadSodium m) => m (MLockedSizedBytes n) -mlsbNew = - MLSB <$> mlockedAllocForeignPtrBytes size align +mlsbNew :: forall n m. (KnownNat n, MonadST m) => m (MLockedSizedBytes n) +mlsbNew = mlsbNewWith mlockedMalloc + +mlsbNewWith :: forall n m. MLockedAllocator m -> (KnownNat n, MonadST m) => m (MLockedSizedBytes n) +mlsbNewWith allocator = + MLSB <$> mlockedAllocForeignPtrBytesWith allocator size align where size = fromInteger (natVal (Proxy @n)) align = nextPowerOf2 size @@ -133,21 +142,33 @@ mlsbNew = -- | Allocate a new 'MLockedSizedBytes', and pre-fill it with zeroes. -- The caller is responsible for deallocating it ('mlsbFinalize') when done -- with it. (See also 'mlsbNew'). -mlsbNewZero :: forall n m. (KnownNat n, MonadSodium m) => m (MLockedSizedBytes n) -mlsbNewZero = do - mlsb <- mlsbNew +mlsbNewZero :: forall n m. (KnownNat n, MonadST m) => m (MLockedSizedBytes n) +mlsbNewZero = mlsbNewZeroWith mlockedMalloc + +mlsbNewZeroWith :: forall n m. (KnownNat n, MonadST m) => MLockedAllocator m -> m (MLockedSizedBytes n) +mlsbNewZeroWith allocator = do + mlsb <- mlsbNewWith allocator mlsbZero mlsb return mlsb -- | Overwrite an existing 'MLockedSizedBytes' with zeroes. -mlsbZero :: forall n m. (KnownNat n, MonadSodium m) => MLockedSizedBytes n -> m () +mlsbZero :: forall n m. (KnownNat n, MonadST m) => MLockedSizedBytes n -> m () mlsbZero mlsb = do withMLSB mlsb $ \ptr -> zeroMem ptr (mlsbSize mlsb) -- | Create a deep mlocked copy of an 'MLockedSizedBytes'. -mlsbCopy :: forall n m. (KnownNat n, MonadSodium m) => MLockedSizedBytes n -> m (MLockedSizedBytes n) -mlsbCopy src = mlsbUseAsCPtr src $ \ptrSrc -> do - dst <- mlsbNew +mlsbCopy :: forall n m. (KnownNat n, MonadST m) + => MLockedSizedBytes n + -> m (MLockedSizedBytes n) +mlsbCopy = mlsbCopyWith mlockedMalloc + +mlsbCopyWith :: + forall n m. (KnownNat n, MonadST m) + => MLockedAllocator m + -> MLockedSizedBytes n + -> m (MLockedSizedBytes n) +mlsbCopyWith allocator src = mlsbUseAsCPtr src $ \ptrSrc -> do + dst <- mlsbNewWith allocator withMLSB dst $ \ptrDst -> do copyMem (castPtr ptrDst) (castPtr ptrSrc) (mlsbSize src) return dst @@ -160,10 +181,14 @@ mlsbCopy src = mlsbUseAsCPtr src $ \ptrSrc -> do -- 'mlsbNew' or 'mlsbNewZero' to create 'MLockedSizedBytes' values, and -- manipulate them through 'withMLSB', 'mlsbUseAsCPtr', or 'mlsbUseAsSizedPtr'. -- (See also 'mlsbFromByteStringCheck') -mlsbFromByteString :: forall n m. (KnownNat n, MonadSodium m, MonadST m) +mlsbFromByteString :: forall n m. (KnownNat n, MonadST m) => BS.ByteString -> m (MLockedSizedBytes n) -mlsbFromByteString bs = do - dst <- mlsbNew +mlsbFromByteString = mlsbFromByteStringWith mlockedMalloc + +mlsbFromByteStringWith :: forall n m. (KnownNat n, MonadST m) + => MLockedAllocator m -> BS.ByteString -> m (MLockedSizedBytes n) +mlsbFromByteStringWith allocator bs = do + dst <- mlsbNewWith allocator withMLSB dst $ \ptr -> do withLiftST $ \liftST -> liftST . unsafeIOToST $ do BS.useAsCStringLen bs $ \(ptrBS, len) -> do @@ -178,10 +203,19 @@ mlsbFromByteString bs = do -- 'mlsbNew' or 'mlsbNewZero' to create 'MLockedSizedBytes' values, and -- manipulate them through 'withMLSB', 'mlsbUseAsCPtr', or 'mlsbUseAsSizedPtr'. -- (See also 'mlsbFromByteString') -mlsbFromByteStringCheck :: forall n m. (KnownNat n, MonadSodium m, MonadST m) => BS.ByteString -> m (Maybe (MLockedSizedBytes n)) -mlsbFromByteStringCheck bs +mlsbFromByteStringCheck :: forall n m. (KnownNat n, MonadST m) + => BS.ByteString + -> m (Maybe (MLockedSizedBytes n)) +mlsbFromByteStringCheck = mlsbFromByteStringCheckWith mlockedMalloc + +mlsbFromByteStringCheckWith :: + forall n m. (KnownNat n, MonadST m) + => MLockedAllocator m + -> BS.ByteString + -> m (Maybe (MLockedSizedBytes n)) +mlsbFromByteStringCheckWith allocator bs | BS.length bs /= size = return Nothing - | otherwise = Just <$> mlsbFromByteString bs + | otherwise = Just <$> mlsbFromByteStringWith allocator bs where size :: Int size = fromInteger (natVal (Proxy @n)) @@ -200,7 +234,7 @@ mlsbAsByteString mlsb@(MLSB (SFP fptr)) = BSI.PS (castForeignPtr fptr) 0 size -- | /Note:/ this function will leak mlocked memory to the Haskell heap -- and should not be used in production code. -mlsbToByteString :: forall n m. (KnownNat n, MonadSodium m, MonadST m) => MLockedSizedBytes n -> m BS.ByteString +mlsbToByteString :: forall n m. (KnownNat n, MonadST m) => MLockedSizedBytes n -> m BS.ByteString mlsbToByteString mlsb = withMLSB mlsb $ \ptr -> withLiftST $ \liftST -> liftST . unsafeIOToST $ BS.packCStringLen (castPtr ptr, size) @@ -212,7 +246,7 @@ mlsbToByteString mlsb = -- to never copy the contents of the 'MLockedSizedBytes' value into managed -- memory through the raw pointer, because that would violate the -- secure-forgetting property of mlocked memory. -mlsbUseAsCPtr :: MonadSodium m => MLockedSizedBytes n -> (Ptr Word8 -> m r) -> m r +mlsbUseAsCPtr :: MonadST m => MLockedSizedBytes n -> (Ptr Word8 -> m r) -> m r mlsbUseAsCPtr (MLSB x) k = withMLockedForeignPtr x (k . castPtr) @@ -220,18 +254,18 @@ mlsbUseAsCPtr (MLSB x) k = -- should be taken to never copy the contents of the 'MLockedSizedBytes' value -- into managed memory through the sized pointer, because that would violate -- the secure-forgetting property of mlocked memory. -mlsbUseAsSizedPtr :: forall n r m. (MonadSodium m) => MLockedSizedBytes n -> (SizedPtr n -> m r) -> m r +mlsbUseAsSizedPtr :: forall n r m. (MonadST m) => MLockedSizedBytes n -> (SizedPtr n -> m r) -> m r mlsbUseAsSizedPtr (MLSB x) k = withMLockedForeignPtr x (k . SizedPtr . castPtr) -- | Calls 'finalizeMLockedForeignPtr' on underlying pointer. -- This function invalidates argument. -- -mlsbFinalize :: MonadSodium m => MLockedSizedBytes n -> m () +mlsbFinalize :: MonadST m => MLockedSizedBytes n -> m () mlsbFinalize (MLSB ptr) = finalizeMLockedForeignPtr ptr -- | 'compareM' on 'MLockedSizedBytes' -mlsbCompare :: forall n m. (MonadSodium m, MonadST m, KnownNat n) => MLockedSizedBytes n -> MLockedSizedBytes n -> m Ordering +mlsbCompare :: forall n m. (MonadST m, KnownNat n) => MLockedSizedBytes n -> MLockedSizedBytes n -> m Ordering mlsbCompare (MLSB x) (MLSB y) = withMLockedForeignPtr x $ \x' -> withMLockedForeignPtr y $ \y' -> do @@ -241,5 +275,5 @@ mlsbCompare (MLSB x) (MLSB y) = size = fromInteger $ natVal (Proxy @n) -- | 'equalsM' on 'MLockedSizedBytes' -mlsbEq :: forall n m. (MonadSodium m, MonadST m, KnownNat n) => MLockedSizedBytes n -> MLockedSizedBytes n -> m Bool +mlsbEq :: forall n m. (MonadST m, KnownNat n) => MLockedSizedBytes n -> MLockedSizedBytes n -> m Bool mlsbEq a b = (== EQ) <$> mlsbCompare a b diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedSeed.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedSeed.hs new file mode 100644 index 000000000..0677a9a13 --- /dev/null +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedSeed.hs @@ -0,0 +1,84 @@ +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Cardano.Crypto.Libsodium.MLockedSeed +where + +import Cardano.Crypto.Libsodium.MLockedBytes ( + MLockedSizedBytes, + mlsbCopyWith, + mlsbFinalize, + mlsbNewWith, + mlsbNewZeroWith, + mlsbUseAsCPtr, + mlsbUseAsSizedPtr, + ) +import Cardano.Crypto.Libsodium.Memory ( + MLockedAllocator, + mlockedMalloc, + ) +import Cardano.Crypto.EqST ( + EqST (..), + ) +import Cardano.Foreign (SizedPtr) +import Control.DeepSeq (NFData) +import Control.Monad.Class.MonadST (MonadST) +import Data.Word (Word8) +import Foreign.Ptr (Ptr) +import GHC.TypeNats (KnownNat) +import NoThunks.Class (NoThunks) + +-- | A seed of size @n@, stored in mlocked memory. This is required to prevent +-- the seed from leaking to disk via swapping and reclaiming or scanning memory +-- after its content has been moved. +newtype MLockedSeed n = MLockedSeed {mlockedSeedMLSB :: MLockedSizedBytes n} + deriving (NFData, NoThunks) + +deriving via + MLockedSizedBytes n + instance + KnownNat n => EqST (MLockedSeed n) + +withMLockedSeedAsMLSB + :: Functor m + => (MLockedSizedBytes n -> m (MLockedSizedBytes n)) + -> MLockedSeed n + -> m (MLockedSeed n) +withMLockedSeedAsMLSB action = + fmap MLockedSeed . action . mlockedSeedMLSB + +mlockedSeedCopy :: (KnownNat n, MonadST m) => MLockedSeed n -> m (MLockedSeed n) +mlockedSeedCopy = mlockedSeedCopyWith mlockedMalloc + +mlockedSeedCopyWith + :: (KnownNat n, MonadST m) + => MLockedAllocator m + -> MLockedSeed n + -> m (MLockedSeed n) +mlockedSeedCopyWith allocator = withMLockedSeedAsMLSB (mlsbCopyWith allocator) + +mlockedSeedNew :: (KnownNat n, MonadST m) => m (MLockedSeed n) +mlockedSeedNew = mlockedSeedNewWith mlockedMalloc + +mlockedSeedNewWith :: (KnownNat n, MonadST m) => MLockedAllocator m -> m (MLockedSeed n) +mlockedSeedNewWith allocator = + MLockedSeed <$> mlsbNewWith allocator + +mlockedSeedNewZero :: (KnownNat n, MonadST m) => m (MLockedSeed n) +mlockedSeedNewZero = mlockedSeedNewZeroWith mlockedMalloc + +mlockedSeedNewZeroWith :: (KnownNat n, MonadST m) => MLockedAllocator m -> m (MLockedSeed n) +mlockedSeedNewZeroWith allocator = + MLockedSeed <$> mlsbNewZeroWith allocator + +mlockedSeedFinalize :: (MonadST m) => MLockedSeed n -> m () +mlockedSeedFinalize = mlsbFinalize . mlockedSeedMLSB + +mlockedSeedUseAsCPtr :: (MonadST m) => MLockedSeed n -> (Ptr Word8 -> m b) -> m b +mlockedSeedUseAsCPtr seed = mlsbUseAsCPtr (mlockedSeedMLSB seed) + +mlockedSeedUseAsSizedPtr :: (MonadST m) => MLockedSeed n -> (SizedPtr n -> m b) -> m b +mlockedSeedUseAsSizedPtr seed = mlsbUseAsSizedPtr (mlockedSeedMLSB seed) diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs index 1e830c403..3c04e37e5 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs @@ -4,7 +4,32 @@ module Cardano.Crypto.Libsodium.Memory ( withMLockedForeignPtr, finalizeMLockedForeignPtr, traceMLockedForeignPtr, + + -- * MLocked allocations mlockedMalloc, + MLockedAllocator (..), + AllocatorEvent(..), + getAllocatorEvent, + + mlockedAlloca, + mlockedAllocaSized, + mlockedAllocForeignPtr, + mlockedAllocForeignPtrBytes, + + -- * Allocations using an explicit allocator + mlockedAllocaWith, + mlockedAllocaSizedWith, + mlockedAllocForeignPtrWith, + mlockedAllocForeignPtrBytesWith, + + -- * Unmanaged memory, generalized to 'MonadST' + zeroMem, + copyMem, + allocaBytes, + + -- * ByteString memory access, generalized to 'MonadST' + useByteStringAsCStringLen, + packByteStringCStringLen, ) where import Cardano.Crypto.Libsodium.Memory.Internal diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs index 1bc425672..79e4162dd 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs @@ -1,40 +1,78 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE CPP #-} -{-# OPTIONS_GHC -fprof-auto #-} module Cardano.Crypto.Libsodium.Memory.Internal ( -- * High-level memory management MLockedForeignPtr (..), withMLockedForeignPtr, finalizeMLockedForeignPtr, traceMLockedForeignPtr, + + -- * MLocked allocations mlockedMalloc, - -- * Low-level memory function - sodiumMalloc, - sodiumFree, + MLockedAllocator (..), + AllocatorEvent(..), + getAllocatorEvent, + + mlockedAlloca, + mlockedAllocaSized, + mlockedAllocForeignPtr, + mlockedAllocForeignPtrBytes, + + -- * Allocations using an explicit allocator + mlockedAllocaWith, + mlockedAllocaSizedWith, + mlockedAllocForeignPtrWith, + mlockedAllocForeignPtrBytesWith, + + -- * Unmanaged memory, generalized to 'MonadST' + zeroMem, + copyMem, + allocaBytes, + + -- * ByteString memory access, generalized to 'MonadST' + useByteStringAsCStringLen, + packByteStringCStringLen, + + -- * Helper + unsafeIOToMonadST ) where import Control.DeepSeq (NFData (..), rwhnf) -import Control.Exception (mask_) -import Control.Monad (when) +import Control.Exception (Exception, mask_) +import Control.Monad (when, void) +import Control.Monad.Class.MonadST +import Control.Monad.Class.MonadThrow (MonadThrow (bracket)) +import Control.Monad.ST +import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO) +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Unsafe as BS import Data.Coerce (coerce) -import Data.Proxy (Proxy (..)) +import Data.Typeable +import Debug.Trace (traceShowM) import Foreign.C.Error (errnoToIOError, getErrno) +import Foreign.C.String (CStringLen) import Foreign.C.Types (CSize (..)) -import Foreign.Ptr (Ptr, nullPtr) -import Foreign.ForeignPtr (ForeignPtr, withForeignPtr, finalizeForeignPtr) import Foreign.Concurrent (newForeignPtr) -import Foreign.Storable (Storable (peek)) +import Foreign.ForeignPtr (ForeignPtr, finalizeForeignPtr, touchForeignPtr) +import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) +import qualified Foreign.Marshal.Alloc as Foreign import Foreign.Marshal.Utils (fillBytes) -import GHC.TypeLits (KnownNat, natVal) +import Foreign.Ptr (Ptr, nullPtr, castPtr) +import Foreign.Storable (Storable (peek), sizeOf, alignment) import GHC.IO.Exception (ioException) +import GHC.TypeLits (KnownNat, natVal) import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) import System.IO.Unsafe (unsafePerformIO) import Cardano.Crypto.Libsodium.C +import Cardano.Foreign (c_memset, c_memcpy, SizedPtr (..)) import Cardano.Memory.Pool (initPool, grabNextBlock, Pool) -- | Foreign pointer to securely allocated memory. @@ -44,24 +82,30 @@ newtype MLockedForeignPtr a = SFP { _unwrapMLockedForeignPtr :: ForeignPtr a } instance NFData (MLockedForeignPtr a) where rnf = rwhnf . _unwrapMLockedForeignPtr -withMLockedForeignPtr :: forall a b. MLockedForeignPtr a -> (Ptr a -> IO b) -> IO b -withMLockedForeignPtr = coerce (withForeignPtr @a @b) +withMLockedForeignPtr :: MonadST m => MLockedForeignPtr a -> (Ptr a -> m b) -> m b +withMLockedForeignPtr (SFP fptr) f = do + r <- f (unsafeForeignPtrToPtr fptr) + r <$ unsafeIOToMonadST (touchForeignPtr fptr) + +finalizeMLockedForeignPtr :: MonadST m => MLockedForeignPtr a -> m () +finalizeMLockedForeignPtr (SFP fptr) = withLiftST $ \lift -> + (lift . unsafeIOToST) (finalizeForeignPtr fptr) -finalizeMLockedForeignPtr :: forall a. MLockedForeignPtr a -> IO () -finalizeMLockedForeignPtr = coerce (finalizeForeignPtr @a) +{-# WARNING traceMLockedForeignPtr "Do not use traceMLockedForeignPtr in production" #-} -traceMLockedForeignPtr :: (Storable a, Show a) => MLockedForeignPtr a -> IO () +traceMLockedForeignPtr :: (Storable a, Show a, MonadST m) => MLockedForeignPtr a -> m () traceMLockedForeignPtr fptr = withMLockedForeignPtr fptr $ \ptr -> do - a <- peek ptr - print a + a <- unsafeIOToMonadST (peek ptr) + traceShowM a -{-# DEPRECATED traceMLockedForeignPtr "Don't leave traceMLockedForeignPtr in production" #-} +unsafeIOToMonadST :: MonadST m => IO a -> m a +unsafeIOToMonadST action = withLiftST ($ unsafeIOToST action) -makeMLockedPool :: forall n. KnownNat n => IO (Pool n) +makeMLockedPool :: forall n s. KnownNat n => ST s (Pool n s) makeMLockedPool = do initPool (max 1 . fromIntegral $ 4096 `div` natVal (Proxy @n) `div` 64) - (\size -> mask_ $ do + (\size -> unsafeIOToST $ mask_ $ do ptr <- sodiumMalloc (fromIntegral size) newForeignPtr ptr (sodiumFree ptr (fromIntegral size)) ) @@ -72,39 +116,50 @@ makeMLockedPool = do eraseMem :: forall n a. KnownNat n => Proxy n -> Ptr a -> IO () eraseMem proxy ptr = fillBytes ptr 0xff (fromIntegral $ natVal proxy) -mlockedPool32 :: Pool 32 -mlockedPool32 = unsafePerformIO makeMLockedPool +mlockedPool32 :: Pool 32 RealWorld +mlockedPool32 = unsafePerformIO $ stToIO makeMLockedPool {-# NOINLINE mlockedPool32 #-} -mlockedPool64 :: Pool 64 -mlockedPool64 = unsafePerformIO makeMLockedPool +mlockedPool64 :: Pool 64 RealWorld +mlockedPool64 = unsafePerformIO $ stToIO makeMLockedPool {-# NOINLINE mlockedPool64 #-} -mlockedPool128 :: Pool 128 -mlockedPool128 = unsafePerformIO makeMLockedPool +mlockedPool128 :: Pool 128 RealWorld +mlockedPool128 = unsafePerformIO $ stToIO makeMLockedPool {-# NOINLINE mlockedPool128 #-} -mlockedPool256 :: Pool 256 -mlockedPool256 = unsafePerformIO makeMLockedPool +mlockedPool256 :: Pool 256 RealWorld +mlockedPool256 = unsafePerformIO $ stToIO makeMLockedPool {-# NOINLINE mlockedPool256 #-} -mlockedPool512 :: Pool 512 -mlockedPool512 = unsafePerformIO makeMLockedPool +mlockedPool512 :: Pool 512 RealWorld +mlockedPool512 = unsafePerformIO $ stToIO makeMLockedPool {-# NOINLINE mlockedPool512 #-} -mlockedMalloc :: CSize -> IO (MLockedForeignPtr a) -mlockedMalloc size = SFP <$> do +data AllocatorException = + AllocatorNoTracer + | AllocatorNoGenerator + deriving Show + +instance Exception AllocatorException + +mlockedMalloc :: MonadST m => MLockedAllocator m +mlockedMalloc = + MLockedAllocator { mlAllocate = \ size -> withLiftST ($ unsafeIOToST (mlockedMallocIO size)) } + +mlockedMallocIO :: CSize -> IO (MLockedForeignPtr a) +mlockedMallocIO size = SFP <$> do if | size <= 32 -> do - coerce $ grabNextBlock mlockedPool32 + coerce $ stToIO $ grabNextBlock mlockedPool32 | size <= 64 -> do - coerce $ grabNextBlock mlockedPool64 + coerce $ stToIO $ grabNextBlock mlockedPool64 | size <= 128 -> do - coerce $ grabNextBlock mlockedPool128 + coerce $ stToIO $ grabNextBlock mlockedPool128 | size <= 256 -> do - coerce $ grabNextBlock mlockedPool256 + coerce $ stToIO $ grabNextBlock mlockedPool256 | size <= 512 -> do - coerce $ grabNextBlock mlockedPool512 + coerce $ stToIO $ grabNextBlock mlockedPool512 | otherwise -> do mask_ $ do ptr <- sodiumMalloc size @@ -130,3 +185,98 @@ sodiumFree ptr size = do errno <- getErrno ioException $ errnoToIOError "c_sodium_munlock" errno Nothing Nothing c_sodium_free ptr + +zeroMem :: MonadST m => Ptr a -> CSize -> m () +zeroMem ptr size = unsafeIOToMonadST . void $ c_memset (castPtr ptr) 0 size + +copyMem :: MonadST m => Ptr a -> Ptr a -> CSize -> m () +copyMem dst src size = unsafeIOToMonadST . void $ c_memcpy (castPtr dst) (castPtr src) size + +allocaBytes :: Int -> (Ptr a -> ST s b) -> ST s b +allocaBytes size f = + unsafeIOToST $ Foreign.allocaBytes size (unsafeSTToIO . f) + +useByteStringAsCStringLen :: ByteString -> (CStringLen -> ST s a) -> ST s a +useByteStringAsCStringLen bs f = + allocaBytes (BS.length bs + 1) $ \buf -> do + len <- unsafeIOToST $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> + len <$ copyMem buf ptr (fromIntegral len) + f (buf, len) + +packByteStringCStringLen :: MonadST m => CStringLen -> m ByteString +packByteStringCStringLen (ptr, len) = + withLiftST $ \lift -> lift . unsafeIOToST $ BS.packCStringLen (ptr, len) + +data AllocatorEvent where + AllocatorEvent :: (Show e, Typeable e) => e -> AllocatorEvent + +instance Show AllocatorEvent where + show (AllocatorEvent e) = "(AllocatorEvent " ++ show e ++ ")" + +getAllocatorEvent :: forall e. Typeable e => AllocatorEvent -> Maybe e +getAllocatorEvent (AllocatorEvent e) = cast e + +newtype MLockedAllocator m = + MLockedAllocator + { mlAllocate :: forall a. CSize -> m (MLockedForeignPtr a) + } + +mlockedAllocaSized :: forall m n b. (MonadST m, MonadThrow m, KnownNat n) => (SizedPtr n -> m b) -> m b +mlockedAllocaSized = mlockedAllocaSizedWith mlockedMalloc + +mlockedAllocaSizedWith :: + forall m n b. (MonadST m, MonadThrow m, KnownNat n) + => MLockedAllocator m + -> (SizedPtr n -> m b) + -> m b +mlockedAllocaSizedWith allocator k = mlockedAllocaWith allocator size (k . SizedPtr) where + size :: CSize + size = fromInteger (natVal (Proxy @n)) + +mlockedAllocForeignPtrBytes :: MonadST m => CSize -> CSize -> m (MLockedForeignPtr a) +mlockedAllocForeignPtrBytes = mlockedAllocForeignPtrBytesWith mlockedMalloc + +mlockedAllocForeignPtrBytesWith :: MLockedAllocator m -> CSize -> CSize -> m (MLockedForeignPtr a) +mlockedAllocForeignPtrBytesWith allocator size align = do + mlAllocate allocator size' + where + size' :: CSize + size' + | m == 0 = size + | otherwise = (q + 1) * align + where + (q,m) = size `quotRem` align + +mlockedAllocForeignPtr :: forall a m . (MonadST m, Storable a) => m (MLockedForeignPtr a) +mlockedAllocForeignPtr = mlockedAllocForeignPtrWith mlockedMalloc + +mlockedAllocForeignPtrWith :: + forall a m. Storable a + => MLockedAllocator m + -> m (MLockedForeignPtr a) +mlockedAllocForeignPtrWith allocator = + mlockedAllocForeignPtrBytesWith allocator size align + where + dummy :: a + dummy = undefined + + size :: CSize + size = fromIntegral $ sizeOf dummy + + align :: CSize + align = fromIntegral $ alignment dummy + +mlockedAlloca :: forall a b m. (MonadST m, MonadThrow m) => CSize -> (Ptr a -> m b) -> m b +mlockedAlloca = mlockedAllocaWith mlockedMalloc + +mlockedAllocaWith :: + forall a b m. (MonadThrow m, MonadST m) + => MLockedAllocator m + -> CSize + -> (Ptr a -> m b) + -> m b +mlockedAllocaWith allocator size = + bracket alloc free . flip withMLockedForeignPtr + where + alloc = mlAllocate allocator size + free = finalizeMLockedForeignPtr diff --git a/cardano-crypto-class/src/Cardano/Crypto/MLockedSeed.hs b/cardano-crypto-class/src/Cardano/Crypto/MLockedSeed.hs deleted file mode 100644 index e5f9fc9ce..000000000 --- a/cardano-crypto-class/src/Cardano/Crypto/MLockedSeed.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -module Cardano.Crypto.MLockedSeed -where - -import Cardano.Crypto.MonadSodium - ( MLockedSizedBytes - , MonadSodium (..) - , mlsbCopy - , mlsbNew - , mlsbNewZero - , mlsbFinalize - , mlsbUseAsCPtr - , mlsbUseAsSizedPtr - , MEq (..) - ) -import Cardano.Foreign (SizedPtr) -import GHC.TypeNats (KnownNat) -import Control.DeepSeq (NFData) -import NoThunks.Class (NoThunks) -import Foreign.Ptr (Ptr) -import Data.Word (Word8) -import Control.Monad.Class.MonadST (MonadST) - --- | A seed of size @n@, stored in mlocked memory. This is required to prevent --- the seed from leaking to disk via swapping and reclaiming or scanning memory --- after its content has been moved. -newtype MLockedSeed n = - MLockedSeed { mlockedSeedMLSB :: MLockedSizedBytes n } - deriving (NFData, NoThunks) - -deriving via (MLockedSizedBytes n) - instance (MonadSodium m, MonadST m, KnownNat n) => MEq m (MLockedSeed n) - -withMLockedSeedAsMLSB :: Functor m - => (MLockedSizedBytes n -> m (MLockedSizedBytes n)) - -> MLockedSeed n - -> m (MLockedSeed n) -withMLockedSeedAsMLSB action = - fmap MLockedSeed . action . mlockedSeedMLSB - -mlockedSeedCopy :: (KnownNat n, MonadSodium m) => MLockedSeed n -> m (MLockedSeed n) -mlockedSeedCopy = - withMLockedSeedAsMLSB mlsbCopy - -mlockedSeedNew :: (KnownNat n, MonadSodium m) => m (MLockedSeed n) -mlockedSeedNew = - MLockedSeed <$> mlsbNew - -mlockedSeedNewZero :: (KnownNat n, MonadSodium m) => m (MLockedSeed n) -mlockedSeedNewZero = - MLockedSeed <$> mlsbNewZero - -mlockedSeedFinalize :: (MonadSodium m) => MLockedSeed n -> m () -mlockedSeedFinalize = mlsbFinalize . mlockedSeedMLSB - -mlockedSeedUseAsCPtr :: (MonadSodium m) => MLockedSeed n -> (Ptr Word8 -> m b) -> m b -mlockedSeedUseAsCPtr seed = mlsbUseAsCPtr (mlockedSeedMLSB seed) - -mlockedSeedUseAsSizedPtr :: (MonadSodium m) => MLockedSeed n -> (SizedPtr n -> m b) -> m b -mlockedSeedUseAsSizedPtr seed = mlsbUseAsSizedPtr (mlockedSeedMLSB seed) diff --git a/cardano-crypto-class/src/Cardano/Crypto/MonadSodium.hs b/cardano-crypto-class/src/Cardano/Crypto/MonadSodium.hs deleted file mode 100644 index 0085fdb7c..000000000 --- a/cardano-crypto-class/src/Cardano/Crypto/MonadSodium.hs +++ /dev/null @@ -1,64 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- We need this so that we can forward the deprecated traceMLockedForeignPtr -{-# OPTIONS_GHC -Wno-deprecations #-} - --- | The Libsodium API generalized to fit arbitrary-ish Monads. --- --- The purpose of this module is to provide a drop-in replacement for the plain --- 'Cardano.Crypto.Libsodium' module, but such that the Monad in which some --- essential actions run can be mocked, rather than forcing it to be 'IO'. --- --- It may also be used to provide Libsodium functionality in monad stacks that --- have IO at the bottom, but decorate certain Libsodium operations with --- additional effects, e.g. logging mlocked memory access. -module Cardano.Crypto.MonadSodium -( - -- * MonadSodium class - MonadSodium (..), - - -- * Re-exported types - MLockedForeignPtr, - MLockedSizedBytes, - - -- * Monadic Eq and Ord - MEq (..), - nequalsM, - (==!), (!=!), - PureMEq (..), - - -- * Memory management - mlockedAllocaSized, - mlockedAllocForeignPtr, - mlockedAllocForeignPtrBytes, - - -- * MLockedSizedBytes operations - mlsbNew, - mlsbZero, - mlsbNewZero, - mlsbCopy, - mlsbFinalize, - mlsbToByteString, - mlsbAsByteString, - mlsbFromByteString, - mlsbFromByteStringCheck, - mlsbUseAsSizedPtr, - mlsbUseAsCPtr, - mlsbCompare, - mlsbEq, - - -- * Hashing - SodiumHashAlgorithm (..), - expandHash, - digestMLockedStorable, - digestMLockedBS, -) -where - -import Cardano.Crypto.MonadSodium.Class -import Cardano.Crypto.MonadSodium.Alloc -import Cardano.Crypto.Libsodium.Hash -import Cardano.Crypto.Libsodium.MLockedBytes -import Cardano.Crypto.MEqOrd diff --git a/cardano-crypto-class/src/Cardano/Crypto/MonadSodium/Alloc.hs b/cardano-crypto-class/src/Cardano/Crypto/MonadSodium/Alloc.hs deleted file mode 100644 index 5eecbafb5..000000000 --- a/cardano-crypto-class/src/Cardano/Crypto/MonadSodium/Alloc.hs +++ /dev/null @@ -1,77 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} - --- We need this so that we can forward the deprecated traceMLockedForeignPtr -{-# OPTIONS_GHC -Wno-deprecations #-} - --- | The Libsodium API generalized to fit arbitrary-ish Monads. --- --- The purpose of this module is to provide a drop-in replacement for the plain --- 'Cardano.Crypto.Libsodium' module, but such that the Monad in which some --- essential actions run can be mocked, rather than forcing it to be 'IO'. --- --- It may also be used to provide Libsodium functionality in monad stacks that --- have IO at the bottom, but decorate certain Libsodium operations with --- additional effects, e.g. logging mlocked memory access. -module Cardano.Crypto.MonadSodium.Alloc -( - MonadSodium (..), - mlockedAlloca, - mlockedAllocaSized, - mlockedAllocForeignPtr, - mlockedAllocForeignPtrBytes, - - -- * Re-exports from plain Libsodium module - NaCl.MLockedForeignPtr, -) -where - -import Cardano.Crypto.MonadSodium.Class -import Control.Monad.Class.MonadThrow (MonadThrow, bracket) - -import qualified Cardano.Crypto.Libsodium.Memory as NaCl - -import Cardano.Foreign (SizedPtr (..)) - -import GHC.TypeLits (KnownNat, natVal) -import Foreign.Storable (Storable (..)) -import Foreign.C.Types (CSize) -import Foreign.Ptr (Ptr) -import Data.Proxy (Proxy (..)) - -mlockedAllocaSized :: forall m n b. (MonadSodium m, MonadThrow m, KnownNat n) => (SizedPtr n -> m b) -> m b -mlockedAllocaSized k = mlockedAlloca size (k . SizedPtr) where - size :: CSize - size = fromInteger (natVal (Proxy @n)) - -mlockedAllocForeignPtrBytes :: (MonadSodium m) => CSize -> CSize -> m (MLockedForeignPtr a) -mlockedAllocForeignPtrBytes size align = do - mlockedMalloc size' - where - size' :: CSize - size' - | m == 0 = size - | otherwise = (q + 1) * align - where - (q,m) = size `quotRem` align - -mlockedAllocForeignPtr :: forall a m . (MonadSodium m, Storable a) => m (MLockedForeignPtr a) -mlockedAllocForeignPtr = - mlockedAllocForeignPtrBytes size align - where - dummy :: a - dummy = undefined - - size :: CSize - size = fromIntegral $ sizeOf dummy - - align :: CSize - align = fromIntegral $ alignment dummy - -mlockedAlloca :: forall a b m. (MonadSodium m, MonadThrow m) => CSize -> (Ptr a -> m b) -> m b -mlockedAlloca size = - bracket alloc free . flip withMLockedForeignPtr - where - alloc = mlockedMalloc size - free = finalizeMLockedForeignPtr diff --git a/cardano-crypto-class/src/Cardano/Crypto/MonadSodium/Class.hs b/cardano-crypto-class/src/Cardano/Crypto/MonadSodium/Class.hs deleted file mode 100644 index b9a0cde56..000000000 --- a/cardano-crypto-class/src/Cardano/Crypto/MonadSodium/Class.hs +++ /dev/null @@ -1,62 +0,0 @@ -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE FlexibleInstances #-} - --- We need this so that we can forward the deprecated traceMLockedForeignPtr -{-# OPTIONS_GHC -Wno-deprecations #-} - --- | The Libsodium API generalized to fit arbitrary-ish Monads. --- --- The purpose of this module is to provide a drop-in replacement for the plain --- 'Cardano.Crypto.Libsodium' module, but such that the Monad in which some --- essential actions run can be mocked, rather than forcing it to be 'IO'. --- --- It may also be used to provide Libsodium functionality in monad stacks that --- have IO at the bottom, but decorate certain Libsodium operations with --- additional effects, e.g. logging mlocked memory access. -module Cardano.Crypto.MonadSodium.Class -( - MonadSodium (..), - - -- * Re-exports from plain Libsodium module - NaCl.MLockedForeignPtr, -) -where - -import Cardano.Crypto.Libsodium.Memory.Internal (MLockedForeignPtr (..)) - -import qualified Cardano.Crypto.Libsodium.Memory as NaCl -import Control.Monad (void) - -import Cardano.Foreign (c_memset, c_memcpy) - -import Foreign.Ptr (Ptr, castPtr) -import Foreign.Storable (Storable) -import Foreign.C.Types (CSize) - -{-# DEPRECATED traceMLockedForeignPtr "Do not use traceMLockedForeignPtr in production" #-} - --- | Primitive operations on unmanaged mlocked memory. --- These are all implemented in 'IO' underneath, but should morally be in 'ST'. --- There are two use cases for this: --- - Running mlocked-memory operations in a mocking context (e.g. 'IOSim') for --- testing purposes. --- - Running mlocked-memory operations directly on some monad stack with 'IO' --- at the bottom. -class Monad m => MonadSodium m where - withMLockedForeignPtr :: forall a b. MLockedForeignPtr a -> (Ptr a -> m b) -> m b - finalizeMLockedForeignPtr :: forall a. MLockedForeignPtr a -> m () - traceMLockedForeignPtr :: (Storable a, Show a) => MLockedForeignPtr a -> m () - mlockedMalloc :: CSize -> m (MLockedForeignPtr a) - zeroMem :: Ptr a -> CSize -> m () - copyMem :: Ptr a -> Ptr a -> CSize -> m () - -instance MonadSodium IO where - withMLockedForeignPtr = NaCl.withMLockedForeignPtr - finalizeMLockedForeignPtr = NaCl.finalizeMLockedForeignPtr - traceMLockedForeignPtr = NaCl.traceMLockedForeignPtr - mlockedMalloc = NaCl.mlockedMalloc - zeroMem ptr size = void $ c_memset (castPtr ptr) 0 size - copyMem dst src size = void $ c_memcpy (castPtr dst) (castPtr src) size diff --git a/cardano-crypto-class/src/Cardano/Crypto/PinnedSizedBytes.hs b/cardano-crypto-class/src/Cardano/Crypto/PinnedSizedBytes.hs index baa748f2b..283b70f55 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/PinnedSizedBytes.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/PinnedSizedBytes.hs @@ -38,7 +38,8 @@ import Data.Kind (Type) import Control.DeepSeq (NFData) import Control.Monad.ST (runST) import Control.Monad.ST.Unsafe (unsafeIOToST) -import Control.Monad.Primitive (PrimMonad, primitive_, touch) +import Control.Monad.Class.MonadST +import Control.Monad.Primitive (primitive_, touch) import Data.Primitive.ByteArray ( ByteArray (..) , MutableByteArray (..) @@ -237,7 +238,7 @@ instance KnownNat n => Storable (PinnedSizedBytes n) where {-# INLINE psbUseAsCPtr #-} psbUseAsCPtr :: forall (n :: Nat) (r :: Type) (m :: Type -> Type) . - (PrimMonad m) => + (MonadST m) => PinnedSizedBytes n -> (Ptr Word8 -> m r) -> m r @@ -260,7 +261,7 @@ psbUseAsCPtr (PSB ba) = runAndTouch ba {-# INLINE psbUseAsCPtrLen #-} psbUseAsCPtrLen :: forall (n :: Nat) (r :: Type) (m :: Type -> Type) . - (KnownNat n, PrimMonad m) => + (KnownNat n, MonadST m) => PinnedSizedBytes n -> (Ptr Word8 -> CSize -> m r) -> m r @@ -275,20 +276,20 @@ psbUseAsCPtrLen (PSB ba) f = do {-# INLINE psbUseAsSizedPtr #-} psbUseAsSizedPtr :: forall (n :: Nat) (r :: Type) (m :: Type -> Type) . - (PrimMonad m) => + (MonadST m) => PinnedSizedBytes n -> (SizedPtr n -> m r) -> m r -psbUseAsSizedPtr (PSB ba) k = do +psbUseAsSizedPtr (PSB ba) k = withLiftST $ \lift -> do r <- k (SizedPtr $ castPtr $ byteArrayContents ba) - r <$ touch ba + r <$ lift (touch ba) -- | As 'psbCreateResult', but presumes that no useful value is produced: that -- is, the function argument is run only for its side effects. {-# INLINE psbCreate #-} psbCreate :: forall (n :: Nat) (m :: Type -> Type) . - (KnownNat n, PrimMonad m) => + (KnownNat n, MonadST m) => (Ptr Word8 -> m ()) -> m (PinnedSizedBytes n) psbCreate f = fst <$> psbCreateResult f @@ -298,7 +299,7 @@ psbCreate f = fst <$> psbCreateResult f {-# INLINE psbCreateLen #-} psbCreateLen :: forall (n :: Nat) (m :: Type -> Type) . - (KnownNat n, PrimMonad m) => + (KnownNat n, MonadST m) => (Ptr Word8 -> CSize -> m ()) -> m (PinnedSizedBytes n) psbCreateLen f = fst <$> psbCreateResultLen f @@ -321,7 +322,7 @@ psbCreateLen f = fst <$> psbCreateResultLen f {-# INLINE psbCreateResult #-} psbCreateResult :: forall (n :: Nat) (r :: Type) (m :: Type -> Type) . - (KnownNat n, PrimMonad m) => + (KnownNat n, MonadST m) => (Ptr Word8 -> m r) -> m (PinnedSizedBytes n, r) psbCreateResult f = psbCreateResultLen (\p _ -> f p) @@ -341,14 +342,14 @@ psbCreateResult f = psbCreateResultLen (\p _ -> f p) {-# INLINE psbCreateResultLen #-} psbCreateResultLen :: forall (n :: Nat) (r :: Type) (m :: Type -> Type). - (KnownNat n, PrimMonad m) => + (KnownNat n, MonadST m) => (Ptr Word8 -> CSize -> m r) -> m (PinnedSizedBytes n, r) -psbCreateResultLen f = do +psbCreateResultLen f = withLiftST $ \lift -> do let len :: Int = fromIntegral . natVal $ Proxy @n - mba <- newPinnedByteArray len + mba <- lift (newPinnedByteArray len) res <- f (mutableByteArrayContents mba) (fromIntegral len) - arr <- unsafeFreezeByteArray mba + arr <- lift (unsafeFreezeByteArray mba) pure (PSB arr, res) -- | As 'psbCreateSizedResult', but presumes that no useful value is produced: @@ -356,7 +357,7 @@ psbCreateResultLen f = do {-# INLINE psbCreateSized #-} psbCreateSized :: forall (n :: Nat) (m :: Type -> Type) . - (KnownNat n, PrimMonad m) => + (KnownNat n, MonadST m) => (SizedPtr n -> m ()) -> m (PinnedSizedBytes n) psbCreateSized k = psbCreate (k . SizedPtr . castPtr) @@ -367,7 +368,7 @@ psbCreateSized k = psbCreate (k . SizedPtr . castPtr) {-# INLINE psbCreateSizedResult #-} psbCreateSizedResult :: forall (n :: Nat) (r :: Type) (m :: Type -> Type) . - (KnownNat n, PrimMonad m) => + (KnownNat n, MonadST m) => (SizedPtr n -> m r) -> m (PinnedSizedBytes n, r) psbCreateSizedResult f = psbCreateResult (f . SizedPtr . castPtr) @@ -405,10 +406,10 @@ die fun problem = error $ "PinnedSizedBytes." ++ fun ++ ": " ++ problem {-# INLINE runAndTouch #-} runAndTouch :: forall (a :: Type) (m :: Type -> Type) . - (PrimMonad m) => + (MonadST m) => ByteArray -> (Ptr Word8 -> m a) -> m a -runAndTouch ba f = do +runAndTouch ba f = withLiftST $ \lift -> do r <- f (byteArrayContents ba) - r <$ touch ba + r <$ lift (touch ba) diff --git a/cardano-crypto-tests/cardano-crypto-tests.cabal b/cardano-crypto-tests/cardano-crypto-tests.cabal index 2be302d9d..040043a14 100644 --- a/cardano-crypto-tests/cardano-crypto-tests.cabal +++ b/cardano-crypto-tests/cardano-crypto-tests.cabal @@ -54,7 +54,6 @@ library Test.Crypto.VRF Test.Crypto.Regressions Test.Crypto.Instances - Cardano.Crypto.KES.ForgetMock Bench.Crypto.DSIGN Bench.Crypto.VRF Bench.Crypto.KES @@ -78,7 +77,6 @@ library , mtl , nothunks , pretty-show - , random , QuickCheck , quickcheck-instances , tasty diff --git a/cardano-crypto-tests/src/Bench/Crypto/KES.hs b/cardano-crypto-tests/src/Bench/Crypto/KES.hs index a5126dc1d..76ae4db53 100644 --- a/cardano-crypto-tests/src/Bench/Crypto/KES.hs +++ b/cardano-crypto-tests/src/Bench/Crypto/KES.hs @@ -26,7 +26,7 @@ import Criterion import qualified Data.ByteString as BS (ByteString) import Data.Either (fromRight) import Cardano.Crypto.Libsodium as NaCl -import Cardano.Crypto.MLockedSeed +import Cardano.Crypto.Libsodium.MLockedSeed import System.IO.Unsafe (unsafePerformIO) import GHC.TypeLits (KnownNat) import Data.Kind (Type) @@ -51,7 +51,7 @@ benchmarks = bgroup "KES" {-# NOINLINE benchKES #-} benchKES :: forall (proxy :: forall k. k -> Type) v - . ( KESSignAlgorithm IO v + . ( KESSignAlgorithm v , ContextKES v ~ () , Signable v BS.ByteString , NFData (SignKeyKES v) @@ -63,21 +63,21 @@ benchKES :: forall (proxy :: forall k. k -> Type) v benchKES _ lbl = bgroup lbl [ bench "genKey" $ - nfIO $ genKeyKES @IO @v testSeedML >>= forgetSignKeyKES @IO @v + nfIO $ genKeyKES @v testSeedML >>= forgetSignKeyKES @v , bench "signKES" $ nfIO $ - (\sk -> do { sig <- signKES @IO @v () 0 typicalMsg sk; forgetSignKeyKES sk; return sig }) - =<< (genKeyKES @IO @v testSeedML) + (\sk -> do { sig <- signKES @v() 0 typicalMsg sk; forgetSignKeyKES sk; return sig }) + =<< genKeyKES @v testSeedML , bench "verifyKES" $ nfIO $ do - signKey <- genKeyKES @IO @v testSeedML - sig <- signKES @IO @v () 0 typicalMsg signKey + signKey <- genKeyKES @v testSeedML + sig <- signKES @v () 0 typicalMsg signKey verKey <- deriveVerKeyKES signKey forgetSignKeyKES signKey return . fromRight $ verifyKES @v () verKey 0 typicalMsg sig , bench "updateKES" $ nfIO $ do - signKey <- genKeyKES @IO @v testSeedML + signKey <- genKeyKES @v testSeedML sk' <- fromJust <$> updateKES () signKey 0 forgetSignKeyKES signKey return sk' diff --git a/cardano-crypto-tests/src/Cardano/Crypto/KES/ForgetMock.hs b/cardano-crypto-tests/src/Cardano/Crypto/KES/ForgetMock.hs deleted file mode 100644 index 9a0536a76..000000000 --- a/cardano-crypto-tests/src/Cardano/Crypto/KES/ForgetMock.hs +++ /dev/null @@ -1,169 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DerivingVia #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE MultiParamTypeClasses #-} - --- | Mock key evolving signatures. -module Cardano.Crypto.KES.ForgetMock - ( ForgetMockKES - , VerKeyKES (..) - , SignKeyKES (..) - , SigKES (..) - , ForgetMockEvent (..) - , isGEN - , isUPD - , isDEL - ) -where - -import Data.Proxy (Proxy(..)) -import GHC.Generics (Generic) - -import Cardano.Crypto.KES.Class -import NoThunks.Class (NoThunks (..), allNoThunks) -import System.Random (randomRIO) -import Control.Tracer -import Test.Crypto.AllocLog -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Reader (ask) -import Control.Monad ((<$!>)) - --- | A wrapper for a KES implementation that adds logging functionality, for --- the purpose of verifying that invocations of 'genKeyKES' and --- 'forgetSignKeyKES' pair up properly in a given host application. --- --- The wrapped KES behaves exactly like its unwrapped payload, except that --- invocations of 'genKeyKES', 'updateKES' and 'forgetSignKeyKES' are logged --- as 'GenericEvent' 'ForgetMockEvent' values. (We use 'GenericEvent' in order --- to use the generic 'MonadSodium' instance of 'LogT'; otherwise we would --- have to provide a boilerplate instance here). -data ForgetMockKES k - -data ForgetMockEvent - = GEN Word - | UPD Word Word - | NOUPD - | DEL Word - deriving (Ord, Eq, Show) - -isGEN :: ForgetMockEvent -> Bool -isGEN GEN {} = True -isGEN _ = False - -isUPD :: ForgetMockEvent -> Bool -isUPD UPD {} = True -isUPD _ = False - -isDEL :: ForgetMockEvent -> Bool -isDEL DEL {} = True -isDEL _ = False - -instance - ( KESAlgorithm k - ) - => KESAlgorithm (ForgetMockKES k) where - type SeedSizeKES (ForgetMockKES k) = SeedSizeKES k - type Signable (ForgetMockKES k) = Signable k - - newtype VerKeyKES (ForgetMockKES k) = VerKeyForgetMockKES (VerKeyKES k) - deriving (Generic) - newtype SigKES (ForgetMockKES k) = SigForgetMockKES (SigKES k) - deriving (Generic) - - type ContextKES (ForgetMockKES k) = ContextKES k - - algorithmNameKES _ = algorithmNameKES (Proxy @k) - - verifyKES ctx (VerKeyForgetMockKES vk) p msg (SigForgetMockKES sig) = - verifyKES ctx vk p msg sig - - totalPeriodsKES _ = totalPeriodsKES (Proxy @k) - - type SizeVerKeyKES (ForgetMockKES k) = SizeVerKeyKES k - type SizeSignKeyKES (ForgetMockKES k) = SizeSignKeyKES k - type SizeSigKES (ForgetMockKES k) = SizeSigKES k - - rawSerialiseVerKeyKES (VerKeyForgetMockKES k) = rawSerialiseVerKeyKES k - rawSerialiseSigKES (SigForgetMockKES k) = rawSerialiseSigKES k - - rawDeserialiseVerKeyKES = fmap VerKeyForgetMockKES . rawDeserialiseVerKeyKES - rawDeserialiseSigKES = fmap SigForgetMockKES . rawDeserialiseSigKES - - -instance - ( KESSignAlgorithm (LogT (GenericEvent ForgetMockEvent) m) k - , MonadIO m - ) - => KESSignAlgorithm (LogT (GenericEvent ForgetMockEvent) m) (ForgetMockKES k) where - data SignKeyKES (ForgetMockKES k) = SignKeyForgetMockKES !Word !(SignKeyKES k) - - genKeyKES seed = do - sk <- genKeyKES seed - nonce <- randomRIO (10000000, 99999999) - tracer <- ask - traceWith tracer (GenericEvent $ GEN nonce) - return $! SignKeyForgetMockKES nonce sk - - forgetSignKeyKES (SignKeyForgetMockKES nonce sk) = do - tracer <- ask - traceWith tracer (GenericEvent $ DEL nonce) - forgetSignKeyKES sk - - deriveVerKeyKES (SignKeyForgetMockKES _ k) = - VerKeyForgetMockKES <$!> deriveVerKeyKES k - - signKES ctx p msg (SignKeyForgetMockKES _ sk) = - SigForgetMockKES <$!> signKES ctx p msg sk - - updateKES ctx (SignKeyForgetMockKES nonce sk) p = do - tracer <- ask - nonce' <- randomRIO (10000000, 99999999) - updateKES ctx sk p >>= \case - Just sk' -> do - traceWith tracer (GenericEvent $ UPD nonce nonce') - return $! Just $! SignKeyForgetMockKES nonce' sk' - Nothing -> do - traceWith tracer (GenericEvent NOUPD) - return Nothing - -instance - ( UnsoundKESSignAlgorithm (LogT (GenericEvent ForgetMockEvent) m) k - , MonadIO m - ) - => UnsoundKESSignAlgorithm (LogT (GenericEvent ForgetMockEvent) m) (ForgetMockKES k) where - - rawSerialiseSignKeyKES (SignKeyForgetMockKES _ k) = rawSerialiseSignKeyKES k - - rawDeserialiseSignKeyKES bs = do - msk <- rawDeserialiseSignKeyKES bs - nonce :: Word <- randomRIO (10000000, 99999999) - return $ fmap (SignKeyForgetMockKES nonce) msk - - -deriving instance Show (VerKeyKES k) => Show (VerKeyKES (ForgetMockKES k)) -deriving instance Eq (VerKeyKES k) => Eq (VerKeyKES (ForgetMockKES k)) -deriving instance Ord (VerKeyKES k) => Ord (VerKeyKES (ForgetMockKES k)) -deriving instance NoThunks (VerKeyKES k) => NoThunks (VerKeyKES (ForgetMockKES k)) - -deriving instance Eq (SignKeyKES k) => Eq (SignKeyKES (ForgetMockKES k)) - -instance NoThunks (SignKeyKES k) => NoThunks (SignKeyKES (ForgetMockKES k)) where - showTypeOf _ = "SignKeyKES (ForgetMockKES k)" - wNoThunks ctx (SignKeyForgetMockKES t k) = - allNoThunks - [ noThunks ctx t - , noThunks ctx k - ] - -deriving instance Show (SigKES k) => Show (SigKES (ForgetMockKES k)) -deriving instance Eq (SigKES k) => Eq (SigKES (ForgetMockKES k)) -deriving instance Ord (SigKES k) => Ord (SigKES (ForgetMockKES k)) -deriving instance NoThunks (SigKES k) => NoThunks (SigKES (ForgetMockKES k)) diff --git a/cardano-crypto-tests/src/Test/Crypto/AllocLog.hs b/cardano-crypto-tests/src/Test/Crypto/AllocLog.hs index 7c2c755df..8e9afd478 100644 --- a/cardano-crypto-tests/src/Test/Crypto/AllocLog.hs +++ b/cardano-crypto-tests/src/Test/Crypto/AllocLog.hs @@ -1,23 +1,17 @@ -{-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE InstanceSigs #-} {-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# OPTIONS_GHC -Wno-deprecations #-} module Test.Crypto.AllocLog where -import Cardano.Crypto.MonadSodium -import Cardano.Crypto.Libsodium.Memory.Internal (MLockedForeignPtr (..)) import Control.Tracer -import Control.Monad.Reader -import Foreign.Ptr -import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadST -import Control.Monad.ST.Unsafe (unsafeIOToST) import Data.Typeable -import Data.Coerce (coerce) -import Foreign.Concurrent (addForeignPtrFinalizer) -import Test.Crypto.RunIO +import Foreign.Ptr +import Foreign.Concurrent + +import Cardano.Crypto.Libsodium (withMLockedForeignPtr) +import Cardano.Crypto.Libsodium.Memory (MLockedAllocator(..)) +import Cardano.Crypto.Libsodium.Memory.Internal (MLockedForeignPtr (..)) -- | Allocation log event. These are emitted automatically whenever mlocked -- memory is allocated through the 'mlockedAllocForeignPtr' primitive, or @@ -28,74 +22,17 @@ data AllocEvent = AllocEv !WordPtr | FreeEv !WordPtr | MarkerEv !String - deriving (Eq, Show) - -newtype LogT event m a = LogT { unLogT :: ReaderT (Tracer (LogT event m) event) m a } - deriving (Functor, Applicative, Monad, MonadThrow, MonadST, Typeable, MonadIO) - -type AllocLogT = LogT AllocEvent - -instance Monad m => MonadReader (Tracer (LogT event m) event) (LogT event m) where - ask = LogT ask - local f (LogT action) = LogT (local f action) - -instance MonadTrans (LogT event) where - lift action = LogT (lift action) - -runLogT :: Tracer (LogT event m) event -> LogT event m a -> m a -runLogT tracer action = runReaderT (unLogT action) tracer - -runAllocLogT :: Tracer (LogT AllocEvent m) AllocEvent -> LogT AllocEvent m a -> m a -runAllocLogT = runLogT - -pushLogEvent :: Monad m => event -> LogT event m () -pushLogEvent event = do - tracer <- ask - traceWith tracer event - -pushAllocLogEvent :: Monad m => AllocEvent -> LogT AllocEvent m () -pushAllocLogEvent = pushLogEvent - --- | Automatically log all mlocked allocation events (allocate and free) via --- 'mlockedAlloca', 'mlockedMalloc', and associated finalizers. -instance (MonadIO m, MonadThrow m, MonadSodium m, MonadST m, RunIO m) - => MonadSodium (LogT AllocEvent m) where - withMLockedForeignPtr fptr action = LogT $ do - tracer <- ask - lift $ withMLockedForeignPtr fptr (\ptr -> (runReaderT . unLogT) (action ptr) tracer) - - finalizeMLockedForeignPtr = lift . finalizeMLockedForeignPtr - - traceMLockedForeignPtr = lift . traceMLockedForeignPtr - - mlockedMalloc size = do - fptr <- lift (mlockedMalloc size) - addr <- withMLockedForeignPtr fptr (return . ptrToWordPtr) - pushAllocLogEvent (AllocEv addr) - tracer :: Tracer (LogT event m) event <- ask - withLiftST $ \liftST -> liftST . unsafeIOToST $ - addForeignPtrFinalizer - (coerce fptr) - (io . runLogT tracer . pushAllocLogEvent $ FreeEv addr) - return fptr - - zeroMem addr size = lift $ zeroMem addr size - copyMem dst src size = lift $ copyMem dst src size - --- | Newtype wrapper over an arbitrary event; we use this to write the generic --- 'MonadSodium' instance below while avoiding overlapping instances. -newtype GenericEvent e = GenericEvent { concreteEvent :: e } - --- | Generic instance, log nothing automatically. Log entries can be triggered --- manually using 'pushLogEvent'. -instance MonadSodium m => MonadSodium (LogT (GenericEvent e) m) where - withMLockedForeignPtr fptr (action) = LogT $ do - tracer <- ask - lift $ withMLockedForeignPtr fptr (\ptr -> (runReaderT . unLogT) (action ptr) tracer) - - finalizeMLockedForeignPtr = lift . finalizeMLockedForeignPtr - traceMLockedForeignPtr = lift . traceMLockedForeignPtr - mlockedMalloc size = lift (mlockedMalloc size) - - zeroMem addr size = lift $ zeroMem addr size - copyMem dst src size = lift $ copyMem dst src size + deriving (Eq, Show, Typeable) + +mkLoggingAllocator :: + Tracer IO AllocEvent -> MLockedAllocator IO -> MLockedAllocator IO +mkLoggingAllocator tracer ioAllocator = + MLockedAllocator + { mlAllocate = + \size -> do + sfptr@(SFP fptr) <- mlAllocate ioAllocator size + addr <- withMLockedForeignPtr sfptr (return . ptrToWordPtr) + traceWith tracer (AllocEv addr) + addForeignPtrFinalizer fptr (traceWith tracer (FreeEv addr)) + return sfptr + } diff --git a/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs b/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs index 3de3539c9..fcb969906 100644 --- a/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs +++ b/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs @@ -32,8 +32,8 @@ import Test.Tasty (TestTree, testGroup, adjustOption) import Test.Tasty.QuickCheck (testProperty, QuickCheckTests) import qualified Data.ByteString as BS -import qualified Cardano.Crypto.Libsodium as NaCl -import Cardano.Crypto.MonadSodium (MEq (..), (==!)) +import Cardano.Crypto.Libsodium +import Cardano.Crypto.EqST (EqST (..), (==!)) import Text.Show.Pretty (ppShow) @@ -93,9 +93,9 @@ import Cardano.Crypto.DSIGN ( rawSerialiseSigDSIGNM, rawDeserialiseSigDSIGNM), DSIGNMAlgorithm (), - UnsoundDSIGNMAlgorithm ( - rawSerialiseSignKeyDSIGNM, - rawDeserialiseSignKeyDSIGNM), + UnsoundDSIGNMAlgorithm, + rawSerialiseSignKeyDSIGNM, + rawDeserialiseSignKeyDSIGNM, sizeVerKeyDSIGNM, sizeSignKeyDSIGNM, sizeSigDSIGNM, @@ -134,7 +134,7 @@ import Test.Crypto.Util ( withLock, ) import Test.Crypto.Instances (withMLockedSeedFromPSB) -import Cardano.Crypto.MLockedSeed +import Cardano.Crypto.Libsodium.MLockedSeed #ifdef SECP256K1_ENABLED import Cardano.Crypto.DSIGN ( @@ -363,7 +363,7 @@ testDSIGNAlgorithm genSig genMsg name = adjustOption testEnough . testGroup name testDSIGNMAlgorithm :: forall v. ( -- change back to DSIGNMAlgorithm when unsound API is phased out - UnsoundDSIGNMAlgorithm IO v + UnsoundDSIGNMAlgorithm v , ToCBOR (VerKeyDSIGNM v) , FromCBOR (VerKeyDSIGNM v) -- DSIGNM cannot satisfy To/FromCBOR (not even with @@ -372,7 +372,7 @@ testDSIGNMAlgorithm -- test direct encoding/decoding for 'SignKeyDSIGNM'. -- , ToCBOR (SignKeyDSIGNM v) -- , FromCBOR (SignKeyDSIGNM v) - , MEq IO (SignKeyDSIGNM v) -- only monadic MEq for signing keys + , EqST (SignKeyDSIGNM v) -- only monadic EqST for signing keys , ToCBOR (SigDSIGNM v) , FromCBOR (SigDSIGNM v) , ContextDSIGNM v ~ () @@ -406,15 +406,15 @@ testDSIGNMAlgorithm lock _ n = [ testProperty "VerKey" $ ioPropertyWithSK @v lock $ \sk -> do vk <- deriveVerKeyDSIGNM sk - return $ (fromIntegral . BS.length . rawSerialiseVerKeyDSIGNM $ vk) === (sizeVerKeyDSIGNM (Proxy @v)) + return $ (fromIntegral . BS.length . rawSerialiseVerKeyDSIGNM $ vk) === sizeVerKeyDSIGNM (Proxy @v) , testProperty "SignKey" $ ioPropertyWithSK @v lock $ \sk -> do serialized <- rawSerialiseSignKeyDSIGNM sk - evaluate ((fromIntegral . BS.length $ serialized) == (sizeSignKeyDSIGNM (Proxy @v))) + evaluate ((fromIntegral . BS.length $ serialized) == sizeSignKeyDSIGNM (Proxy @v)) , testProperty "Sig" $ \(msg :: Message) -> ioPropertyWithSK @v lock $ \sk -> do sig :: SigDSIGNM v <- signDSIGNM () msg sk - return $ (fromIntegral . BS.length . rawSerialiseSigDSIGNM $ sig) === (sizeSigDSIGNM (Proxy @v)) + return $ (fromIntegral . BS.length . rawSerialiseSigDSIGNM $ sig) === sizeSigDSIGNM (Proxy @v) ] , testGroup "direct CBOR" @@ -432,37 +432,37 @@ testDSIGNMAlgorithm lock _ n = , testGroup "To/FromCBOR class" [ testProperty "VerKey" $ - ioPropertyWithSK lock $ \sk -> do + ioPropertyWithSK @v lock $ \sk -> do vk :: VerKeyDSIGNM v <- deriveVerKeyDSIGNM sk return $ prop_cbor vk -- No To/FromCBOR for 'SignKeyDSIGNM', see above. , testProperty "Sig" $ \(msg :: Message) -> - ioPropertyWithSK lock $ \sk -> do + ioPropertyWithSK @v lock $ \sk -> do sig :: SigDSIGNM v <- signDSIGNM () msg sk return $ prop_cbor sig ] , testGroup "ToCBOR size" [ testProperty "VerKey" $ - ioPropertyWithSK lock $ \sk -> do + ioPropertyWithSK @v lock $ \sk -> do vk :: VerKeyDSIGNM v <- deriveVerKeyDSIGNM sk return $ prop_cbor_size vk -- No To/FromCBOR for 'SignKeyDSIGNM', see above. , testProperty "Sig" $ \(msg :: Message) -> - ioPropertyWithSK lock $ \sk -> do + ioPropertyWithSK @v lock $ \sk -> do sig :: SigDSIGNM v <- signDSIGNM () msg sk return $ prop_cbor_size sig ] , testGroup "direct matches class" [ testProperty "VerKey" $ - ioPropertyWithSK lock $ \sk -> do + ioPropertyWithSK @v lock $ \sk -> do vk :: VerKeyDSIGNM v <- deriveVerKeyDSIGNM sk return $ prop_cbor_direct_vs_class encodeVerKeyDSIGNM vk -- No CBOR testing for SignKey: sign keys are stored in MLocked memory -- and require IO for access. , testProperty "Sig" $ \(msg :: Message) -> - ioPropertyWithSK lock $ \sk -> do + ioPropertyWithSK @v lock $ \sk -> do sig :: SigDSIGNM v <- signDSIGNM () msg sk return $ prop_cbor_direct_vs_class encodeSigDSIGNM sig ] @@ -500,7 +500,7 @@ testDSIGNMAlgorithm lock _ n = -- timely forgetting. Special care must be taken to not leak the key outside of -- the wrapped action (be particularly mindful of thunks and unsafe key access -- here). -withSK :: (DSIGNMAlgorithm IO v) => PinnedSizedBytes (SeedSizeDSIGNM v) -> (SignKeyDSIGNM v -> IO b) -> IO b +withSK :: (DSIGNMAlgorithm v) => PinnedSizedBytes (SeedSizeDSIGNM v) -> (SignKeyDSIGNM v -> IO b) -> IO b withSK seedPSB action = withMLockedSeedFromPSB seedPSB $ \seed -> bracket @@ -515,7 +515,7 @@ withSK seedPSB action = -- memory. Special care must be taken to not leak the key outside of the -- wrapped action (be particularly mindful of thunks and unsafe key access -- here). -ioPropertyWithSK :: forall v a. (Testable a, DSIGNMAlgorithm IO v) +ioPropertyWithSK :: forall v a. (Testable a, DSIGNMAlgorithm v) => Lock -> (SignKeyDSIGNM v -> IO a) -> PinnedSizedBytes (SeedSizeDSIGNM v) @@ -525,7 +525,7 @@ ioPropertyWithSK lock action seedPSB = prop_key_overwritten_after_forget :: forall v. - (DSIGNMAlgorithm IO v + (DSIGNMAlgorithm v ) => Proxy v -> PinnedSizedBytes (SeedSizeDSIGNM v) @@ -536,20 +536,20 @@ prop_key_overwritten_after_forget p seedPSB = mlockedSeedFinalize seed seedBefore <- getSeedDSIGNM p sk - bsBefore <- NaCl.mlsbToByteString . mlockedSeedMLSB $ seedBefore + bsBefore <- mlsbToByteString . mlockedSeedMLSB $ seedBefore mlockedSeedFinalize seedBefore forgetSignKeyDSIGNM sk seedAfter <- getSeedDSIGNM p sk - bsAfter <- NaCl.mlsbToByteString . mlockedSeedMLSB $ seedAfter + bsAfter <- mlsbToByteString . mlockedSeedMLSB $ seedAfter mlockedSeedFinalize seedAfter return (bsBefore =/= bsAfter) prop_dsignm_seed_roundtrip :: forall v. - ( DSIGNMAlgorithm IO v + ( DSIGNMAlgorithm v ) => Proxy v -> PinnedSizedBytes (SeedSizeDSIGNM v) @@ -557,8 +557,8 @@ prop_dsignm_seed_roundtrip prop_dsignm_seed_roundtrip p seedPSB = ioProperty . withMLockedSeedFromPSB seedPSB $ \seed -> do sk <- genKeyDSIGNM seed seed' <- getSeedDSIGNM p sk - bs <- NaCl.mlsbToByteString . mlockedSeedMLSB $ seed - bs' <- NaCl.mlsbToByteString . mlockedSeedMLSB $ seed' + bs <- mlsbToByteString . mlockedSeedMLSB $ seed + bs' <- mlsbToByteString . mlockedSeedMLSB $ seed' forgetSignKeyDSIGNM sk mlockedSeedFinalize seed' return (bs === bs') @@ -594,7 +594,7 @@ prop_dsign_verify_wrong_key (msg, sk, sk') = in verifyDSIGN () vk' msg signed =/= Right () prop_dsignm_verify_pos - :: forall v. (DSIGNMAlgorithm IO v, ContextDSIGNM v ~ (), SignableM v Message) + :: forall v. (DSIGNMAlgorithm v, ContextDSIGNM v ~ (), SignableM v Message) => Lock -> Proxy v -> Message @@ -611,7 +611,7 @@ prop_dsignm_verify_pos lock _ msg = -- different signing key, then the verification fails. -- prop_dsignm_verify_neg_key - :: forall v. (DSIGNMAlgorithm IO v, ContextDSIGNM v ~ (), SignableM v Message) + :: forall v. (DSIGNMAlgorithm v, ContextDSIGNM v ~ (), SignableM v Message) => Lock -> Proxy v -> Message @@ -681,7 +681,7 @@ testEcdsaWithHashAlgorithm _ name = adjustOption defaultTestEnough . testGroup n #endif prop_dsignm_verify_neg_msg - :: forall v. (DSIGNMAlgorithm IO v, ContextDSIGNM v ~ (), SignableM v Message) + :: forall v. (DSIGNMAlgorithm v, ContextDSIGNM v ~ (), SignableM v Message) => Lock -> Proxy v -> Message diff --git a/cardano-crypto-tests/src/Test/Crypto/Instances.hs b/cardano-crypto-tests/src/Test/Crypto/Instances.hs index f295d99ee..7119b4c0e 100644 --- a/cardano-crypto-tests/src/Test/Crypto/Instances.hs +++ b/cardano-crypto-tests/src/Test/Crypto/Instances.hs @@ -12,13 +12,9 @@ import Data.Proxy (Proxy (Proxy)) import GHC.TypeLits (KnownNat, natVal) import Test.QuickCheck (Arbitrary (..)) import qualified Test.QuickCheck.Gen as Gen -import Cardano.Crypto.MonadSodium -import Cardano.Crypto.MLockedSeed -import Cardano.Crypto.PinnedSizedBytes ( - PinnedSizedBytes, - psbFromByteStringCheck, - psbToByteString, - ) +import Cardano.Crypto.Libsodium +import Cardano.Crypto.Libsodium.MLockedSeed +import Cardano.Crypto.PinnedSizedBytes import Control.Monad.Class.MonadThrow import Control.Monad.Class.MonadST @@ -37,19 +33,19 @@ import Control.Monad.Class.MonadST -- size :: Int -- size = fromInteger (natVal (Proxy :: Proxy n)) -mlsbFromPSB :: (MonadSodium m, MonadST m, KnownNat n) => PinnedSizedBytes n -> m (MLockedSizedBytes n) +mlsbFromPSB :: (MonadST m, KnownNat n) => PinnedSizedBytes n -> m (MLockedSizedBytes n) mlsbFromPSB = mlsbFromByteString . psbToByteString -withMLSBFromPSB :: (MonadSodium m, MonadST m, MonadThrow m, KnownNat n) => PinnedSizedBytes n -> (MLockedSizedBytes n -> m a) -> m a +withMLSBFromPSB :: (MonadST m, MonadThrow m, KnownNat n) => PinnedSizedBytes n -> (MLockedSizedBytes n -> m a) -> m a withMLSBFromPSB psb = bracket (mlsbFromPSB psb) mlsbFinalize -mlockedSeedFromPSB :: (MonadSodium m, MonadST m, KnownNat n) => PinnedSizedBytes n -> m (MLockedSeed n) +mlockedSeedFromPSB :: (MonadST m, KnownNat n) => PinnedSizedBytes n -> m (MLockedSeed n) mlockedSeedFromPSB = fmap MLockedSeed . mlsbFromPSB -withMLockedSeedFromPSB :: (MonadSodium m, MonadST m, MonadThrow m, KnownNat n) => PinnedSizedBytes n -> (MLockedSeed n -> m a) -> m a +withMLockedSeedFromPSB :: (MonadST m, MonadThrow m, KnownNat n) => PinnedSizedBytes n -> (MLockedSeed n -> m a) -> m a withMLockedSeedFromPSB psb = bracket (mlockedSeedFromPSB psb) diff --git a/cardano-crypto-tests/src/Test/Crypto/KES.hs b/cardano-crypto-tests/src/Test/Crypto/KES.hs index efad9bdca..4212f3188 100644 --- a/cardano-crypto-tests/src/Test/Crypto/KES.hs +++ b/cardano-crypto-tests/src/Test/Crypto/KES.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE DerivingVia #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} @@ -30,24 +31,21 @@ import Data.Set (Set) import qualified Data.Set as Set import Foreign.Ptr (WordPtr) import Data.IORef -import Data.Foldable (traverse_) import GHC.TypeNats (KnownNat) import Control.Tracer -import Control.Monad (void) -import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Class.MonadThrow -import Control.Monad.Class.MonadST +import Control.Monad.IO.Class (liftIO) +import Control.Monad (void) import Cardano.Crypto.DSIGN hiding (Signable) import Cardano.Crypto.Hash import Cardano.Crypto.KES -import Cardano.Crypto.KES.ForgetMock import Cardano.Crypto.Util (SignableRepresentation(..)) -import Cardano.Crypto.MLockedSeed -import qualified Cardano.Crypto.Libsodium as NaCl -import Cardano.Crypto.PinnedSizedBytes (PinnedSizedBytes) -import Cardano.Crypto.MonadSodium +import Cardano.Crypto.Libsodium +import Cardano.Crypto.Libsodium.MLockedSeed +import Cardano.Crypto.PinnedSizedBytes +import Cardano.Crypto.EqST import Test.QuickCheck import Test.Tasty (TestTree, testGroup, adjustOption) @@ -71,11 +69,11 @@ import Test.Crypto.Util ( Lock, withLock, ) -import Test.Crypto.RunIO (RunIO (..)) import Test.Crypto.Instances (withMLockedSeedFromPSB) import Test.Crypto.AllocLog {- HLINT ignore "Reduce duplication" -} +{- HLINT ignore "Use head" -} -- -- The list of all tests @@ -83,18 +81,18 @@ import Test.Crypto.AllocLog tests :: Lock -> TestTree tests lock = testGroup "Crypto.KES" - [ testKESAlloc (Proxy :: Proxy (SingleKES Ed25519DSIGNM)) "SingleKES" - , testKESAlloc (Proxy :: Proxy (Sum1KES Ed25519DSIGNM Blake2b_256)) "Sum1KES" - , testKESAlloc (Proxy :: Proxy (Sum2KES Ed25519DSIGNM Blake2b_256)) "Sum2KES" - , testKESAlgorithm lock (Proxy :: Proxy IO) (Proxy :: Proxy (MockKES 7)) "MockKES" - , testKESAlgorithm lock (Proxy :: Proxy IO) (Proxy :: Proxy (SimpleKES Ed25519DSIGNM 7)) "SimpleKES" - , testKESAlgorithm lock (Proxy :: Proxy IO) (Proxy :: Proxy (SingleKES Ed25519DSIGNM)) "SingleKES" - , testKESAlgorithm lock (Proxy :: Proxy IO) (Proxy :: Proxy (Sum1KES Ed25519DSIGNM Blake2b_256)) "Sum1KES" - , testKESAlgorithm lock (Proxy :: Proxy IO) (Proxy :: Proxy (Sum2KES Ed25519DSIGNM Blake2b_256)) "Sum2KES" - , testKESAlgorithm lock (Proxy :: Proxy IO) (Proxy :: Proxy (Sum5KES Ed25519DSIGNM Blake2b_256)) "Sum5KES" - , testKESAlgorithm lock (Proxy :: Proxy IO) (Proxy :: Proxy (CompactSum1KES Ed25519DSIGNM Blake2b_256)) "CompactSum1KES" - , testKESAlgorithm lock (Proxy :: Proxy IO) (Proxy :: Proxy (CompactSum2KES Ed25519DSIGNM Blake2b_256)) "CompactSum2KES" - , testKESAlgorithm lock (Proxy :: Proxy IO) (Proxy :: Proxy (CompactSum5KES Ed25519DSIGNM Blake2b_256)) "CompactSum5KES" + [ testKESAlloc (Proxy @(SingleKES Ed25519DSIGNM)) "SingleKES" + , testKESAlloc (Proxy @(Sum1KES Ed25519DSIGNM Blake2b_256)) "Sum1KES" + , testKESAlloc (Proxy @(Sum2KES Ed25519DSIGNM Blake2b_256)) "Sum2KES" + , testKESAlgorithm @(MockKES 7) lock "MockKES" + , testKESAlgorithm @(SimpleKES Ed25519DSIGNM 7) lock "SimpleKES" + , testKESAlgorithm @(SingleKES Ed25519DSIGNM) lock "SingleKES" + , testKESAlgorithm @(Sum1KES Ed25519DSIGNM Blake2b_256) lock "Sum1KES" + , testKESAlgorithm @(Sum2KES Ed25519DSIGNM Blake2b_256) lock "Sum2KES" + , testKESAlgorithm @(Sum5KES Ed25519DSIGNM Blake2b_256) lock "Sum5KES" + , testKESAlgorithm @(CompactSum1KES Ed25519DSIGNM Blake2b_256) lock "CompactSum1KES" + , testKESAlgorithm @(CompactSum2KES Ed25519DSIGNM Blake2b_256) lock "CompactSum2KES" + , testKESAlgorithm @(CompactSum5KES Ed25519DSIGNM Blake2b_256) lock "CompactSum5KES" ] -- We normally ensure that we avoid naively comparing signing keys by not @@ -103,7 +101,7 @@ tests lock = instance Show (SignKeyKES (SingleKES Ed25519DSIGNM)) where show (SignKeySingleKES (SignKeyEd25519DSIGNM mlsb)) = - let bytes = NaCl.mlsbAsByteString mlsb + let bytes = mlsbAsByteString mlsb hexstr = hexBS bytes in "SignKeySingleKES (SignKeyEd25519DSIGNM " ++ hexstr ++ ")" @@ -112,109 +110,50 @@ instance Show (SignKeyKES (SumKES h d)) where instance Show (SignKeyKES (CompactSingleKES Ed25519DSIGNM)) where show (SignKeyCompactSingleKES (SignKeyEd25519DSIGNM mlsb)) = - let bytes = NaCl.mlsbAsByteString mlsb + let bytes = mlsbAsByteString mlsb hexstr = hexBS bytes in "SignKeyCompactSingleKES (SignKeyEd25519DSIGNM " ++ hexstr ++ ")" instance Show (SignKeyKES (CompactSumKES h d)) where show _ = "" -deriving via (PureMEq (SignKeyKES (MockKES t))) instance Applicative m => MEq m (SignKeyKES (MockKES t)) +deriving via (PureEqST (SignKeyKES (MockKES t))) instance EqST (SignKeyKES (MockKES t)) -deriving newtype instance (MEq m (SignKeyDSIGNM d)) => MEq m (SignKeyKES (SingleKES d)) +deriving newtype instance (EqST (SignKeyDSIGNM d)) => EqST (SignKeyKES (SingleKES d)) -instance ( MonadSodium m - , MonadST m - , MEq m (SignKeyKES d) +instance ( EqST (SignKeyKES d) , Eq (VerKeyKES d) , KnownNat (SeedSizeKES d) - ) => MEq m (SignKeyKES (SumKES h d)) where + ) => EqST (SignKeyKES (SumKES h d)) where equalsM (SignKeySumKES s r v1 v2) (SignKeySumKES s' r' v1' v2') = - (s, r, PureMEq v1, PureMEq v2) ==! (s', r', PureMEq v1', PureMEq v2') + (s, r, PureEqST v1, PureEqST v2) ==! (s', r', PureEqST v1', PureEqST v2') -deriving newtype instance (MEq m (SignKeyDSIGNM d)) => MEq m (SignKeyKES (CompactSingleKES d)) +deriving newtype instance (EqST (SignKeyDSIGNM d)) => EqST (SignKeyKES (CompactSingleKES d)) -instance ( MonadSodium m - , MonadST m - , MEq m (SignKeyKES d) +instance ( EqST (SignKeyKES d) , Eq (VerKeyKES d) , KnownNat (SeedSizeKES d) - ) => MEq m (SignKeyKES (CompactSumKES h d)) where + ) => EqST (SignKeyKES (CompactSumKES h d)) where equalsM (SignKeyCompactSumKES s r v1 v2) (SignKeyCompactSumKES s' r' v1' v2') = - (s, r, PureMEq v1, PureMEq v2) ==! (s', r', PureMEq v1', PureMEq v2') + (s, r, PureEqST v1, PureEqST v2) ==! (s', r', PureEqST v1', PureEqST v2') testKESAlloc :: forall v. - ( (forall m. (MonadSodium m, MonadThrow m, MonadST m) => KESSignAlgorithm m v) - , ContextKES v ~ () + ( KESSignAlgorithm v ) => Proxy v -> String -> TestTree testKESAlloc _p n = testGroup n - [ testGroup "Forget mock" - [ testCase "genKey" $ testForgetGenKeyKES _p - , testCase "updateKey" $ testForgetUpdateKeyKES _p - ] - , testGroup "Low-level mlocked allocations" + [ testGroup "Low-level mlocked allocations" [ testCase "genKey" $ testMLockGenKeyKES _p -- , testCase "updateKey" $ testMLockUpdateKeyKES _p ] ] -testForgetGenKeyKES - :: forall v. - ( KESSignAlgorithm (LogT (GenericEvent ForgetMockEvent) IO) v - ) - => Proxy v - -> Assertion -testForgetGenKeyKES _p = do - logVar <- newIORef [] - let tracer :: Tracer (LogT (GenericEvent ForgetMockEvent) IO) (GenericEvent ForgetMockEvent) - tracer = Tracer (\ev -> liftIO $ modifyIORef logVar (++ [ev])) - runLogT tracer $ do - seed <- MLockedSeed <$> mlsbFromByteString (BS.replicate 1024 23) - sk <- genKeyKES @(LogT (GenericEvent ForgetMockEvent) IO) @(ForgetMockKES v) seed - mlockedSeedFinalize seed - forgetSignKeyKES sk - result <- map concreteEvent <$> readIORef logVar - assertBool ("Unexpected log: " ++ show result) $ case result of - [GEN a, DEL b] -> - -- End of last period, so no update happened - a == b - _ -> False - return () - -testForgetUpdateKeyKES - :: forall v. - ( KESSignAlgorithm (LogT (GenericEvent ForgetMockEvent) IO) v - , ContextKES v ~ () - ) - => Proxy v - -> Assertion -testForgetUpdateKeyKES _p = do - logVar <- newIORef [] - let tracer :: Tracer (LogT (GenericEvent ForgetMockEvent) IO) (GenericEvent ForgetMockEvent) - tracer = Tracer (\ev -> liftIO $ modifyIORef logVar (++ [ev])) - runLogT tracer $ do - seed <- MLockedSeed <$> NaCl.mlsbFromByteString (BS.replicate 1024 23) - sk <- genKeyKES @(LogT (GenericEvent ForgetMockEvent) IO) @(ForgetMockKES v) seed - mlockedSeedFinalize seed - msk' <- updateKES () sk 0 - forgetSignKeyKES sk - traverse_ forgetSignKeyKES msk' - result <- map concreteEvent <$> readIORef logVar - - assertBool ("Unexpected log: " ++ show result) $ case result of - [GEN a, UPD b c, DEL d, DEL e] -> - -- Regular update - a == b && d == a && e == c - [GEN a, NOUPD, DEL b] -> - -- End of last period, so no update happened - a == b - _ -> False - +eventTracer :: IORef [event] -> Tracer IO event +eventTracer logVar = Tracer (\ev -> liftIO $ atomicModifyIORef' logVar (\acc -> (acc ++ [ev], ()))) matchAllocLog :: [AllocEvent] -> Set WordPtr matchAllocLog = foldl' (flip go) Set.empty @@ -225,54 +164,51 @@ matchAllocLog = foldl' (flip go) Set.empty testMLockGenKeyKES :: forall v. - ( KESSignAlgorithm (AllocLogT IO) v - ) + KESSignAlgorithm v => Proxy v -> Assertion testMLockGenKeyKES _p = do accumVar <- newIORef [] - let tracer = Tracer (\ev -> liftIO $ modifyIORef accumVar (++ [ev])) - runAllocLogT tracer $ do - pushAllocLogEvent $ MarkerEv "gen seed" - (seed :: MLockedSeed (SeedSizeKES v)) <- MLockedSeed <$> NaCl.mlsbFromByteString (BS.replicate 1024 23) - pushAllocLogEvent $ MarkerEv "gen key" - sk <- genKeyKES @_ @v seed - pushAllocLogEvent $ MarkerEv "forget key" - forgetSignKeyKES sk - pushAllocLogEvent $ MarkerEv "forget seed" - mlockedSeedFinalize seed - pushAllocLogEvent $ MarkerEv "done" + let tracer = eventTracer accumVar + let allocator = mkLoggingAllocator tracer mlockedMalloc + traceWith tracer $ MarkerEv "gen seed" + seed :: MLockedSeed (SeedSizeKES v) <- + MLockedSeed <$> mlsbFromByteStringWith allocator (BS.replicate 1024 23) + traceWith tracer $ MarkerEv "gen key" + sk <- genKeyKESWith @v allocator seed + traceWith tracer $ MarkerEv "forget key" + forgetSignKeyKESWith allocator sk + traceWith tracer $ MarkerEv "forget seed" + mlockedSeedFinalize seed + traceWith tracer $ MarkerEv "done" after <- readIORef accumVar let evset = matchAllocLog after + assertBool "some allocations happened" (not . null $ [ () | AllocEv _ <- after ]) assertEqual "all allocations deallocated" Set.empty evset {-# NOINLINE testKESAlgorithm#-} testKESAlgorithm - :: forall m v. + :: forall v. ( ToCBOR (VerKeyKES v) , FromCBOR (VerKeyKES v) - , MEq IO (SignKeyKES v) -- only monadic MEq for signing keys + , EqST (SignKeyKES v) -- only monadic EqST for signing keys , Show (SignKeyKES v) -- fake instance defined locally , ToCBOR (SigKES v) , FromCBOR (SigKES v) , Signable v ~ SignableRepresentation , ContextKES v ~ () - , KESSignAlgorithm m v - -- , KESSignAlgorithm IO v -- redundant for now - , UnsoundKESSignAlgorithm IO v + , UnsoundKESSignAlgorithm v ) => Lock - -> Proxy m - -> Proxy v -> String -> TestTree -testKESAlgorithm lock _pm _pv n = +testKESAlgorithm lock n = testGroup n - [ testProperty "only gen signkey" $ prop_onlyGenSignKeyKES @v lock Proxy - , testProperty "only gen verkey" $ prop_onlyGenVerKeyKES @v lock Proxy - , testProperty "one update signkey" $ prop_oneUpdateSignKeyKES lock (Proxy @IO) (Proxy @v) - , testProperty "all updates signkey" $ prop_allUpdatesSignKeyKES lock (Proxy @IO) (Proxy @v) - , testProperty "total periods" $ prop_totalPeriodsKES lock (Proxy @IO) (Proxy @v) + [ testProperty "only gen signkey" $ prop_onlyGenSignKeyKES @v lock + , testProperty "only gen verkey" $ prop_onlyGenVerKeyKES @v lock + , testProperty "one update signkey" $ prop_oneUpdateSignKeyKES @v lock + , testProperty "all updates signkey" $ prop_allUpdatesSignKeyKES @v lock + , testProperty "total periods" $ prop_totalPeriodsKES @v lock , testGroup "NoThunks" [ testProperty "VerKey" $ ioPropertyWithSK @v lock $ \sk -> @@ -287,11 +223,11 @@ testKESAlgorithm lock _pm _pv n = (maybe (return ()) forgetSignKeyKES) (prop_no_thunks_IO . return) , testProperty "Sig" $ \seedPSB (msg :: Message) -> - ioProperty $ withLock lock $ fmap conjoin $ withAllUpdatesKES @IO @v seedPSB $ \t sk -> do + ioProperty $ withLock lock $ fmap conjoin $ withAllUpdatesKES @v seedPSB $ \t sk -> do prop_no_thunks_IO (signKES () t msg sk) ] - , testProperty "same VerKey " $ prop_deriveVerKeyKES (Proxy @IO) (Proxy @v) + , testProperty "same VerKey " $ prop_deriveVerKeyKES @v , testGroup "serialisation" [ testGroup "raw ser only" @@ -380,16 +316,16 @@ testKESAlgorithm lock _pm _pv n = ] , testGroup "verify" - [ testProperty "positive" $ prop_verifyKES_positive @IO @v Proxy Proxy - , testProperty "negative (key)" $ prop_verifyKES_negative_key @IO @v Proxy Proxy - , testProperty "negative (message)" $ prop_verifyKES_negative_message @IO @v Proxy Proxy + [ testProperty "positive" $ prop_verifyKES_positive @v + , testProperty "negative (key)" $ prop_verifyKES_negative_key @v + , testProperty "negative (message)" $ prop_verifyKES_negative_message @v , adjustOption (\(QuickCheckMaxSize sz) -> QuickCheckMaxSize (min sz 50)) $ - testProperty "negative (period)" $ prop_verifyKES_negative_period @IO @v Proxy Proxy + testProperty "negative (period)" $ prop_verifyKES_negative_period @v ] , testGroup "serialisation of all KES evolutions" - [ testProperty "VerKey" $ prop_serialise_VerKeyKES @IO @v Proxy Proxy - , testProperty "Sig" $ prop_serialise_SigKES @IO @v Proxy Proxy + [ testProperty "VerKey" $ prop_serialise_VerKeyKES @v + , testProperty "Sig" $ prop_serialise_SigKES @v ] -- TODO: this doesn't pass right now, see @@ -406,11 +342,8 @@ testKESAlgorithm lock _pm _pv n = -- timely forgetting. Special care must be taken to not leak the key outside of -- the wrapped action (be particularly mindful of thunks and unsafe key access -- here). -withSK :: ( MonadSodium m - , MonadST m - , MonadThrow m - , KESSignAlgorithm m v - ) => PinnedSizedBytes (SeedSizeKES v) -> (SignKeyKES v -> m b) -> m b +withSK :: KESSignAlgorithm v + => PinnedSizedBytes (SeedSizeKES v) -> (SignKeyKES v -> IO b) -> IO b withSK seedPSB = bracket (withMLockedSeedFromPSB seedPSB genKeyKES) @@ -423,7 +356,7 @@ withSK seedPSB = -- memory. Special care must be taken to not leak the key outside of the -- wrapped action (be particularly mindful of thunks and unsafe key access -- here). -ioPropertyWithSK :: forall v a. (Testable a, KESSignAlgorithm IO v) +ioPropertyWithSK :: forall v a. (Testable a, KESSignAlgorithm v) => Lock -> (SignKeyKES v -> IO a) -> PinnedSizedBytes (SeedSizeKES v) @@ -456,70 +389,55 @@ ioPropertyWithSK lock action seedPSB = prop_onlyGenSignKeyKES :: forall v. - KESSignAlgorithm IO v - => Lock -> Proxy v -> PinnedSizedBytes (SeedSizeKES v) -> Property -prop_onlyGenSignKeyKES lock _ = + KESSignAlgorithm v + => Lock -> PinnedSizedBytes (SeedSizeKES v) -> Property +prop_onlyGenSignKeyKES lock = ioPropertyWithSK @v lock $ const noExceptionsThrown prop_onlyGenVerKeyKES :: forall v. - KESSignAlgorithm IO v - => Lock -> Proxy v -> PinnedSizedBytes (SeedSizeKES v) -> Property -prop_onlyGenVerKeyKES lock _ = + KESSignAlgorithm v + => Lock -> PinnedSizedBytes (SeedSizeKES v) -> Property +prop_onlyGenVerKeyKES lock = ioPropertyWithSK @v lock $ doesNotThrow . deriveVerKeyKES prop_oneUpdateSignKeyKES - :: forall m v. + :: forall v. ( ContextKES v ~ () - , RunIO m - , MonadFail m - , MonadSodium m - , MonadST m - , MonadThrow m - , KESSignAlgorithm m v + , KESSignAlgorithm v ) - => Lock -> Proxy m -> Proxy v -> PinnedSizedBytes (SeedSizeKES v) -> Property -prop_oneUpdateSignKeyKES lock _ _ seedPSB = - ioProperty . withLock lock . io . withMLockedSeedFromPSB seedPSB $ \seed -> do - sk <- genKeyKES @m @v seed - msk' <- updateKES @m () sk 0 + => Lock -> PinnedSizedBytes (SeedSizeKES v) -> Property +prop_oneUpdateSignKeyKES lock seedPSB = + ioProperty . withLock lock . withMLockedSeedFromPSB seedPSB $ \seed -> do + sk <- genKeyKES @v seed + msk' <- updateKES () sk 0 forgetSignKeyKES sk maybe (return ()) forgetSignKeyKES msk' return True prop_allUpdatesSignKeyKES - :: forall m v. + :: forall v. ( ContextKES v ~ () - , RunIO m - , MonadIO m - , MonadSodium m - , MonadST m - , MonadThrow m - , KESSignAlgorithm m v + , KESSignAlgorithm v ) - => Lock -> Proxy m -> Proxy v -> PinnedSizedBytes (SeedSizeKES v) -> Property -prop_allUpdatesSignKeyKES lock _ _ seedPSB = - ioProperty . withLock lock . io $ do - void $ withAllUpdatesKES_ @m @v seedPSB $ const (return ()) + => Lock -> PinnedSizedBytes (SeedSizeKES v) -> Property +prop_allUpdatesSignKeyKES lock seedPSB = + ioProperty . withLock lock $ do + void $ withAllUpdatesKES_ @v seedPSB $ const (return ()) -- | If we start with a signing key, we can evolve it a number of times so that -- the total number of signing keys (including the initial one) equals the -- total number of periods for this algorithm. -- prop_totalPeriodsKES - :: forall m v. + :: forall v. ( ContextKES v ~ () - , RunIO m - , MonadIO m - , MonadSodium m - , MonadST m - , MonadThrow m - , KESSignAlgorithm m v + , KESSignAlgorithm v ) - => Lock -> Proxy m -> Proxy v -> PinnedSizedBytes (SeedSizeKES v) -> Property -prop_totalPeriodsKES lock _ _ seed = + => Lock -> PinnedSizedBytes (SeedSizeKES v) -> Property +prop_totalPeriodsKES lock seed = ioProperty . withLock lock $ do - sks <- io $ withAllUpdatesKES_ @m @v seed (const . return $ ()) + sks <- withAllUpdatesKES_ @v seed (const . return $ ()) return $ totalPeriods > 0 ==> counterexample (show totalPeriods) $ @@ -534,25 +452,20 @@ prop_totalPeriodsKES lock _ _ seed = -- keys we derive from each one are the same. -- prop_deriveVerKeyKES - :: forall m v. + :: forall v. ( ContextKES v ~ () - , RunIO m - , MonadIO m - , MonadSodium m - , MonadST m - , MonadThrow m - , KESSignAlgorithm m v + , KESSignAlgorithm v ) - => Proxy m -> Proxy v -> PinnedSizedBytes (SeedSizeKES v) -> Property -prop_deriveVerKeyKES _ _ seedPSB = + => PinnedSizedBytes (SeedSizeKES v) -> Property +prop_deriveVerKeyKES seedPSB = ioProperty $ do - vk_0 <- io $ do - sk_0 <- withMLockedSeedFromPSB seedPSB $ genKeyKES @m @v - vk_0 <- deriveVerKeyKES @m sk_0 + vk_0 <- do + sk_0 <- withMLockedSeedFromPSB seedPSB $ genKeyKES @v + vk_0 <- deriveVerKeyKES sk_0 forgetSignKeyKES sk_0 return vk_0 - vks <- io $ withAllUpdatesKES_ seedPSB $ deriveVerKeyKES @m + vks <- withAllUpdatesKES_ seedPSB deriveVerKeyKES return $ counterexample (show vks) $ conjoin (map (vk_0 ===) vks) @@ -563,25 +476,20 @@ prop_deriveVerKeyKES _ _ seedPSB = -- corresponding period. -- prop_verifyKES_positive - :: forall m v. + :: forall v. ( ContextKES v ~ () , Signable v ~ SignableRepresentation - , RunIO m - , MonadIO m - , MonadSodium m - , MonadST m - , MonadThrow m - , KESSignAlgorithm m v + , KESSignAlgorithm v ) - => Proxy m -> Proxy v -> PinnedSizedBytes (SeedSizeKES v) -> Gen Property -prop_verifyKES_positive _ _ seedPSB = do + => PinnedSizedBytes (SeedSizeKES v) -> Gen Property +prop_verifyKES_positive seedPSB = do xs :: [Message] <- vectorOf totalPeriods arbitrary return $ checkCoverage $ cover 1 (length xs >= totalPeriods) "Message count covers total periods" $ not (null xs) ==> - ioProperty $ fmap conjoin $ io $ do - sk_0 <- withMLockedSeedFromPSB seedPSB $ genKeyKES @m @v - vk <- deriveVerKeyKES @m sk_0 + ioProperty $ fmap conjoin $ do + sk_0 <- withMLockedSeedFromPSB seedPSB $ genKeyKES @v + vk <- deriveVerKeyKES sk_0 forgetSignKeyKES sk_0 withAllUpdatesKES seedPSB $ \t sk -> do let x = cycle xs !! fromIntegral t @@ -600,24 +508,18 @@ prop_verifyKES_positive _ _ seedPSB = do -- corresponding to a different signing key, then the verification fails. -- prop_verifyKES_negative_key - :: forall m v. + :: forall v. ( ContextKES v ~ () , Signable v ~ SignableRepresentation - , RunIO m - , MonadIO m - , MonadSodium m - , MonadST m - , MonadThrow m - , KESSignAlgorithm m v + , KESSignAlgorithm v ) - => Proxy m -> Proxy v - -> PinnedSizedBytes (SeedSizeKES v) + => PinnedSizedBytes (SeedSizeKES v) -> PinnedSizedBytes (SeedSizeKES v) -> Message -> Property -prop_verifyKES_negative_key _ _ seedPSB seedPSB' x = - seedPSB /= seedPSB' ==> ioProperty $ fmap conjoin $ io $ do - sk_0' <- withMLockedSeedFromPSB seedPSB' $ genKeyKES @m @v +prop_verifyKES_negative_key seedPSB seedPSB' x = + seedPSB /= seedPSB' ==> ioProperty $ fmap conjoin $ do + sk_0' <- withMLockedSeedFromPSB seedPSB' $ genKeyKES @v vk' <- deriveVerKeyKES sk_0' forgetSignKeyKES sk_0' withAllUpdatesKES seedPSB $ \t sk -> do @@ -632,24 +534,18 @@ prop_verifyKES_negative_key _ _ seedPSB seedPSB' x = -- verification fails. -- prop_verifyKES_negative_message - :: forall m v. + :: forall v. ( ContextKES v ~ () , Signable v ~ SignableRepresentation - , RunIO m - , MonadIO m - , MonadSodium m - , MonadST m - , MonadThrow m - , KESSignAlgorithm m v + , KESSignAlgorithm v ) - => Proxy m -> Proxy v - -> PinnedSizedBytes (SeedSizeKES v) + => PinnedSizedBytes (SeedSizeKES v) -> Message -> Message -> Property -prop_verifyKES_negative_message _ _ seedPSB x x' = - x /= x' ==> ioProperty $ fmap conjoin $ io $ do - sk_0 <- withMLockedSeedFromPSB seedPSB $ genKeyKES @m @v - vk <- deriveVerKeyKES @m sk_0 +prop_verifyKES_negative_message seedPSB x x' = + x /= x' ==> ioProperty $ fmap conjoin $ do + sk_0 <- withMLockedSeedFromPSB seedPSB $ genKeyKES @v + vk <- deriveVerKeyKES sk_0 forgetSignKeyKES sk_0 withAllUpdatesKES seedPSB $ \t sk -> do sig <- signKES () t x sk @@ -664,24 +560,18 @@ prop_verifyKES_negative_message _ _ seedPSB x x' = -- verification fails. -- prop_verifyKES_negative_period - :: forall m v. + :: forall v. ( ContextKES v ~ () , Signable v ~ SignableRepresentation - , RunIO m - , MonadIO m - , MonadSodium m - , MonadST m - , MonadThrow m - , KESSignAlgorithm m v + , KESSignAlgorithm v ) - => Proxy m -> Proxy v - -> PinnedSizedBytes (SeedSizeKES v) + => PinnedSizedBytes (SeedSizeKES v) -> Message -> Property -prop_verifyKES_negative_period _ _ seedPSB x = - ioProperty $ fmap conjoin $ io $ do - sk_0 <- withMLockedSeedFromPSB seedPSB $ genKeyKES @m @v - vk <- deriveVerKeyKES @m sk_0 +prop_verifyKES_negative_period seedPSB x = + ioProperty $ fmap conjoin $ do + sk_0 <- withMLockedSeedFromPSB seedPSB $ genKeyKES @v + vk <- deriveVerKeyKES sk_0 forgetSignKeyKES sk_0 withAllUpdatesKES seedPSB $ \t sk -> do sig <- signKES () t x sk @@ -700,22 +590,16 @@ prop_verifyKES_negative_period _ _ seedPSB x = -- for 'VerKeyKES' on /all/ the KES key evolutions. -- prop_serialise_VerKeyKES - :: forall m v. + :: forall v. ( ContextKES v ~ () - , RunIO m - , MonadIO m - , MonadSodium m - , MonadST m - , MonadThrow m - , KESSignAlgorithm m v + , KESSignAlgorithm v ) - => Proxy m -> Proxy v - -> PinnedSizedBytes (SeedSizeKES v) + => PinnedSizedBytes (SeedSizeKES v) -> Property -prop_serialise_VerKeyKES _ _ seedPSB = - ioProperty $ fmap conjoin $ io $ do - withAllUpdatesKES @m @v seedPSB $ \t sk -> do - vk <- deriveVerKeyKES @m sk +prop_serialise_VerKeyKES seedPSB = + ioProperty $ fmap conjoin $ do + withAllUpdatesKES @v seedPSB $ \t sk -> do + vk <- deriveVerKeyKES sk return $ counterexample ("period " ++ show t) $ counterexample ("vkey " ++ show vk) $ @@ -730,24 +614,18 @@ prop_serialise_VerKeyKES _ _ seedPSB = -- for 'SigKES' on /all/ the KES key evolutions. -- prop_serialise_SigKES - :: forall m v. + :: forall v. ( ContextKES v ~ () , Signable v ~ SignableRepresentation , Show (SignKeyKES v) - , RunIO m - , MonadIO m - , MonadSodium m - , MonadST m - , MonadThrow m - , KESSignAlgorithm m v + , KESSignAlgorithm v ) - => Proxy m -> Proxy v - -> PinnedSizedBytes (SeedSizeKES v) + => PinnedSizedBytes (SeedSizeKES v) -> Message -> Property -prop_serialise_SigKES _ _ seedPSB x = - ioProperty $ fmap conjoin $ io $ do - withAllUpdatesKES @m @v seedPSB $ \t sk -> do +prop_serialise_SigKES seedPSB x = + ioProperty $ fmap conjoin $ do + withAllUpdatesKES @v seedPSB $ \t sk -> do sig <- signKES () t x sk return $ counterexample ("period " ++ show t) $ @@ -764,34 +642,28 @@ prop_serialise_SigKES _ _ seedPSB x = -- KES test utils -- -withAllUpdatesKES_ :: forall m v a. - ( KESSignAlgorithm m v +withAllUpdatesKES_ :: forall v a. + ( KESSignAlgorithm v , ContextKES v ~ () - , MonadSodium m - , MonadST m - , MonadThrow m ) => PinnedSizedBytes (SeedSizeKES v) - -> (SignKeyKES v -> m a) - -> m [a] + -> (SignKeyKES v -> IO a) + -> IO [a] withAllUpdatesKES_ seedPSB f = do withAllUpdatesKES seedPSB (const f) -withAllUpdatesKES :: forall m v a. - ( KESSignAlgorithm m v +withAllUpdatesKES :: forall v a. + ( KESSignAlgorithm v , ContextKES v ~ () - , MonadSodium m - , MonadST m - , MonadThrow m ) => PinnedSizedBytes (SeedSizeKES v) - -> (Word -> SignKeyKES v -> m a) - -> m [a] + -> (Word -> SignKeyKES v -> IO a) + -> IO [a] withAllUpdatesKES seedPSB f = withMLockedSeedFromPSB seedPSB $ \seed -> do sk_0 <- genKeyKES seed go sk_0 0 where - go :: SignKeyKES v -> Word -> m [a] + go :: SignKeyKES v -> Word -> IO [a] go sk t = do x <- f t sk msk' <- updateKES () sk t diff --git a/cardano-crypto-tests/src/Test/Crypto/Util.hs b/cardano-crypto-tests/src/Test/Crypto/Util.hs index 1660f35dd..c0c7d7441 100644 --- a/cardano-crypto-tests/src/Test/Crypto/Util.hs +++ b/cardano-crypto-tests/src/Test/Crypto/Util.hs @@ -130,7 +130,7 @@ import qualified Test.QuickCheck.Gen as Gen import Control.Monad (guard, when) import GHC.TypeLits (Nat, KnownNat, natVal) import Formatting.Buildable (Buildable (..), build) -import Control.Concurrent.MVar (MVar, withMVar, newMVar) +import Control.Concurrent.Class.MonadMVar (MVar, withMVar, newMVar) import GHC.Stack (HasCallStack) -------------------------------------------------------------------------------- @@ -364,7 +364,7 @@ noExceptionsThrown = pure (property True) doesNotThrow :: Applicative m => m a -> m Property doesNotThrow = (*> noExceptionsThrown) -newtype Lock = Lock (MVar ()) +newtype Lock = Lock (MVar IO ()) withLock :: Lock -> IO a -> IO a withLock (Lock v) = withMVar v . const diff --git a/cardano-mempool/src/Cardano/Memory/Pool.hs b/cardano-mempool/src/Cardano/Memory/Pool.hs index d18aa9cfc..0be97d759 100644 --- a/cardano-mempool/src/Cardano/Memory/Pool.hs +++ b/cardano-mempool/src/Cardano/Memory/Pool.hs @@ -18,36 +18,39 @@ -- Currently there is no functionality for releasing unused pages. So, once a page is -- allocated, it will be re-used when more `Block`s is needed, but it will not be GCed -- until the whole `Pool` is GCed. -module Cardano.Memory.Pool - ( -- * Pool - Pool - , initPool +module Cardano.Memory.Pool ( + -- * Pool + Pool, + initPool, + -- * Block - , Block(..) - , blockByteCount - , grabNextBlock + Block (..), + blockByteCount, + grabNextBlock, + -- * Helpers + -- -- Exported for testing - , countPages - , findNextZeroIndex - ) where + countPages, + findNextZeroIndex, +) where -import Control.Monad -import Control.Monad.Primitive -import Foreign.Ptr -import Foreign.ForeignPtr -import GHC.ForeignPtr import Control.Applicative +import Control.Monad import Data.Bits -import GHC.TypeLits -import Data.Primitive.PrimArray +import Data.Primitive.MutVar import Data.Primitive.PVar import Data.Primitive.PVar.Unsafe (atomicModifyIntArray#) -import Data.IORef -import GHC.Int -import GHC.IO +import Data.Primitive.PrimArray +import Foreign.ForeignPtr +import Foreign.Ptr import GHC.Exts (fetchAndIntArray#) +import GHC.ForeignPtr (addForeignPtrConcFinalizer) +import GHC.IO +import GHC.Int +import GHC.ST +import GHC.TypeLits -- | This is just a proxy type that carries information at the type level about the size -- of the block in bytes supported by a particular instance of a `Pool`. Use @@ -61,78 +64,76 @@ blockByteCount = fromInteger . natVal -- | Internal helper type that manages each individual page. This is essentailly a mutable -- linked list, which contains a memory buffer, a bit array that tracks which blocks in -- the buffere are free and which ones are taken. -data Page n = - Page - { pageMemory :: !(ForeignPtr (Block n)) - -- ^ Contiguous memory buffer that holds all the blocks in the page. - , pageBitArray :: !(MutablePrimArray RealWorld Int) - -- ^ We use an Int array, because there are no built-in atomic primops for Word. - , pageFull :: !(PVar Int RealWorld) - -- ^ This is a boolean flag which indicates when a page is full. It here as - -- optimization only, because it allows us to skip iteration of the above bit - -- array. It is an `Int` instead of a `Bool`, because GHC provides atomic primops for - -- ByteArray, whcih is what `PVar` is based on. - , pageNextPage :: !(IORef (Maybe (Page n))) - -- ^ Link to the next page. Last page when this IORef contains `Nothing` - } +data Page n s = Page + { pageMemory :: !(ForeignPtr (Block n)) + -- ^ Contiguous memory buffer that holds all the blocks in the page. + , pageBitArray :: !(MutablePrimArray s Int) + -- ^ We use an Int array, because there are no built-in atomic primops for Word. + , pageFull :: !(PVar Int s) + -- ^ This is a boolean flag which indicates when a page is full. It here as + -- optimization only, because it allows us to skip iteration of the above bit + -- array. It is an `Int` instead of a `Bool`, because GHC provides atomic primops for + -- ByteArray, whcih is what `PVar` is based on. + , pageNextPage :: !(MutVar s (Maybe (Page n s))) + -- ^ Link to the next page. Last page when this IORef contains `Nothing` + } -- | Thread-safe lock-free memory pool for managing large memory pages that contain of -- many small `Block`s. -data Pool n = - Pool - { poolFirstPage :: !(Page n) - -- ^ Initial page, which itself contains references to subsequent pages - , poolPageInitializer :: !(IO (Page n)) - -- ^ Page initializing action - , poolBlockFinalizer :: !(Ptr (Block n) -> IO ()) - -- ^ Finilizer that will be attached to each individual `ForeignPtr` of a reserved - -- `Block`. - } +data Pool n s = Pool + { poolFirstPage :: !(Page n s) + -- ^ Initial page, which itself contains references to subsequent pages + , poolPageInitializer :: !(ST s (Page n s)) + -- ^ Page initializing action + , poolBlockFinalizer :: !(Ptr (Block n) -> IO ()) + -- ^ Finilizer that will be attached to each individual `ForeignPtr` of a reserved + -- `Block`. + } -- | Useful function for testing. Check how many pages have been allocated thus far. -countPages :: Pool n -> IO Int +countPages :: Pool n s -> ST s Int countPages pool = go 1 (poolFirstPage pool) where - go n Page {pageNextPage} = do - readIORef pageNextPage >>= \case + go n Page{pageNextPage} = do + readMutVar pageNextPage >>= \case Nothing -> pure n Just nextPage -> go (n + 1) nextPage - ixBitSize :: Int ixBitSize = finiteBitSize (0 :: Word) -- | Initilizes the `Pool` that can be used for further allocation of @`ForeignPtr` -- `Block` n@ with `grabNextBlock`. -initPool :: - forall n. KnownNat n +initPool + :: forall n s + . KnownNat n => Int -- ^ Number of groups per page. Must be a posititve number, otherwise error. One group -- contains as many blocks as the operating system has bits. A 64bit architecture will -- have 64 blocks per group. For example, if program is compiled on a 64 bit OS and you -- know ahead of time the maximum number of blocks that will be allocated through out -- the program, then the optimal value for this argument will @maxBlockNum/64@ - -> (forall a. Int -> IO (ForeignPtr a)) + -> (forall a. Int -> ST s (ForeignPtr a)) -- ^ Mempool page allocator. Some allocated pages might be immediately discarded, -- therefore number of pages utilized will not necessesarely match the number of times -- this action will be called. -> (Ptr (Block n) -> IO ()) -- ^ Finalizer to use for each block. It is an IO action because it will be executed by -- the Garbage Collector in a separate thread once the `Block` is no longer referenced. - -> IO (Pool n) + -> ST s (Pool n s) initPool groupsPerPage memAlloc blockFinalizer = do unless (groupsPerPage > 0) $ error $ - "Groups per page should be a positive number, but got: " ++ - show groupsPerPage + "Groups per page should be a positive number, but got: " + ++ show groupsPerPage let pageInit = do pageMemory <- memAlloc $ groupsPerPage * ixBitSize * blockByteCount (Block :: Block n) pageBitArray <- newPrimArray groupsPerPage setPrimArray pageBitArray 0 groupsPerPage 0 pageFull <- newPVar 0 - pageNextPage <- newIORef Nothing - pure Page {..} + pageNextPage <- newMutVar Nothing + pure Page{..} firstPage <- pageInit pure Pool @@ -145,45 +146,49 @@ initPool groupsPerPage memAlloc blockFinalizer = do -- finalizer attached to the `ForeignPtr` that will run `Block` pointer finalizer and -- release that memory for re-use by other blocks allocated in the future. It is safe to -- add more Haskell finalizers with `addForeignPtrConcFinalizer` if necessary. -grabNextBlock :: KnownNat n => Pool n -> IO (ForeignPtr (Block n)) +grabNextBlock :: KnownNat n => Pool n s -> ST s (ForeignPtr (Block n)) grabNextBlock = grabNextPoolBlockWith grabNextPageForeignPtr {-# INLINE grabNextBlock #-} -- | This is a helper function that will allocate a `Page` if the current `Page` in the -- `Pool` is full. Whenever there are still block slots are available then supplied -- @grabNext@ function will be used to reserve the slot in that `Page`. -grabNextPoolBlockWith :: - (Page n -> (Ptr (Block n) -> IO ()) -> IO (Maybe (ForeignPtr (Block n)))) - -> Pool n - -> IO (ForeignPtr (Block n)) +grabNextPoolBlockWith + :: (Page n s -> (Ptr (Block n) -> IO ()) -> ST s (Maybe (ForeignPtr (Block n)))) + -> Pool n s + -> ST s (ForeignPtr (Block n)) grabNextPoolBlockWith grabNext pool = go (poolFirstPage pool) where go page = do isPageFull <- atomicReadIntPVar (pageFull page) if intToBool isPageFull - then readIORef (pageNextPage page) >>= \case - Nothing -> do - newPage <- poolPageInitializer pool - -- There is a slight chance of a race condition in that the next page could - -- have been allocated and assigned to 'pageNextPage' by another thread - -- since we last checked for it. This is not a problem since we can safely - -- discard the page created in this thread and switch to the one that was - -- assigned to 'pageNextPage'. - mNextPage <- - atomicModifyIORef' (pageNextPage page) $ \mNextPage -> - (mNextPage <|> Just newPage, mNextPage) - case mNextPage of - Nothing -> go newPage - Just existingPage -> do - -- Here we cleanup the newly allocated page in favor of the one that - -- was potentially created by another thread. It is important to - -- eagerly free up scarce resources - finalizeForeignPtr (pageMemory newPage) - go existingPage - Just nextPage -> go nextPage - else grabNext page (poolBlockFinalizer pool) >>= \case - Nothing -> go page - Just ma -> pure ma + then + readMutVar (pageNextPage page) >>= \case + Nothing -> do + newPage <- poolPageInitializer pool + -- There is a slight chance of a race condition in that the next page could + -- have been allocated and assigned to 'pageNextPage' by another thread + -- since we last checked for it. This is not a problem since we can safely + -- discard the page created in this thread and switch to the one that was + -- assigned to 'pageNextPage'. + mNextPage <- + atomicModifyMutVar' (pageNextPage page) $ \mNextPage -> + (mNextPage <|> Just newPage, mNextPage) + case mNextPage of + Nothing -> go newPage + Just existingPage -> do + -- Here we cleanup the newly allocated page in favor of the one that + -- was potentially created by another thread. It is important to + -- eagerly free up scarce resources. + -- + -- This operation is idempotent and thread safe + unsafeIOToST $ finalizeForeignPtr (pageMemory newPage) + go existingPage + Just nextPage -> go nextPage + else + grabNext page (poolBlockFinalizer pool) >>= \case + Nothing -> go page + Just ma -> pure ma {-# INLINE grabNextPoolBlockWith #-} intToBool :: Int -> Bool @@ -193,14 +198,14 @@ intToBool _ = True -- | This is a helper function that will attempt to find the next available slot for the -- `Block` and create a `ForeignPtr` with the size of `Block` in the `Page`. In case when -- `Page` is full it will return `Nothing`. -grabNextPageForeignPtr :: - forall n. - KnownNat n - -- | Page to grab the block from - => Page n - -- | Finalizer to run, once the `ForeignPtr` holding on to `Ptr` `Block` is no longer used +grabNextPageForeignPtr + :: forall n s + . KnownNat n + => Page n s + -- ^ Page to grab the block from -> (Ptr (Block n) -> IO ()) - -> IO (Maybe (ForeignPtr (Block n))) + -- ^ Finalizer to run, once the `ForeignPtr` holding on to `Ptr` `Block` is no longer used + -> ST s (Maybe (ForeignPtr (Block n))) grabNextPageForeignPtr page finalizer = grabNextPageWithAllocator page $ \blockPtr resetIndex -> do fp <- newForeignPtr_ blockPtr @@ -208,12 +213,13 @@ grabNextPageForeignPtr page finalizer = pure fp {-# INLINE grabNextPageForeignPtr #-} -grabNextPageWithAllocator :: - forall n. KnownNat n - => Page n +grabNextPageWithAllocator + :: forall n s + . KnownNat n + => Page n s -> (Ptr (Block n) -> IO () -> IO (ForeignPtr (Block n))) - -> IO (Maybe (ForeignPtr (Block n))) -grabNextPageWithAllocator Page {..} allocator = do + -> ST s (Maybe (ForeignPtr (Block n))) +grabNextPageWithAllocator Page{..} allocator = do setNextZero pageBitArray >>= \case -- There is a slight chance that some Blocks will be cleared before the pageFull is -- set to True. This is not a problem because that memory will be recovered as soon as @@ -225,29 +231,30 @@ grabNextPageWithAllocator Page {..} allocator = do Nothing -> Nothing <$ atomicWriteIntPVar pageFull 1 Just ix -> fmap Just $ - withForeignPtr pageMemory $ \pagePtr -> - let !blockPtr = - plusPtr pagePtr $ ix * blockByteCount (Block :: Block n) - in allocator blockPtr $ do - let !(!q, !r) = ix `quotRem` ixBitSize - !pageBitMask = clearBit (complement 0) r - touch pageMemory - atomicAndIntMutablePrimArray pageBitArray q pageBitMask - atomicWriteIntPVar pageFull 0 + unsafeIOToST $ + withForeignPtr pageMemory $ \pagePtr -> + let !blockPtr = + plusPtr pagePtr $ ix * blockByteCount (Block :: Block n) + in allocator blockPtr $ do + let !(!q, !r) = ix `quotRem` ixBitSize + !pageBitMask = clearBit (complement 0) r + touchForeignPtr pageMemory + unsafeSTToIO $ atomicAndIntMutablePrimArray pageBitArray q pageBitMask + unsafeSTToIO $ atomicWriteIntPVar pageFull 0 {-# INLINE grabNextPageWithAllocator #-} -- | Atomically AND an element of the array -atomicAndIntMutablePrimArray :: MutablePrimArray RealWorld Int -> Int -> Int -> IO () +atomicAndIntMutablePrimArray :: MutablePrimArray s Int -> Int -> Int -> ST s () atomicAndIntMutablePrimArray (MutablePrimArray mba#) (I# i#) (I# m#) = - IO $ \s# -> + ST $ \s# -> case fetchAndIntArray# mba# i# m# s# of (# s'#, _ #) -> (# s'#, () #) {-# INLINE atomicAndIntMutablePrimArray #-} -- | Atomically modify an element of the array -atomicModifyMutablePrimArray :: MutablePrimArray RealWorld Int -> Int -> (Int -> (Int, a)) -> IO a +atomicModifyMutablePrimArray :: MutablePrimArray s Int -> Int -> (Int -> (Int, a)) -> ST s a atomicModifyMutablePrimArray (MutablePrimArray mba#) (I# i#) f = - IO $ atomicModifyIntArray# mba# i# (\x# -> case f (I# x#) of (I# y#, a) -> (# y#, a #)) + ST $ atomicModifyIntArray# mba# i# (\x# -> case f (I# x#) of (I# y#, a) -> (# y#, a #)) {-# INLINE atomicModifyMutablePrimArray #-} -- | Helper function that finds an index of the left-most bit that is not set. @@ -257,9 +264,10 @@ findNextZeroIndex b = i1 = countTrailingZeros (complement b) maxBits = finiteBitSize (undefined :: b) in if i0 == 0 - then if i1 == maxBits - then Nothing - else Just i1 + then + if i1 == maxBits + then Nothing + else Just i1 else Just (i0 - 1) {-# INLINE findNextZeroIndex #-} @@ -267,7 +275,7 @@ findNextZeroIndex b = -- atomically. In case when all bits are set, then `Nothing` is returned. It is possible -- that while search is ongoing bits that where checked get cleared. This is totally fine -- for our implementation of mempool. -setNextZero :: MutablePrimArray RealWorld Int -> IO (Maybe Int) +setNextZero :: MutablePrimArray s Int -> ST s (Maybe Int) setNextZero ma = ifindAtomicMutablePrimArray ma f where f i !w = @@ -276,18 +284,17 @@ setNextZero ma = ifindAtomicMutablePrimArray ma f Just !bitIx -> (setBit w bitIx, Just (ixBitSize * i + bitIx)) {-# INLINE setNextZero #-} - -ifindAtomicMutablePrimArray :: - MutablePrimArray RealWorld Int -> - (Int -> Int -> (Int, Maybe a)) -> - IO (Maybe a) +ifindAtomicMutablePrimArray + :: MutablePrimArray s Int + -> (Int -> Int -> (Int, Maybe a)) + -> ST s (Maybe a) ifindAtomicMutablePrimArray ma f = do n <- getSizeofMutablePrimArray ma let go i | i >= n = pure Nothing | otherwise = - atomicModifyMutablePrimArray ma i (f i) >>= \case - Nothing -> go (i + 1) - Just a -> pure $! Just a + atomicModifyMutablePrimArray ma i (f i) >>= \case + Nothing -> go (i + 1) + Just a -> pure $ Just a go 0 {-# INLINE ifindAtomicMutablePrimArray #-} diff --git a/cardano-mempool/tests/Test/Cardano/Memory/PoolTests.hs b/cardano-mempool/tests/Test/Cardano/Memory/PoolTests.hs index fe39a365f..d22a72a15 100644 --- a/cardano-mempool/tests/Test/Cardano/Memory/PoolTests.hs +++ b/cardano-mempool/tests/Test/Cardano/Memory/PoolTests.hs @@ -75,10 +75,10 @@ propFindNextZeroIndex w = monadicIO . run $ -- We allow one extra page be allocated due to concurrency false positives in block -- reservations -checkNumPages :: Pool n -> Int -> Int -> Assertion +checkNumPages :: Pool n RealWorld -> Int -> Int -> Assertion checkNumPages pool n numBlocks = do let estimatedUpperBoundOfPages = 1 + max 1 (numBlocks `div` n `div` 64) - numPages <- countPages pool + numPages <- stToPrim $ countPages pool assertBool (concat [ "Number of pages should not exceed the expected amount: " @@ -102,8 +102,8 @@ checkBlockBytes block byte ptr = checkFillByte (i - 1) in checkFillByte (blockByteCount block - 1) -mallocPreFilled :: Word8 -> Int -> IO (ForeignPtr b) -mallocPreFilled preFillByte bc = do +mallocPreFilled :: Word8 -> Int -> ST s (ForeignPtr b) +mallocPreFilled preFillByte bc = unsafeIOToPrim $ do mfp <- mallocForeignPtrBytes bc withForeignPtr mfp $ \ptr -> setPtr (castPtr ptr) bc preFillByte pure mfp @@ -166,11 +166,11 @@ propPoolGarbageCollected block (Positive n) numBlocks16 preFillByte fillByte = (pool, ptrs) <- ensureAllGCed numBlocks $ \countOneBlockGCed -> do pool <- - initPool n (mallocPreFilled preFillByte) $ \ptr -> do + stToPrim $ initPool n (mallocPreFilled preFillByte) $ \ptr -> do setPtr (castPtr ptr) (blockByteCount block) fillByte countOneBlockGCed fmps :: [ForeignPtr (Block n)] <- - replicateConcurrently numBlocks (grabNextBlock pool) + replicateConcurrently numBlocks (stToPrim $ grabNextBlock pool) touch fmps -- Here we return just the pointers and let the GC collect the ForeignPtrs ptrs <- @@ -201,14 +201,14 @@ propPoolAllocateAndFinalize block (Positive n) numBlocks16 emptyByte fullByte = ensureAllGCed numBlocks $ \countOneBlockGCed -> do chan <- newChan pool <- - initPool n (mallocPreFilled emptyByte) $ \(ptr :: Ptr (Block n)) -> do + stToPrim $ initPool n (mallocPreFilled emptyByte) $ \(ptr :: Ptr (Block n)) -> do setPtr (castPtr ptr) (blockByteCount block) emptyByte countOneBlockGCed -- allocate and finalize blocks concurrently pool <$ concurrently_ (do replicateConcurrently_ numBlocks $ do - fp <- grabNextBlock pool + fp <- stToPrim $ grabNextBlock pool withForeignPtr fp (checkBlockBytes block emptyByte) writeChan chan (Just fp) -- place Nothing to indicate that we are done allocating blocks From 0c6c14f7bb34d69695b28e2ec2111c36ebb0ac1e Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Mon, 22 May 2023 13:10:07 +0200 Subject: [PATCH 14/75] Move EqST to test suite --- .../cardano-crypto-class.cabal | 1 - .../src/Cardano/Crypto/DSIGN/Ed25519ML.hs | 6 ---- .../src/Cardano/Crypto/KES/Simple.hs | 8 ----- .../Crypto/Libsodium/MLockedBytes/Internal.hs | 4 --- .../Cardano/Crypto/Libsodium/MLockedSeed.hs | 8 ----- .../cardano-crypto-tests.cabal | 2 ++ cardano-crypto-tests/src/Test/Crypto/DSIGN.hs | 5 +-- .../src/Test}/Crypto/EqST.hs | 31 +++++++++++++++++-- cardano-crypto-tests/src/Test/Crypto/KES.hs | 2 +- 9 files changed, 35 insertions(+), 32 deletions(-) rename {cardano-crypto-class/src/Cardano => cardano-crypto-tests/src/Test}/Crypto/EqST.hs (69%) diff --git a/cardano-crypto-class/cardano-crypto-class.cabal b/cardano-crypto-class/cardano-crypto-class.cabal index 4451c600e..79870ac34 100644 --- a/cardano-crypto-class/cardano-crypto-class.cabal +++ b/cardano-crypto-class/cardano-crypto-class.cabal @@ -79,7 +79,6 @@ library Cardano.Crypto.Libsodium.MLockedBytes.Internal Cardano.Crypto.Libsodium.MLockedSeed Cardano.Crypto.Libsodium.UnsafeC - Cardano.Crypto.EqST Cardano.Crypto.PinnedSizedBytes Cardano.Crypto.Seed Cardano.Crypto.Util diff --git a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs b/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs index a4cbc2e2f..097fa5e5e 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519ML.hs @@ -56,9 +56,6 @@ import Cardano.Crypto.PinnedSizedBytes , psbFromByteStringCheck , psbCreateSizedResult ) -import Cardano.Crypto.EqST - ( EqST (..) - ) import Cardano.Crypto.DSIGNM.Class import Cardano.Crypto.Libsodium.MLockedSeed @@ -256,9 +253,6 @@ instance DSIGNMAlgorithm Ed25519DSIGNM where -- forgetSignKeyDSIGNMWith _ (SignKeyEd25519DSIGNM sk) = mlsbFinalize sk -deriving via (MLockedSizedBytes (SizeSignKeyDSIGNM Ed25519DSIGNM)) - instance EqST (SignKeyDSIGNM Ed25519DSIGNM) - instance UnsoundDSIGNMAlgorithm Ed25519DSIGNM where -- -- Ser/deser (dangerous - do not use in production code) diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs index c40bcffc1..8ec44fa14 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs @@ -43,8 +43,6 @@ import Cardano.Crypto.Libsodium.MLockedSeed import Cardano.Crypto.Libsodium.MLockedBytes import Cardano.Crypto.Util import Data.Unit.Strict (forceElemsToWHNF) -import Cardano.Crypto.EqST (EqST (..)) - data SimpleKES d (t :: Nat) @@ -218,12 +216,6 @@ deriving instance DSIGNMAlgorithmBase d => Show (SigKES (SimpleKES d t)) deriving instance DSIGNMAlgorithmBase d => Eq (VerKeyKES (SimpleKES d t)) deriving instance DSIGNMAlgorithmBase d => Eq (SigKES (SimpleKES d t)) -instance EqST (SignKeyDSIGNM d) => EqST (SignKeyKES (SimpleKES d t)) where - equalsM (ThunkySignKeySimpleKES a) (ThunkySignKeySimpleKES b) = - -- No need to check that lengths agree, the types already guarantee this. - Vec.and <$> Vec.zipWithM equalsM a b - - instance DSIGNMAlgorithmBase d => NoThunks (SigKES (SimpleKES d t)) instance DSIGNMAlgorithmBase d => NoThunks (SignKeyKES (SimpleKES d t)) instance DSIGNMAlgorithmBase d => NoThunks (VerKeyKES (SimpleKES d t)) diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes/Internal.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes/Internal.hs index 1d50ac25f..3c7ca290a 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes/Internal.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes/Internal.hs @@ -55,7 +55,6 @@ import Cardano.Foreign import Cardano.Crypto.Libsodium.Memory import Cardano.Crypto.Libsodium.Memory.Internal (MLockedForeignPtr (..)) import Cardano.Crypto.Libsodium.C -import Cardano.Crypto.EqST import qualified Data.ByteString as BS import qualified Data.ByteString.Internal as BSI @@ -84,9 +83,6 @@ instance KnownNat n => Show (MLockedSizedBytes n) where -- hexstr = concatMap (printf "%02x") bytes -- in "MLSB " ++ hexstr -instance KnownNat n => EqST (MLockedSizedBytes n) where - equalsM = mlsbEq - nextPowerOf2 :: forall n. (Num n, Ord n, Bits n) => n -> n nextPowerOf2 i = go 1 diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedSeed.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedSeed.hs index 0677a9a13..5fb8c600d 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedSeed.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedSeed.hs @@ -20,9 +20,6 @@ import Cardano.Crypto.Libsodium.Memory ( MLockedAllocator, mlockedMalloc, ) -import Cardano.Crypto.EqST ( - EqST (..), - ) import Cardano.Foreign (SizedPtr) import Control.DeepSeq (NFData) import Control.Monad.Class.MonadST (MonadST) @@ -37,11 +34,6 @@ import NoThunks.Class (NoThunks) newtype MLockedSeed n = MLockedSeed {mlockedSeedMLSB :: MLockedSizedBytes n} deriving (NFData, NoThunks) -deriving via - MLockedSizedBytes n - instance - KnownNat n => EqST (MLockedSeed n) - withMLockedSeedAsMLSB :: Functor m => (MLockedSizedBytes n -> m (MLockedSizedBytes n)) diff --git a/cardano-crypto-tests/cardano-crypto-tests.cabal b/cardano-crypto-tests/cardano-crypto-tests.cabal index 040043a14..77c9596e1 100644 --- a/cardano-crypto-tests/cardano-crypto-tests.cabal +++ b/cardano-crypto-tests/cardano-crypto-tests.cabal @@ -54,6 +54,7 @@ library Test.Crypto.VRF Test.Crypto.Regressions Test.Crypto.Instances + Test.Crypto.EqST Bench.Crypto.DSIGN Bench.Crypto.VRF Bench.Crypto.KES @@ -86,6 +87,7 @@ library , criterion , base16-bytestring , tasty-hunit + , vector if flag(secp256k1-support) cpp-options: -DSECP256K1_ENABLED diff --git a/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs b/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs index fcb969906..85de68852 100644 --- a/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs +++ b/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs @@ -33,7 +33,6 @@ import Test.Tasty.QuickCheck (testProperty, QuickCheckTests) import qualified Data.ByteString as BS import Cardano.Crypto.Libsodium -import Cardano.Crypto.EqST (EqST (..), (==!)) import Text.Show.Pretty (ppShow) @@ -133,9 +132,11 @@ import Test.Crypto.Util ( Lock, withLock, ) -import Test.Crypto.Instances (withMLockedSeedFromPSB) import Cardano.Crypto.Libsodium.MLockedSeed +import Test.Crypto.Instances (withMLockedSeedFromPSB) +import Test.Crypto.EqST (EqST (..), (==!)) + #ifdef SECP256K1_ENABLED import Cardano.Crypto.DSIGN ( EcdsaSecp256k1DSIGN, diff --git a/cardano-crypto-class/src/Cardano/Crypto/EqST.hs b/cardano-crypto-tests/src/Test/Crypto/EqST.hs similarity index 69% rename from cardano-crypto-class/src/Cardano/Crypto/EqST.hs rename to cardano-crypto-tests/src/Test/Crypto/EqST.hs index ffdae7e0b..44fabcfdf 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/EqST.hs +++ b/cardano-crypto-tests/src/Test/Crypto/EqST.hs @@ -1,10 +1,21 @@ -{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} -module Cardano.Crypto.EqST where +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE StandaloneDeriving #-} +module Test.Crypto.EqST where + +import GHC.TypeLits (KnownNat) +import qualified Data.Vector as Vec import Control.Monad.Class.MonadST (MonadST) +import Cardano.Crypto.Libsodium.MLockedBytes.Internal +import Cardano.Crypto.Libsodium.MLockedSeed +import Cardano.Crypto.DSIGN.Ed25519ML +import Cardano.Crypto.DSIGNM.Class +import Cardano.Crypto.KES.Simple + -- | Monadic flavor of 'Eq', for things that can only be compared in a monadic -- context that satisfies 'MonadST'. -- This is needed because we cannot have a sound 'Eq' instance on mlocked @@ -56,3 +67,19 @@ newtype PureEqST a = PureEqST a instance Eq a => EqST (PureEqST a) where equalsM (PureEqST a) (PureEqST b) = pure (a == b) + +instance KnownNat n => EqST (MLockedSizedBytes n) where + equalsM = mlsbEq + +deriving via + MLockedSizedBytes n + instance + KnownNat n => EqST (MLockedSeed n) + +deriving via (MLockedSizedBytes (SizeSignKeyDSIGNM Ed25519DSIGNM)) + instance EqST (SignKeyDSIGNM Ed25519DSIGNM) + +instance EqST (SignKeyDSIGNM d) => EqST (SignKeyKES (SimpleKES d t)) where + equalsM (ThunkySignKeySimpleKES a) (ThunkySignKeySimpleKES b) = + -- No need to check that lengths agree, the types already guarantee this. + Vec.and <$> Vec.zipWithM equalsM a b diff --git a/cardano-crypto-tests/src/Test/Crypto/KES.hs b/cardano-crypto-tests/src/Test/Crypto/KES.hs index 4212f3188..3b9b80780 100644 --- a/cardano-crypto-tests/src/Test/Crypto/KES.hs +++ b/cardano-crypto-tests/src/Test/Crypto/KES.hs @@ -45,7 +45,6 @@ import Cardano.Crypto.Util (SignableRepresentation(..)) import Cardano.Crypto.Libsodium import Cardano.Crypto.Libsodium.MLockedSeed import Cardano.Crypto.PinnedSizedBytes -import Cardano.Crypto.EqST import Test.QuickCheck import Test.Tasty (TestTree, testGroup, adjustOption) @@ -69,6 +68,7 @@ import Test.Crypto.Util ( Lock, withLock, ) +import Test.Crypto.EqST import Test.Crypto.Instances (withMLockedSeedFromPSB) import Test.Crypto.AllocLog From aaf1b61599dbe996d7eb84da1b6ef3c808861e85 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Mon, 22 May 2023 15:39:03 +0200 Subject: [PATCH 15/75] Remove dead code --- .../src/Cardano/Crypto/Libsodium/Memory.hs | 2 -- .../src/Cardano/Crypto/Libsodium/Memory/Internal.hs | 11 ----------- 2 files changed, 13 deletions(-) diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs index 3c04e37e5..9806f0ad8 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs @@ -8,8 +8,6 @@ module Cardano.Crypto.Libsodium.Memory ( -- * MLocked allocations mlockedMalloc, MLockedAllocator (..), - AllocatorEvent(..), - getAllocatorEvent, mlockedAlloca, mlockedAllocaSized, diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs index 79e4162dd..37c2a9cda 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs @@ -16,8 +16,6 @@ module Cardano.Crypto.Libsodium.Memory.Internal ( -- * MLocked allocations mlockedMalloc, MLockedAllocator (..), - AllocatorEvent(..), - getAllocatorEvent, mlockedAlloca, mlockedAllocaSized, @@ -207,15 +205,6 @@ packByteStringCStringLen :: MonadST m => CStringLen -> m ByteString packByteStringCStringLen (ptr, len) = withLiftST $ \lift -> lift . unsafeIOToST $ BS.packCStringLen (ptr, len) -data AllocatorEvent where - AllocatorEvent :: (Show e, Typeable e) => e -> AllocatorEvent - -instance Show AllocatorEvent where - show (AllocatorEvent e) = "(AllocatorEvent " ++ show e ++ ")" - -getAllocatorEvent :: forall e. Typeable e => AllocatorEvent -> Maybe e -getAllocatorEvent (AllocatorEvent e) = cast e - newtype MLockedAllocator m = MLockedAllocator { mlAllocate :: forall a. CSize -> m (MLockedForeignPtr a) From 3ec7bf55f68dc95a532bc4213fd4a8eda62ab62f Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Wed, 24 May 2023 11:09:08 +0200 Subject: [PATCH 16/75] Address review comments --- .../src/Cardano/Crypto/Libsodium/Memory.hs | 2 +- .../Crypto/Libsodium/Memory/Internal.hs | 21 ++++++++++++------- 2 files changed, 15 insertions(+), 8 deletions(-) diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs index 9806f0ad8..4d681b11a 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs @@ -26,7 +26,7 @@ module Cardano.Crypto.Libsodium.Memory ( allocaBytes, -- * ByteString memory access, generalized to 'MonadST' - useByteStringAsCStringLen, + unpackByteStringCStringLen, packByteStringCStringLen, ) where diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs index 37c2a9cda..729fcd24b 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs @@ -34,7 +34,7 @@ module Cardano.Crypto.Libsodium.Memory.Internal ( allocaBytes, -- * ByteString memory access, generalized to 'MonadST' - useByteStringAsCStringLen, + unpackByteStringCStringLen, packByteStringCStringLen, -- * Helper @@ -53,6 +53,7 @@ import qualified Data.ByteString as BS import qualified Data.ByteString.Unsafe as BS import Data.Coerce (coerce) import Data.Typeable +import Data.Word (Word8) import Debug.Trace (traceShowM) import Foreign.C.Error (errnoToIOError, getErrno) import Foreign.C.String (CStringLen) @@ -63,7 +64,7 @@ import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import qualified Foreign.Marshal.Alloc as Foreign import Foreign.Marshal.Utils (fillBytes) import Foreign.Ptr (Ptr, nullPtr, castPtr) -import Foreign.Storable (Storable (peek), sizeOf, alignment) +import Foreign.Storable (Storable (peek), sizeOf, alignment, pokeByteOff) import GHC.IO.Exception (ioException) import GHC.TypeLits (KnownNat, natVal) import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) @@ -194,11 +195,15 @@ allocaBytes :: Int -> (Ptr a -> ST s b) -> ST s b allocaBytes size f = unsafeIOToST $ Foreign.allocaBytes size (unsafeSTToIO . f) -useByteStringAsCStringLen :: ByteString -> (CStringLen -> ST s a) -> ST s a -useByteStringAsCStringLen bs f = - allocaBytes (BS.length bs + 1) $ \buf -> do - len <- unsafeIOToST $ BS.unsafeUseAsCStringLen bs $ \(ptr, len) -> - len <$ copyMem buf ptr (fromIntegral len) +-- | Unpacks a ByteString into a temporary buffer and runs the provided 'ST' +-- function on it. +unpackByteStringCStringLen :: ByteString -> (CStringLen -> ST s a) -> ST s a +unpackByteStringCStringLen bs f = do + let len = BS.length bs + allocaBytes (len + 1) $ \buf -> do + unsafeIOToST $ BS.unsafeUseAsCString bs $ \ptr -> do + copyMem buf ptr (fromIntegral len) + pokeByteOff buf len (0 :: Word8) f (buf, len) packByteStringCStringLen :: MonadST m => CStringLen -> m ByteString @@ -226,6 +231,8 @@ mlockedAllocForeignPtrBytes :: MonadST m => CSize -> CSize -> m (MLockedForeignP mlockedAllocForeignPtrBytes = mlockedAllocForeignPtrBytesWith mlockedMalloc mlockedAllocForeignPtrBytesWith :: MLockedAllocator m -> CSize -> CSize -> m (MLockedForeignPtr a) +mlockedAllocForeignPtrBytesWith _ _ 0 = + error "Zero alignment" mlockedAllocForeignPtrBytesWith allocator size align = do mlAllocate allocator size' where From 061659d1d4470cd4d80e4234e3e62801d5cbce9c Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Wed, 21 Jun 2023 09:31:37 +0200 Subject: [PATCH 17/75] Remove unpackByteStringCStringLen --- .../src/Cardano/Crypto/Libsodium/Memory.hs | 1 - .../Cardano/Crypto/Libsodium/Memory/Internal.hs | 16 +--------------- 2 files changed, 1 insertion(+), 16 deletions(-) diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs index 4d681b11a..a4405ef5d 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory.hs @@ -26,7 +26,6 @@ module Cardano.Crypto.Libsodium.Memory ( allocaBytes, -- * ByteString memory access, generalized to 'MonadST' - unpackByteStringCStringLen, packByteStringCStringLen, ) where diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs index 729fcd24b..b32854db4 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs @@ -34,7 +34,6 @@ module Cardano.Crypto.Libsodium.Memory.Internal ( allocaBytes, -- * ByteString memory access, generalized to 'MonadST' - unpackByteStringCStringLen, packByteStringCStringLen, -- * Helper @@ -50,10 +49,8 @@ import Control.Monad.ST import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO) import Data.ByteString (ByteString) import qualified Data.ByteString as BS -import qualified Data.ByteString.Unsafe as BS import Data.Coerce (coerce) import Data.Typeable -import Data.Word (Word8) import Debug.Trace (traceShowM) import Foreign.C.Error (errnoToIOError, getErrno) import Foreign.C.String (CStringLen) @@ -64,7 +61,7 @@ import Foreign.ForeignPtr.Unsafe (unsafeForeignPtrToPtr) import qualified Foreign.Marshal.Alloc as Foreign import Foreign.Marshal.Utils (fillBytes) import Foreign.Ptr (Ptr, nullPtr, castPtr) -import Foreign.Storable (Storable (peek), sizeOf, alignment, pokeByteOff) +import Foreign.Storable (Storable (peek), sizeOf, alignment) import GHC.IO.Exception (ioException) import GHC.TypeLits (KnownNat, natVal) import NoThunks.Class (NoThunks, OnlyCheckWhnfNamed (..)) @@ -195,17 +192,6 @@ allocaBytes :: Int -> (Ptr a -> ST s b) -> ST s b allocaBytes size f = unsafeIOToST $ Foreign.allocaBytes size (unsafeSTToIO . f) --- | Unpacks a ByteString into a temporary buffer and runs the provided 'ST' --- function on it. -unpackByteStringCStringLen :: ByteString -> (CStringLen -> ST s a) -> ST s a -unpackByteStringCStringLen bs f = do - let len = BS.length bs - allocaBytes (len + 1) $ \buf -> do - unsafeIOToST $ BS.unsafeUseAsCString bs $ \ptr -> do - copyMem buf ptr (fromIntegral len) - pokeByteOff buf len (0 :: Word8) - f (buf, len) - packByteStringCStringLen :: MonadST m => CStringLen -> m ByteString packByteStringCStringLen (ptr, len) = withLiftST $ \lift -> lift . unsafeIOToST $ BS.packCStringLen (ptr, len) From 4ee7879de865f9bd32280382d63203bfda5ffc1b Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Wed, 21 Jun 2023 09:42:47 +0200 Subject: [PATCH 18/75] Add new functionality to changelog --- cardano-crypto-class/CHANGELOG.md | 9 ++++++++- 1 file changed, 8 insertions(+), 1 deletion(-) diff --git a/cardano-crypto-class/CHANGELOG.md b/cardano-crypto-class/CHANGELOG.md index 0a8620dfd..a61b593b0 100644 --- a/cardano-crypto-class/CHANGELOG.md +++ b/cardano-crypto-class/CHANGELOG.md @@ -7,12 +7,19 @@ solidified. Ask @lehins if backport is needed. * Introduce memory locking and secure forgetting functionality: [#255](https://github.com/input-output-hk/cardano-base/pull/255) + [#404](https://github.com/input-output-hk/cardano-base/pull/404) * KES started using the new memlocking functionality: [#255](https://github.com/input-output-hk/cardano-base/pull/255) + [#404](https://github.com/input-output-hk/cardano-base/pull/404) * Introduction of `DSIGNM` that uses the new memlocking functionality: - [#255](https://github.com/input-output-hk/cardano-base/pull/255) + [#404](https://github.com/input-output-hk/cardano-base/pull/404) * Included bindings to `blst` library to enable operations over curve BLS12-381 [#266](https://github.com/input-output-hk/cardano-base/pull/266) +* Introduction of `DirectSerialise` / `DirectDeserialise` APIs, providing + direct access to mlocked keys in RAM: + [#404](https://github.com/input-output-hk/cardano-base/pull/404) +* Restructuring of libsodium bindings and related APIs: + [#404](https://github.com/input-output-hk/cardano-base/pull/404) ## 2.1.0.2 From 78e5d3f6e2e359005ba1f09994511899c125d43d Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Mon, 26 Jun 2023 13:23:45 +0200 Subject: [PATCH 19/75] Prevent BLS Affine values from being coerced. The same safeguard already existed for the Point type, but we also need it for Affine. --- .../src/Cardano/Crypto/EllipticCurve/BLS12_381/Internal.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/cardano-crypto-class/src/Cardano/Crypto/EllipticCurve/BLS12_381/Internal.hs b/cardano-crypto-class/src/Cardano/Crypto/EllipticCurve/BLS12_381/Internal.hs index af956ae41..2eccaa004 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/EllipticCurve/BLS12_381/Internal.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/EllipticCurve/BLS12_381/Internal.hs @@ -232,6 +232,10 @@ type Point2 = Point Curve2 newtype Affine curve = Affine (ForeignPtr Void) +-- Making sure different 'Affine's are not 'Coercible', which would ruin the +-- intended type safety: +type role Affine nominal + type Affine1 = Affine Curve1 type Affine2 = Affine Curve2 From 7c771f705ba634c51b3fc33e466e7c9beb4307e3 Mon Sep 17 00:00:00 2001 From: Fraser Murray <130977686+fraser-iohk@users.noreply.github.com> Date: Tue, 11 Jul 2023 10:59:53 +0100 Subject: [PATCH 20/75] fix the link to the packaged dependencies --- README.md | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/README.md b/README.md index 8da461ba4..718744826 100644 --- a/README.md +++ b/README.md @@ -35,7 +35,7 @@ Crypotgraphic depencencies needed for building Haskell packages: * [`libblst`](https://github.com/supranational/blst) We provide packaged versions for common Operating Systems for all of the above -dependencies: [Download](https://github.com/input-output-hk/iohk-nix/releases/tag/latest) +dependencies: [Download](https://github.com/input-output-hk/iohk-nix/releases/latest) ## GHC From ac7a6d5f73c820ab14dcad46f5da1246179c11f3 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Mon, 17 Jul 2023 18:11:05 +0100 Subject: [PATCH 21/75] Fix incorrect lower bound on io-classes and bump up the version. Update flakes --- cardano-crypto-tests/cardano-crypto-tests.cabal | 4 ++-- flake.lock | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/cardano-crypto-tests/cardano-crypto-tests.cabal b/cardano-crypto-tests/cardano-crypto-tests.cabal index 77c9596e1..ad8acf63d 100644 --- a/cardano-crypto-tests/cardano-crypto-tests.cabal +++ b/cardano-crypto-tests/cardano-crypto-tests.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: cardano-crypto-tests -version: 2.2.0.0 +version: 2.2.0.1 synopsis: Tests for cardano-crypto-class and -praos description: Tests for cardano-crypto-class and -praos license: Apache-2.0 @@ -74,7 +74,7 @@ library , contra-tracer ==0.1.0.1 , deepseq , formatting - , io-classes + , io-classes >= 1.1 , mtl , nothunks , pretty-show diff --git a/flake.lock b/flake.lock index c49aa7254..62decfaa8 100644 --- a/flake.lock +++ b/flake.lock @@ -339,11 +339,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1682036591, - "narHash": "sha256-QPrmInnsudgOP+bpJKzosItR0H1C5F54SmPLV8AlFPg=", + "lastModified": 1689553923, + "narHash": "sha256-B5pnktSnsj+sci6zEFmg52gWhmYmMUzyOTIbf9b1VAY=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "9d83fdf40d77bc15719c6e498da98dbd0714dfa4", + "rev": "6debf045a11c4bcdd816ba0c7561d82abdf9c8dc", "type": "github" }, "original": { From 307e22c530e9401804fa09712ca9fae59c8dd9b4 Mon Sep 17 00:00:00 2001 From: Michael Peyton Jones Date: Wed, 26 Jul 2023 19:50:16 +0100 Subject: [PATCH 22/75] Various CI fixes (#428) * Enable tests and benchmarks by default This is usually what you want and ensures that CI will build things. * Disable aarch64-linux on hydra for now * Remove cicero * Fix cardano-mempool benchmarks --------- Co-authored-by: Alexey Kuleshevich --- cabal.project | 3 ++ cardano-mempool/bench/Bench.hs | 54 +++++++++++---------- flake.lock | 85 ++++++++++++++++++---------------- flake.nix | 62 +------------------------ 4 files changed, 80 insertions(+), 124 deletions(-) diff --git a/cabal.project b/cabal.project index b09cf8c4e..0dc7554eb 100644 --- a/cabal.project +++ b/cabal.project @@ -31,6 +31,9 @@ packages: -- Ensures colourized output from test runners test-show-details: direct +tests: true +benchmarks: true + program-options ghc-options: -Werror diff --git a/cardano-mempool/bench/Bench.hs b/cardano-mempool/bench/Bench.hs index 0c3ea93aa..31707c805 100644 --- a/cardano-mempool/bench/Bench.hs +++ b/cardano-mempool/bench/Bench.hs @@ -2,25 +2,28 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-orphans #-} + module Main where -import Foreign.Marshal.Alloc -import GHC.TypeLits -import Criterion.Main import Cardano.Memory.Pool -import Foreign.ForeignPtr import Control.DeepSeq -import UnliftIO.Async (pooledReplicateConcurrently) import Control.Monad +import Control.Monad.ST (RealWorld, stToIO) +import Criterion.Main +import Foreign.ForeignPtr +import Foreign.Marshal.Alloc +import GHC.IO (ioToST) +import GHC.TypeLits +import UnliftIO.Async (pooledReplicateConcurrently) -instance NFData (Pool n) where +instance NFData (Pool n s) where rnf !_ = () instance NFData (ForeignPtr a) where rnf !_ = () -initHaskellPool :: KnownNat n => Int -> IO (Pool n) -initHaskellPool n = initPool n mallocForeignPtrBytes (const (pure ())) +initHaskellPool :: (KnownNat n) => Int -> IO (Pool n RealWorld) +initHaskellPool n = stToIO $ initPool n (ioToST . mallocForeignPtrBytes) (const (pure ())) cmallocForeignPtr :: Int -> IO (ForeignPtr a) cmallocForeignPtr n = do @@ -32,20 +35,23 @@ main = do let n = 10240 blockSize = 32 defaultMain - [ bgroup "Sequential" - [ env (initHaskellPool @32 (n `div` 64)) $ \pool -> - bench "ForeignPtr (Pool)" $ nfIO (replicateM n (grabNextBlock pool)) - , bench "ForeignPtr (ByteArray)" $ - nfIO (replicateM n (mallocForeignPtrBytes blockSize)) - , bench "ForeignPtr (malloc)" $ - nfIO (replicateM n (cmallocForeignPtr blockSize)) - ] - , bgroup "Concurrent" - [ env (initHaskellPool @32 (n `div` 64)) $ \pool -> - bench "ForeignPtr (Pool)" $ nfIO (pooledReplicateConcurrently n (grabNextBlock pool)) - , bench "ForeignPtr (ByteArray)" $ - nfIO (pooledReplicateConcurrently n (mallocForeignPtrBytes blockSize)) - , bench "ForeignPtr (malloc)" $ - nfIO (pooledReplicateConcurrently n (cmallocForeignPtr blockSize)) - ] + [ bgroup + "Sequential" + [ env (initHaskellPool @32 (n `div` 64)) $ \pool -> + bench "ForeignPtr (Pool)" $ nfIO $ replicateM n (stToIO (grabNextBlock pool)) + , bench "ForeignPtr (ByteArray)" $ + nfIO (replicateM n (mallocForeignPtrBytes blockSize)) + , bench "ForeignPtr (malloc)" $ + nfIO (replicateM n (cmallocForeignPtr blockSize)) + ] + , bgroup + "Concurrent" + [ env (initHaskellPool @32 (n `div` 64)) $ \pool -> + bench "ForeignPtr (Pool)" $ + nfIO (pooledReplicateConcurrently n (stToIO (grabNextBlock pool))) + , bench "ForeignPtr (ByteArray)" $ + nfIO (pooledReplicateConcurrently n (mallocForeignPtrBytes blockSize)) + , bench "ForeignPtr (malloc)" $ + nfIO (pooledReplicateConcurrently n (cmallocForeignPtr blockSize)) + ] ] diff --git a/flake.lock b/flake.lock index 62decfaa8..3df6bf045 100644 --- a/flake.lock +++ b/flake.lock @@ -135,11 +135,13 @@ "devshell": { "inputs": { "flake-utils": [ + "haskellNix", "tullia", "std", "flake-utils" ], "nixpkgs": [ + "haskellNix", "tullia", "std", "nixpkgs" @@ -162,11 +164,13 @@ "dmerge": { "inputs": { "nixlib": [ + "haskellNix", "tullia", "std", "nixpkgs" ], "yants": [ + "haskellNix", "tullia", "std", "yants" @@ -319,7 +323,7 @@ }, "gomod2nix": { "inputs": { - "nixpkgs": "nixpkgs_3", + "nixpkgs": "nixpkgs_2", "utils": "utils" }, "locked": { @@ -379,9 +383,7 @@ "nixpkgs-unstable": "nixpkgs-unstable", "old-ghc-nix": "old-ghc-nix", "stackage": "stackage", - "tullia": [ - "tullia" - ] + "tullia": "tullia" }, "locked": { "lastModified": 1682124656, @@ -456,6 +458,7 @@ "incl": { "inputs": { "nixlib": [ + "haskellNix", "tullia", "std", "nixpkgs" @@ -478,7 +481,7 @@ "iohkNix": { "inputs": { "blst": "blst", - "nixpkgs": "nixpkgs_2", + "nixpkgs": "nixpkgs_5", "secp256k1": "secp256k1", "sodium": "sodium" }, @@ -532,11 +535,13 @@ "n2c": { "inputs": { "flake-utils": [ + "haskellNix", "tullia", "std", "flake-utils" ], "nixpkgs": [ + "haskellNix", "tullia", "std", "nixpkgs" @@ -581,16 +586,19 @@ "inputs": { "flake-compat": "flake-compat_3", "flake-utils": [ + "haskellNix", "tullia", "nix2container", "flake-utils" ], "gomod2nix": "gomod2nix", "nixpkgs": [ + "haskellNix", "tullia", "nixpkgs" ], "nixpkgs-lib": [ + "haskellNix", "tullia", "nixpkgs" ] @@ -612,7 +620,7 @@ "nix2container": { "inputs": { "flake-utils": "flake-utils_3", - "nixpkgs": "nixpkgs_4" + "nixpkgs": "nixpkgs_3" }, "locked": { "lastModified": 1658567952, @@ -631,16 +639,19 @@ "nixago": { "inputs": { "flake-utils": [ + "haskellNix", "tullia", "std", "flake-utils" ], "nixago-exts": [ + "haskellNix", "tullia", "std", "blank" ], "nixpkgs": [ + "haskellNix", "tullia", "std", "nixpkgs" @@ -789,22 +800,6 @@ } }, "nixpkgs_2": { - "locked": { - "lastModified": 1684171562, - "narHash": "sha256-BMUWjVWAUdyMWKk0ATMC9H0Bv4qAV/TXwwPUvTiC5IQ=", - "owner": "nixos", - "repo": "nixpkgs", - "rev": "55af203d468a6f5032a519cba4f41acf5a74b638", - "type": "github" - }, - "original": { - "owner": "nixos", - "ref": "release-22.11", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs_3": { "locked": { "lastModified": 1653581809, "narHash": "sha256-Uvka0V5MTGbeOfWte25+tfRL3moECDh1VwokWSZUdoY=", @@ -820,7 +815,7 @@ "type": "github" } }, - "nixpkgs_4": { + "nixpkgs_3": { "locked": { "lastModified": 1654807842, "narHash": "sha256-ADymZpr6LuTEBXcy6RtFHcUZdjKTBRTMYwu19WOx17E=", @@ -835,34 +830,34 @@ "type": "github" } }, - "nixpkgs_5": { + "nixpkgs_4": { "locked": { - "lastModified": 1674407282, - "narHash": "sha256-2qwc8mrPINSFdWffPK+ji6nQ9aGnnZyHSItVcYDZDlk=", + "lastModified": 1675940568, + "narHash": "sha256-epG6pOT9V0kS+FUqd7R6/CWkgnZx2DMT5Veqo+y6G3c=", "owner": "nixos", "repo": "nixpkgs", - "rev": "ab1254087f4cdf4af74b552d7fc95175d9bdbb49", + "rev": "6ccc4a59c3f1b56d039d93da52696633e641bc71", "type": "github" }, "original": { "owner": "nixos", - "ref": "nixos-22.11", + "ref": "nixpkgs-unstable", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs_6": { + "nixpkgs_5": { "locked": { - "lastModified": 1675940568, - "narHash": "sha256-epG6pOT9V0kS+FUqd7R6/CWkgnZx2DMT5Veqo+y6G3c=", + "lastModified": 1684171562, + "narHash": "sha256-BMUWjVWAUdyMWKk0ATMC9H0Bv4qAV/TXwwPUvTiC5IQ=", "owner": "nixos", "repo": "nixpkgs", - "rev": "6ccc4a59c3f1b56d039d93da52696633e641bc71", + "rev": "55af203d468a6f5032a519cba4f41acf5a74b638", "type": "github" }, "original": { "owner": "nixos", - "ref": "nixpkgs-unstable", + "ref": "release-22.11", "repo": "nixpkgs", "type": "github" } @@ -902,12 +897,14 @@ "paisano": { "inputs": { "nixpkgs": [ + "haskellNix", "tullia", "std", "nixpkgs" ], "nosys": "nosys", "yants": [ + "haskellNix", "tullia", "std", "yants" @@ -930,11 +927,13 @@ "paisano-tui": { "inputs": { "nixpkgs": [ + "haskellNix", "tullia", "std", "blank" ], "std": [ + "haskellNix", "tullia", "std" ] @@ -963,8 +962,7 @@ "nixpkgs": [ "haskellNix", "nixpkgs-unstable" - ], - "tullia": "tullia" + ] } }, "secp256k1": { @@ -1020,6 +1018,7 @@ "std": { "inputs": { "arion": [ + "haskellNix", "tullia", "std", "blank" @@ -1030,18 +1029,20 @@ "flake-utils": "flake-utils_4", "incl": "incl", "makes": [ + "haskellNix", "tullia", "std", "blank" ], "microvm": [ + "haskellNix", "tullia", "std", "blank" ], "n2c": "n2c", "nixago": "nixago", - "nixpkgs": "nixpkgs_6", + "nixpkgs": "nixpkgs_4", "paisano": "paisano", "paisano-tui": "paisano-tui", "yants": "yants" @@ -1079,15 +1080,18 @@ "inputs": { "nix-nomad": "nix-nomad", "nix2container": "nix2container", - "nixpkgs": "nixpkgs_5", + "nixpkgs": [ + "haskellNix", + "nixpkgs" + ], "std": "std" }, "locked": { - "lastModified": 1677666696, - "narHash": "sha256-Oga/fHNJba7dM6HSz83RNv/UrUeGs1WRHUHbI8dCUqc=", + "lastModified": 1684859161, + "narHash": "sha256-wOKutImA7CRL0rN+Ng80E72fD5FkVub7LLP2k9NICpg=", "owner": "input-output-hk", "repo": "tullia", - "rev": "708d1ec45b17923d2452ba8f28795228ba8aafd5", + "rev": "2964cff1a16eefe301bdddb508c49d94d04603d6", "type": "github" }, "original": { @@ -1114,6 +1118,7 @@ "yants": { "inputs": { "nixpkgs": [ + "haskellNix", "tullia", "std", "nixpkgs" diff --git a/flake.nix b/flake.nix index 1f5a63dc6..4f7bc99dd 100644 --- a/flake.nix +++ b/flake.nix @@ -1,7 +1,6 @@ { inputs = { haskellNix.url = "github:input-output-hk/haskell.nix"; - haskellNix.inputs.tullia.follows = "tullia"; nixpkgs.follows = "haskellNix/nixpkgs-unstable"; iohkNix.url = "github:input-output-hk/iohk-nix"; flake-utils.url = "github:hamishmack/flake-utils/hkm/nested-hydraJobs"; @@ -9,9 +8,6 @@ CHaP.url = "github:input-output-hk/cardano-haskell-packages?ref=repo"; CHaP.flake = false; - # cicero - tullia.url = "github:input-output-hk/tullia"; - # non-flake nix compatibility flake-compat.url = "github:edolstra/flake-compat"; flake-compat.flake = false; @@ -23,7 +19,8 @@ supportedSystems = [ "x86_64-linux" "x86_64-darwin" - "aarch64-linux" + # not supported on ci.iog.io right now + #"aarch64-linux" "aarch64-darwin" ]; in inputs.flake-utils.lib.eachSystem supportedSystems (system: @@ -107,61 +104,6 @@ # we also want cross compilation to windows. nixpkgs.lib.optionalAttrs (system == "x86_64-linux") { crossPlatforms = p: [p.mingwW64]; - }) - # add cicero logic. - // (let actionCiInputName = "GitHub event"; in inputs.tullia.fromSimple system { - tasks = { - ci = { config, lib, ... }: { - preset = { - nix.enable = true; - github.ci = { - # Tullia tasks can run locally or on Cicero. - # When no facts are present we know that we are running locally and vice versa. - # When running locally, the current directory is already bind-mounted into the container, - # so we don't need to fetch the source from GitHub and we don't want to report a GitHub status. - enable = config.actionRun.facts != {}; - repository = "input-output-hk/cardano-base"; - remote = config.preset.github.lib.readRepository actionCiInputName null; - revision = config.preset.github.lib.readRevision actionCiInputName null; - }; - }; - - - command.text = config.preset.github.status.lib.reportBulk { - bulk.text = '' - nix eval .#hydraJobs --apply __attrNames --json | - nix-systems -i | - jq 'with_entries(select(.value))' # filter out systems that we cannot build for - ''; - each.text = ''nix build -L .#hydraJobs."$1".required''; - skippedDescription = lib.escapeShellArg "No nix builder for this system"; - }; - - memory = 1024 * 8; - nomad.driver = "exec"; - nomad.resources.cpu = 10000; - }; - }; - - actions = { - "cardano-base/ci" = { - task = "ci"; - io = '' - // This is a CUE expression that defines what events trigger a new run of this action. - // There is no documentation for this yet. Ask SRE if you have trouble changing this. - let github = { - #input: "${actionCiInputName}" - #repo: "input-output-hk/cardano-base" - } - - #lib.merge - #ios: [ - {#lib.io.github_push, github, #default_branch: true}, - {#lib.io.github_pr, github}, - ] - ''; - }; - }; }); in nixpkgs.lib.recursiveUpdate flake { # add a required job, that's basically all hydraJobs. From 4153fbd46f60c73a7f2cad9be60853f72c648087 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Mon, 10 Jul 2023 13:08:52 +0200 Subject: [PATCH 23/75] Strict checked MVars and TVars --- .github/workflows/haskell.yml | 2 +- cabal.project | 10 + strict-checked-vars/CHANGELOG.md | 5 + strict-checked-vars/LICENSE | 177 ++++++++++++++++ strict-checked-vars/NOTICE | 14 ++ strict-checked-vars/README.md | 63 ++++++ .../Class/MonadMVar/Strict/Checked.hs | 194 ++++++++++++++++++ .../Class/MonadSTM/Strict/TVar/Checked.hs | 162 +++++++++++++++ strict-checked-vars/strict-checked-vars.cabal | 75 +++++++ strict-checked-vars/test/Main.hs | 9 + .../Class/MonadMVar/Strict/Checked.hs | 43 ++++ strict-checked-vars/test/Test/Utils.hs | 23 +++ 12 files changed, 776 insertions(+), 1 deletion(-) create mode 100644 strict-checked-vars/CHANGELOG.md create mode 100644 strict-checked-vars/LICENSE create mode 100644 strict-checked-vars/NOTICE create mode 100644 strict-checked-vars/README.md create mode 100644 strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs create mode 100644 strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs create mode 100644 strict-checked-vars/strict-checked-vars.cabal create mode 100644 strict-checked-vars/test/Main.hs create mode 100644 strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs create mode 100644 strict-checked-vars/test/Test/Utils.hs diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 91f658d43..2a1bb8750 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -34,7 +34,7 @@ jobs: strategy: fail-fast: false matrix: - ghc: ["8.10.7", "9.2.7", "9.6.1"] + ghc: ["8.10.7", "9.2.7", "9.6.2"] os: [ubuntu-latest, macos-latest, windows-latest] env: diff --git a/cabal.project b/cabal.project index 0dc7554eb..6be3bf051 100644 --- a/cabal.project +++ b/cabal.project @@ -27,6 +27,7 @@ packages: heapwords measures orphans-deriving-via + strict-checked-vars -- Ensures colourized output from test runners test-show-details: direct @@ -44,3 +45,12 @@ if impl(ghc >= 9.6) , protolude:binary , protolude:bytestring , protolude:text + +-- TODO: remove when a new version of strict-mvar (>1.1.0.0) is released +source-repository-package + type: git + location: https://github.com/input-output-hk/io-sim + tag: 1b2c22b376f5cda314b9ab444caaf77764961a18 + --sha256: 1qdxcqr4sl93n036p3pz1rvk6zf4qbsadzw4lgsp9agkh8pvs16y + subdir: + strict-mvar \ No newline at end of file diff --git a/strict-checked-vars/CHANGELOG.md b/strict-checked-vars/CHANGELOG.md new file mode 100644 index 000000000..f50aed29f --- /dev/null +++ b/strict-checked-vars/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history of strict-checked-vars + +## 0.1.0.0 + +* Initial version, not released on Hackage. diff --git a/strict-checked-vars/LICENSE b/strict-checked-vars/LICENSE new file mode 100644 index 000000000..f433b1a53 --- /dev/null +++ b/strict-checked-vars/LICENSE @@ -0,0 +1,177 @@ + + 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 diff --git a/strict-checked-vars/NOTICE b/strict-checked-vars/NOTICE new file mode 100644 index 000000000..15b771a00 --- /dev/null +++ b/strict-checked-vars/NOTICE @@ -0,0 +1,14 @@ +Copyright 2019-2023 Input Output Global Inc (IOG). + + 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/strict-checked-vars/README.md b/strict-checked-vars/README.md new file mode 100644 index 000000000..aa5ef6f7c --- /dev/null +++ b/strict-checked-vars/README.md @@ -0,0 +1,63 @@ +# Strict `MVar`s and `TVar`s with invariant checking + +The `strict-checked-vars` package provides a strict interface to mutable +variables (`MVar`) and `TVar`s with invariant checking. It builds on top of +`strict-mvar`, `strict-stm` and `io-classes`, and thus it provides the interface +for `MVar`/`TVar` implementations for both +[IO](https://hackage.haskell.org/package/base-4.18.0.0/docs/Prelude.html#t:IO) +and [io-sim](https://hackage.haskell.org/package/io-sim). + +## Checked and unchecked variants + +There are currently two variant implementations of `StrictTVar`s. +* From `strict-stm`: `Control.Concurrent.Class.MonadSTM.Strict.TVar` +* From `strict-checked-vars`: `Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked` + +Similarly, there are currently two variant implementations of `StrictMVar`s. +* From `strict-mvar`: `Control.Concurrent.Class.MonadMVar.Strict` +* From `strict-checked-vars`: `Control.Concurrent.Class.MonadMVar.Strict.Checked` + + +The _unchecked_ modules provide the simplest implementation of strict variables: +a light wrapper around lazy variables that forces values to WHNF before they are +put inside the variable. The _checked_ module does the exact same thing, but it +has the additional feature that the user can provide an invariant that is +checked each time a new value is placed inside the variable. The checked modules +are drop-in replacements for the unchecked modules, though invariants will be +trivially true in that case. Non-trivial invariants can be set when creating a +new variable. + +```haskell +newMVarWithInvariant :: MonadMVar m + => (a -> Maybe String) + -> a + -> m (StrictMVar m a) + +newEmptyMVarWithInvariant :: MonadMVar m + => (a -> Maybe String) + -> m (StrictMVar m a) + +newTVarWithInvariant :: (MonadSTM m, HasCallStack) + => (a -> Maybe String) + -> a + -> STM m (StrictTVar m a) + +newTVarWithInvariantIO :: (MonadSTM m, HasCallStack) + => (a -> Maybe String) + -> a + -> m (StrictTVar m a) +``` + +**Note:** though the checked modules are drop-in replacements for the unchecked +modules, the `StrictMVar`/`StrictTVar` types are distinct. This means we can't +make mixed use of the checked and unchecked modules. + +## Guarantees for invariant checking on `StrictMVar`s + +Although all functions that modify a checked `StrictMVar` will check the +invariant, we do *not* guarantee that the value inside the `StrictMVar` always +satisfies the invariant. Instead, we *do* guarantee that if the `StrictMVar` is +updated with a value that does not satisfy the invariant, an exception is thrown +*after* the new value is written to the `StrictMVar`. The reason for this weaker +guarantee is that leaving an `MVar` empty can lead to very hard to debug +"blocked indefinitely" problems. \ No newline at end of file diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs new file mode 100644 index 000000000..07b26e383 --- /dev/null +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs @@ -0,0 +1,194 @@ +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module corresponds to "Control.Concurrent.MVar" in the @base@ package. +-- +-- This module can be used as a drop-in replacement for +-- "Control.Concurrent.Class.MonadMVar.Strict", but not the other way around. +module Control.Concurrent.Class.MonadMVar.Strict.Checked ( + -- * StrictMVar + LazyMVar + , StrictMVar + , castStrictMVar + , fromLazyMVar + , isEmptyMVar + , modifyMVar + , modifyMVarMasked + , modifyMVarMasked_ + , modifyMVar_ + , newEmptyMVar + , newEmptyMVarWithInvariant + , newMVar + , newMVarWithInvariant + , putMVar + , readMVar + , swapMVar + , takeMVar + , toLazyMVar + , tryPutMVar + , tryReadMVar + , tryTakeMVar + , withMVar + , withMVarMasked + -- * Re-exports + , MonadMVar + ) where + +import Control.Concurrent.Class.MonadMVar.Strict (LazyMVar, MonadMVar) +import qualified Control.Concurrent.Class.MonadMVar.Strict as Strict +import GHC.Stack (HasCallStack) + +{------------------------------------------------------------------------------- + StrictMVar +-------------------------------------------------------------------------------} + +-- | A strict MVar with invariant checking. +-- +-- There is a weaker invariant for a 'StrictMVar' than for a 'StrictTVar': +-- although all functions that modify the 'StrictMVar' check the invariant, we +-- do /not/ guarantee that the value inside the 'StrictMVar' always satisfies +-- the invariant. Instead, we /do/ guarantee that if the 'StrictMVar' is updated +-- with a value that does not satisfy the invariant, an exception is thrown. The +-- reason for this weaker guarantee is that leaving an 'MVar' empty can lead to +-- very hard to debug "blocked indefinitely" problems. +data StrictMVar m a = StrictMVar { + -- | The invariant that is checked whenever the 'StrictMVar' is updated. + invariant :: !(a -> Maybe String) + , mvar :: !(Strict.StrictMVar m a) + } + +castStrictMVar :: LazyMVar m ~ LazyMVar n + => StrictMVar m a -> StrictMVar n a +castStrictMVar v = StrictMVar (invariant v) (Strict.castStrictMVar $ mvar v) + +-- | Get the underlying @MVar@ +-- +-- Since we obviously can not guarantee that updates to this 'LazyMVar' will be +-- strict, this should be used with caution. +-- +-- Similarly, we can not guarantee that updates to this 'LazyMVar' do not break +-- the original invariant that the 'StrictMVar' held. +toLazyMVar :: StrictMVar m a -> LazyMVar m a +toLazyMVar = Strict.toLazyMVar . mvar + +-- | Create a 'StrictMVar' from a 'LazyMVar' +-- +-- It is not guaranteed that the 'LazyMVar' contains a value that is in WHNF, so +-- there is no guarantee that the resulting 'StrictMVar' contains a value that +-- is in WHNF. This should be used with caution. +-- +-- The resulting 'StrictMVar' has a trivial invariant. +fromLazyMVar :: LazyMVar m a -> StrictMVar m a +fromLazyMVar = StrictMVar (const Nothing) . Strict.fromLazyMVar + +newEmptyMVar :: MonadMVar m => m (StrictMVar m a) +newEmptyMVar = StrictMVar (const Nothing) <$> Strict.newEmptyMVar + +newEmptyMVarWithInvariant :: MonadMVar m + => (a -> Maybe String) + -> m (StrictMVar m a) +newEmptyMVarWithInvariant inv = StrictMVar inv <$> Strict.newEmptyMVar + +newMVar :: MonadMVar m => a -> m (StrictMVar m a) +newMVar a = StrictMVar (const Nothing) <$> Strict.newMVar a + +newMVarWithInvariant :: (HasCallStack, MonadMVar m) + => (a -> Maybe String) + -> a + -> m (StrictMVar m a) +newMVarWithInvariant inv a = + checkInvariant (inv a) $ + StrictMVar inv <$> Strict.newMVar a + +takeMVar :: MonadMVar m => StrictMVar m a -> m a +takeMVar = Strict.takeMVar . mvar + +putMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m () +putMVar v a = do + Strict.putMVar (mvar v) a + checkInvariant (invariant v a) $ pure () + +readMVar :: MonadMVar m => StrictMVar m a -> m a +readMVar v = Strict.readMVar (mvar v) + +swapMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m a +swapMVar v a = do + oldValue <- Strict.swapMVar (mvar v) a + checkInvariant (invariant v a) $ pure oldValue + +tryTakeMVar :: MonadMVar m => StrictMVar m a -> m (Maybe a) +tryTakeMVar v = Strict.tryTakeMVar (mvar v) + +tryPutMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m Bool +tryPutMVar v a = do + didPut <- Strict.tryPutMVar (mvar v) a + checkInvariant (invariant v a) $ pure didPut + +isEmptyMVar :: MonadMVar m => StrictMVar m a -> m Bool +isEmptyMVar v = Strict.isEmptyMVar (mvar v) + +withMVar :: MonadMVar m => StrictMVar m a -> (a -> m b) -> m b +withMVar v = Strict.withMVar (mvar v) + +withMVarMasked :: MonadMVar m => StrictMVar m a -> (a -> m b) -> m b +withMVarMasked v = Strict.withMVarMasked (mvar v) + +-- | 'modifyMVar_' is defined in terms of 'modifyMVar'. +modifyMVar_ :: (HasCallStack, MonadMVar m) + => StrictMVar m a + -> (a -> m a) + -> m () +modifyMVar_ v io = modifyMVar v io' + where io' a = (,()) <$> io a + +modifyMVar :: (HasCallStack, MonadMVar m) + => StrictMVar m a + -> (a -> m (a,b)) + -> m b +modifyMVar v io = do + (a', b) <- Strict.modifyMVar (mvar v) io' + checkInvariant (invariant v a') $ pure b + where + io' a = do + (a', b) <- io a + -- Returning @a'@ along with @b@ allows us to check the invariant /after/ + -- filling in the MVar. + pure (a' , (a', b)) + +-- | 'modifyMVarMasked_' is defined in terms of 'modifyMVarMasked'. +modifyMVarMasked_ :: (HasCallStack, MonadMVar m) + => StrictMVar m a + -> (a -> m a) + -> m () +modifyMVarMasked_ v io = modifyMVar v io' + where io' a = (,()) <$> io a + +modifyMVarMasked :: (HasCallStack, MonadMVar m) + => StrictMVar m a + -> (a -> m (a,b)) + -> m b +modifyMVarMasked v io = do + (a', b) <- Strict.modifyMVarMasked (mvar v) io' + checkInvariant (invariant v a') $ pure b + where + io' a = do + (a', b) <- io a + -- Returning @a'@ along with @b@ allows us to check the invariant /after/ + -- filling in the MVar. + pure (a', (a', b)) + +tryReadMVar :: MonadMVar m => StrictMVar m a -> m (Maybe a) +tryReadMVar v = Strict.tryReadMVar (mvar v) + +-- +-- Dealing with invariants +-- + +-- | Check invariant +-- +-- @checkInvariant mErr x@ is equal to @x@ if @mErr == Nothing@, and throws an +-- error @err@ if @mErr == Just err@. +checkInvariant :: HasCallStack => Maybe String -> a -> a +checkInvariant Nothing k = k +checkInvariant (Just err) _ = error $ "StrictMVar invariant violation: " ++ err diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs new file mode 100644 index 000000000..fa369f61a --- /dev/null +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs @@ -0,0 +1,162 @@ +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +-- | This module corresponds to "Control.Concurrent.STM.TVar" in the @stm@ package. +-- +-- This module can be used as a drop-in replacement for +-- "Control.Concurrent.Class.MonadSTM.Strict.TVar", but not the other way +-- around. +module Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked ( + -- * StrictTVar + LazyTVar + , StrictTVar + , castStrictTVar + , fromLazyTVar + , modifyTVar + , newTVar + , newTVarIO + , newTVarWithInvariant + , newTVarWithInvariantIO + , readTVar + , readTVarIO + , stateTVar + , swapTVar + , toLazyTVar + , writeTVar + -- * MonadLabelSTM + , labelTVar + , labelTVarIO + -- * MonadTraceSTM + , traceTVar + , traceTVarIO + ) where + +import Control.Concurrent.Class.MonadSTM (InspectMonad, + MonadLabelledSTM, MonadSTM, MonadTraceSTM, STM, TraceValue, + atomically) +import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar as Strict +import GHC.Stack (HasCallStack) + +{------------------------------------------------------------------------------- + StrictTVar +-------------------------------------------------------------------------------} + +type LazyTVar m = Strict.LazyTVar m + +data StrictTVar m a = StrictTVar { + -- | Invariant checked whenever updating the 'StrictTVar'. + invariant :: !(a -> Maybe String) + , tvar :: !(Strict.StrictTVar m a) + } + +castStrictTVar :: LazyTVar m ~ LazyTVar n + => StrictTVar m a -> StrictTVar n a +castStrictTVar v = StrictTVar (invariant v) (Strict.castStrictTVar $ tvar v) + +-- | Get the underlying @TVar@ +-- +-- Since we obviously cannot guarantee that updates to this 'LazyTVar' will be +-- strict, this should be used with caution. +-- +-- Similarly, we can not guarantee that updates to this 'LazyTVar' do not break +-- the original invariant that the 'StrictTVar' held. +toLazyTVar :: StrictTVar m a -> LazyTVar m a +toLazyTVar = Strict.toLazyTVar . tvar + +-- | Create a 'StrictMVar' from a 'LazyMVar' +-- +-- It is not guaranteed that the 'LazyTVar' contains a value that is in WHNF, so +-- there is no guarantee that the resulting 'StrictTVar' contains a value that +-- is in WHNF. This should be used with caution. +-- +-- The resulting 'StrictTVar' has a trivial invariant. +fromLazyTVar :: LazyTVar m a -> StrictTVar m a +fromLazyTVar = StrictTVar (const Nothing) . Strict.fromLazyTVar + +newTVar :: MonadSTM m => a -> STM m (StrictTVar m a) +newTVar a = StrictTVar (const Nothing) <$> Strict.newTVar a + +newTVarIO :: MonadSTM m => a -> m (StrictTVar m a) +newTVarIO = newTVarWithInvariantIO (const Nothing) + +newTVarWithInvariant :: (MonadSTM m, HasCallStack) + => (a -> Maybe String) + -> a + -> STM m (StrictTVar m a) +newTVarWithInvariant inv a = + checkInvariant (inv a) $ + StrictTVar inv <$> Strict.newTVar a + +newTVarWithInvariantIO :: (MonadSTM m, HasCallStack) + => (a -> Maybe String) + -> a + -> m (StrictTVar m a) +newTVarWithInvariantIO inv a = + checkInvariant (inv a) $ + StrictTVar inv <$> Strict.newTVarIO a + +readTVar :: MonadSTM m => StrictTVar m a -> STM m a +readTVar = Strict.readTVar . tvar + +readTVarIO :: MonadSTM m => StrictTVar m a -> m a +readTVarIO = Strict.readTVarIO . tvar + +writeTVar :: (MonadSTM m, HasCallStack) => StrictTVar m a -> a -> STM m () +writeTVar v a = + checkInvariant (invariant v a) $ + Strict.writeTVar (tvar v) a + +modifyTVar :: MonadSTM m => StrictTVar m a -> (a -> a) -> STM m () +modifyTVar v f = readTVar v >>= writeTVar v . f + +stateTVar :: MonadSTM m => StrictTVar m s -> (s -> (a, s)) -> STM m a +stateTVar v f = do + a <- readTVar v + let (b, a') = f a + writeTVar v a' + return b + +swapTVar :: MonadSTM m => StrictTVar m a -> a -> STM m a +swapTVar v a' = do + a <- readTVar v + writeTVar v a' + return a + +-- +-- Dealing with invariants +-- + +-- | Check invariant +-- +-- @checkInvariant mErr x@ is equal to @x@ if @mErr == Nothing@, and throws an +-- error @err@ if @mErr == Just err@. +checkInvariant :: HasCallStack => Maybe String -> a -> a +checkInvariant Nothing k = k +checkInvariant (Just err) _ = error $ "StrictTVar invariant violation: " ++ err + +{------------------------------------------------------------------------------- + MonadLabelledSTM +-------------------------------------------------------------------------------} + +labelTVar :: MonadLabelledSTM m => StrictTVar m a -> String -> STM m () +labelTVar = Strict.labelTVar . tvar + +labelTVarIO :: MonadLabelledSTM m => StrictTVar m a -> String -> m () +labelTVarIO v = atomically . labelTVar v + +{------------------------------------------------------------------------------- + MonadTraceSTM +-------------------------------------------------------------------------------} + +traceTVar :: MonadTraceSTM m + => proxy m + -> StrictTVar m a + -> (Maybe a -> a -> InspectMonad m TraceValue) + -> STM m () +traceTVar p = Strict.traceTVar p . tvar + +traceTVarIO :: MonadTraceSTM m + => StrictTVar m a + -> (Maybe a -> a -> InspectMonad m TraceValue) + -> m () +traceTVarIO = Strict.traceTVarIO . tvar diff --git a/strict-checked-vars/strict-checked-vars.cabal b/strict-checked-vars/strict-checked-vars.cabal new file mode 100644 index 000000000..0640a1c8d --- /dev/null +++ b/strict-checked-vars/strict-checked-vars.cabal @@ -0,0 +1,75 @@ +cabal-version: 3.0 +name: strict-checked-vars +version: 0.1.0.0 +synopsis: + Strict MVars and TVars with invariant checking for IO and IOSim + +description: + Strict @MVar@ and @TVar@ interfaces with invariant checking compatible with + [IO](https://hackage.haskell.org/package/base-4.18.0.0/docs/Prelude.html#t:IO) + & [io-sim](https://hackage.haskell.org/package/io-sim). + +license: Apache-2.0 +license-files: + LICENSE + NOTICE + +copyright: 2019-2023 Input Output Global Inc (IOG). +author: IOG Engineering Team +maintainer: operations@iohk.io +category: Concurrency +build-type: Simple +extra-doc-files: + CHANGELOG.md + README.md + +bug-reports: https://github.com/input-output-hk/io-sim/issues +tested-with: GHC ==8.10 || ==9.2 || ==9.4 || ==9.6 + +source-repository head + type: git + location: https://github.com/input-output-hk/ouroboros-consensus + subdir: strict-checked-vars + +library + hs-source-dirs: src + exposed-modules: + Control.Concurrent.Class.MonadMVar.Strict.Checked + Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked + + default-language: Haskell2010 + build-depends: + , base >=4.9 && <4.19 + , io-classes ^>=1.1 + , strict-mvar ^>=1.1 + , strict-stm ^>=1.1 + + ghc-options: + -Wall -Wno-unticked-promoted-constructors -Wcompat + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wpartial-fields -Widentities + +test-suite test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Test.Control.Concurrent.Class.MonadMVar.Strict.Checked + Test.Utils + + default-language: Haskell2010 + build-depends: + , base >=4.9 && <4.19 + , io-sim + , nothunks + , QuickCheck + , strict-checked-vars + , strict-mvar + , strict-stm + , tasty + , tasty-quickcheck + + ghc-options: + -Wall -Wno-unticked-promoted-constructors -Wcompat + -Wincomplete-uni-patterns -Wincomplete-record-updates + -Wpartial-fields -Widentities -fno-ignore-asserts diff --git a/strict-checked-vars/test/Main.hs b/strict-checked-vars/test/Main.hs new file mode 100644 index 000000000..4b7213dbc --- /dev/null +++ b/strict-checked-vars/test/Main.hs @@ -0,0 +1,9 @@ +module Main where + +import qualified Test.Control.Concurrent.Class.MonadMVar.Strict.Checked as Checked +import Test.Tasty + +main :: IO () +main = defaultMain $ testGroup "strict-checked-vars" [ + Checked.tests + ] diff --git a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs new file mode 100644 index 000000000..bdedfa2d4 --- /dev/null +++ b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs @@ -0,0 +1,43 @@ +{-# LANGUAGE RankNTypes #-} + +module Test.Control.Concurrent.Class.MonadMVar.Strict.Checked where + +import Control.Concurrent.Class.MonadMVar.Strict.Checked +import Test.QuickCheck.Monadic +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Utils + +tests :: TestTree +tests = testGroup "Test.Control.Concurrent.Class.MonadMVar.Strict" [ + testGroup "Checked" [ + testGroup "IO" [ + testProperty "prop_invariantShouldFail" $ + once $ expectFailure $ monadicIO prop_invariantShouldFail + , testProperty "prop_invariantShouldNotFail" $ + once $ monadicIO prop_invariantShouldNotFail + ] + , testGroup "IOSim" [ + testProperty "prop_invariantShouldFail" $ + once $ expectFailure $ monadicSim prop_invariantShouldFail + , testProperty "prop_invariantShouldNotFail" $ + once $ monadicSim prop_invariantShouldNotFail + ] + ] + ] + +-- | Invariant that checks whether an @Int@ is positive. +invPositiveInt :: Int -> Maybe String +invPositiveInt x + | x >= 0 = Nothing + | otherwise = Just $ "x<0 for x=" <> show x + +prop_invariantShouldNotFail :: MonadMVar m => PropertyM m () +prop_invariantShouldNotFail = run $ do + v <- newMVarWithInvariant invPositiveInt 0 + modifyMVar_ v (\x -> pure $ x + 1) + +prop_invariantShouldFail :: MonadMVar m => PropertyM m () +prop_invariantShouldFail = run $ do + v <- newMVarWithInvariant invPositiveInt 0 + modifyMVar_ v (\x -> pure $ x - 1) diff --git a/strict-checked-vars/test/Test/Utils.hs b/strict-checked-vars/test/Test/Utils.hs new file mode 100644 index 000000000..8600a2c6d --- /dev/null +++ b/strict-checked-vars/test/Test/Utils.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE RankNTypes #-} + +module Test.Utils ( + monadicSim + , runSimGen + ) where + +import Control.Monad.IOSim (IOSim, runSimOrThrow) +import Test.QuickCheck (Gen, Property, Testable (..)) +import Test.QuickCheck.Gen.Unsafe (Capture (..), capture) +import Test.QuickCheck.Monadic (PropertyM, monadic') + +{------------------------------------------------------------------------------- + Property runners (copied from "Ouroboros.Network.Testing.QuickCheck") +-------------------------------------------------------------------------------} + +runSimGen :: (forall s. Gen (IOSim s a)) -> Gen a +runSimGen f = do + Capture eval <- capture + return $ runSimOrThrow (eval f) + +monadicSim :: Testable a => (forall s. PropertyM (IOSim s) a) -> Property +monadicSim m = property (runSimGen (monadic' m)) From 787a731ad64b6cdfaba1f84ca709543950c30baa Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Thu, 27 Jul 2023 10:42:25 +0200 Subject: [PATCH 24/75] Resolve PR comments --- .../Class/MonadMVar/Strict/Checked.hs | 2 +- strict-checked-vars/strict-checked-vars.cabal | 19 ++++++++----------- 2 files changed, 9 insertions(+), 12 deletions(-) diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs index 07b26e383..a4a65e910 100644 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs @@ -161,7 +161,7 @@ modifyMVarMasked_ :: (HasCallStack, MonadMVar m) => StrictMVar m a -> (a -> m a) -> m () -modifyMVarMasked_ v io = modifyMVar v io' +modifyMVarMasked_ v io = modifyMVarMasked v io' where io' a = (,()) <$> io a modifyMVarMasked :: (HasCallStack, MonadMVar m) diff --git a/strict-checked-vars/strict-checked-vars.cabal b/strict-checked-vars/strict-checked-vars.cabal index 0640a1c8d..a3099de6f 100644 --- a/strict-checked-vars/strict-checked-vars.cabal +++ b/strict-checked-vars/strict-checked-vars.cabal @@ -23,12 +23,12 @@ extra-doc-files: CHANGELOG.md README.md -bug-reports: https://github.com/input-output-hk/io-sim/issues +bug-reports: https://github.com/input-output-hk/cardano-base/issues tested-with: GHC ==8.10 || ==9.2 || ==9.4 || ==9.6 source-repository head type: git - location: https://github.com/input-output-hk/ouroboros-consensus + location: https://github.com/input-output-hk/cardano-base subdir: strict-checked-vars library @@ -45,9 +45,9 @@ library , strict-stm ^>=1.1 ghc-options: - -Wall -Wno-unticked-promoted-constructors -Wcompat - -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -Widentities + -Wall -Wcompat -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wpartial-fields -Widentities + -Wunused-packages test-suite test type: exitcode-stdio-1.0 @@ -61,15 +61,12 @@ test-suite test build-depends: , base >=4.9 && <4.19 , io-sim - , nothunks , QuickCheck , strict-checked-vars - , strict-mvar - , strict-stm , tasty , tasty-quickcheck ghc-options: - -Wall -Wno-unticked-promoted-constructors -Wcompat - -Wincomplete-uni-patterns -Wincomplete-record-updates - -Wpartial-fields -Widentities -fno-ignore-asserts + -Wall -Wcompat -Wincomplete-uni-patterns + -Wincomplete-record-updates -Wpartial-fields -Widentities + -Wunused-packages -fno-ignore-asserts From 8bc94bf17648945b8a38433ca48f317d47f1ffdf Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Mon, 31 Jul 2023 10:55:16 +0200 Subject: [PATCH 25/75] Add Switch modules to turn on/off invariant checking using package flags --- cabal.project | 9 --- .../Class/MonadMVar/Strict/Checked/Switch.hs | 58 +++++++++++++++++++ .../MonadSTM/Strict/TVar/Checked/Switch.hs | 56 ++++++++++++++++++ strict-checked-vars/strict-checked-vars.cabal | 26 +++++++-- 4 files changed, 136 insertions(+), 13 deletions(-) create mode 100644 strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs create mode 100644 strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/Switch.hs diff --git a/cabal.project b/cabal.project index 6be3bf051..e81255f0a 100644 --- a/cabal.project +++ b/cabal.project @@ -45,12 +45,3 @@ if impl(ghc >= 9.6) , protolude:binary , protolude:bytestring , protolude:text - --- TODO: remove when a new version of strict-mvar (>1.1.0.0) is released -source-repository-package - type: git - location: https://github.com/input-output-hk/io-sim - tag: 1b2c22b376f5cda314b9ab444caaf77764961a18 - --sha256: 1qdxcqr4sl93n036p3pz1rvk6zf4qbsadzw4lgsp9agkh8pvs16y - subdir: - strict-mvar \ No newline at end of file diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs new file mode 100644 index 000000000..faa9c5528 --- /dev/null +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs @@ -0,0 +1,58 @@ +{-# LANGUAGE CPP #-} + +module Control.Concurrent.Class.MonadMVar.Strict.Checked.Switch ( + -- * StrictMVar + LazyMVar + , StrictMVar + , castStrictMVar + , fromLazyMVar + , isEmptyMVar + , modifyMVar + , modifyMVarMasked + , modifyMVarMasked_ + , modifyMVar_ + , newEmptyMVar + , newEmptyMVarWithInvariant + , newMVar + , newMVarWithInvariant + , putMVar + , readMVar + , swapMVar + , takeMVar + , toLazyMVar + , tryPutMVar + , tryReadMVar + , tryTakeMVar + , withMVar + , withMVarMasked + -- * Re-exports + , MonadMVar + ) where + +#if CHECK_MVAR_INVARIANTS +import qualified Control.Concurrent.Class.MonadMVar.Strict.Checked as StrictMVar.Checked +import Control.Concurrent.Class.MonadMVar.Strict.Checked hiding (newMVarWithInvariant, newEmptyMVarWithInvariant) +#else +import qualified Control.Concurrent.Class.MonadMVar.Strict as StrictMVar +import Control.Concurrent.Class.MonadMVar.Strict +#endif +import GHC.Stack (HasCallStack) + +newEmptyMVarWithInvariant :: MonadMVar m + => (a -> Maybe String) + -> m (StrictMVar m a) +#if CHECK_MVAR_INVARIANTS +newEmptyMVarWithInvariant = StrictMVar.Checked.newEmptyMVarWithInvariant +#else +newEmptyMVarWithInvariant _ = StrictMVar.newEmptyMVar +#endif + +newMVarWithInvariant :: (HasCallStack, MonadMVar m) + => (a -> Maybe String) + -> a + -> m (StrictMVar m a) +#if CHECK_MVAR_INVARIANTS +newMVarWithInvariant = StrictMVar.Checked.newMVarWithInvariant +#else +newMVarWithInvariant _ = StrictMVar.newMVar +#endif \ No newline at end of file diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/Switch.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/Switch.hs new file mode 100644 index 000000000..ec8ea36f8 --- /dev/null +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/Switch.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE CPP #-} + +module Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.Switch ( + -- * StrictTVar + LazyTVar + , StrictTVar + , castStrictTVar + , fromLazyTVar + , modifyTVar + , newTVar + , newTVarIO + , newTVarWithInvariant + , newTVarWithInvariantIO + , readTVar + , readTVarIO + , stateTVar + , swapTVar + , toLazyTVar + , writeTVar + -- * MonadLabelSTM + , labelTVar + , labelTVarIO + -- * MonadTraceSTM + , traceTVar + , traceTVarIO + ) where + +import Control.Concurrent.Class.MonadSTM (MonadSTM, STM) +#if CHECK_TVAR_INVARIANTS +import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked as StrictTVar.Checked +import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked hiding (newTVarWithInvariant, newTVarWithInvariantIO) +#else +import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar as StrictTVar +import Control.Concurrent.Class.MonadSTM.Strict.TVar +#endif +import GHC.Stack (HasCallStack) + +newTVarWithInvariant :: (MonadSTM m, HasCallStack) + => (a -> Maybe String) + -> a + -> STM m (StrictTVar m a) +#if CHECK_TVAR_INVARIANTS +newTVarWithInvariant = StrictTVar.Checked.newTVarWithInvariant +#else +newTVarWithInvariant _ = StrictTVar.newTVar +#endif + +newTVarWithInvariantIO :: (MonadSTM m, HasCallStack) + => (a -> Maybe String) + -> a + -> m (StrictTVar m a) +#if CHECK_TVAR_INVARIANTS +newTVarWithInvariantIO = StrictTVar.Checked.newTVarWithInvariantIO +#else +newTVarWithInvariantIO _ = StrictTVar.newTVarIO +#endif \ No newline at end of file diff --git a/strict-checked-vars/strict-checked-vars.cabal b/strict-checked-vars/strict-checked-vars.cabal index a3099de6f..b9db30265 100644 --- a/strict-checked-vars/strict-checked-vars.cabal +++ b/strict-checked-vars/strict-checked-vars.cabal @@ -24,31 +24,49 @@ extra-doc-files: README.md bug-reports: https://github.com/input-output-hk/cardano-base/issues -tested-with: GHC ==8.10 || ==9.2 || ==9.4 || ==9.6 +tested-with: GHC ==8.10 || ==9.2 || ==9.6 source-repository head type: git location: https://github.com/input-output-hk/cardano-base subdir: strict-checked-vars +flag checkmvarinvariants + description: Enable runtime invariant checks on StrictMVars + manual: True + default: False + +flag checktvarinvariants + description: Enable runtime invariant checks on StrictTVars + manual: True + default: False + library hs-source-dirs: src exposed-modules: Control.Concurrent.Class.MonadMVar.Strict.Checked + Control.Concurrent.Class.MonadMVar.Strict.Checked.Switch Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked + Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.Switch default-language: Haskell2010 build-depends: , base >=4.9 && <4.19 - , io-classes ^>=1.1 - , strict-mvar ^>=1.1 - , strict-stm ^>=1.1 + , io-classes ^>=1.2 + , strict-mvar ^>=1.2 + , strict-stm ^>=1.2 ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Widentities -Wunused-packages + if flag(checkmvarinvariants) + cpp-options: -DCHECK_MVAR_INVARIANTS + + if flag(checktvarinvariants) + cpp-options: -DCHECK_TVAR_INVARIANTS + test-suite test type: exitcode-stdio-1.0 hs-source-dirs: test From a0b666ecf10a268272957506b915910485265db2 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Mon, 31 Jul 2023 12:12:10 +0200 Subject: [PATCH 26/75] Update index-states --- cabal.project | 4 ++-- flake.lock | 6 +++--- 2 files changed, 5 insertions(+), 5 deletions(-) diff --git a/cabal.project b/cabal.project index e81255f0a..6fe3a68f5 100644 --- a/cabal.project +++ b/cabal.project @@ -10,9 +10,9 @@ repository cardano-haskell-packages d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee -- The hackage index-state -index-state: 2023-04-18T07:23:09Z +index-state: 2023-07-31T10:10:32Z -- The CHaP index-state -index-state: cardano-haskell-packages 2023-05-18T20:27:48Z +index-state: cardano-haskell-packages 2023-07-31T10:10:32Z packages: base-deriving-via diff --git a/flake.lock b/flake.lock index 3df6bf045..d8d1656ef 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1684408157, - "narHash": "sha256-hgHBZ+3HPitr71KBhQ/rhVGfZoUm9PgVntvOrDkkcg0=", + "lastModified": 1690795016, + "narHash": "sha256-UOIamXYb+xLDrTYs41BaaCun2C3P/cscH4jQ+/1R3w0=", "owner": "input-output-hk", "repo": "cardano-haskell-packages", - "rev": "ef8e5093f0ea0f1e59f944fa502c685b1bf085c2", + "rev": "75cb0539932adc80f03ebcdfbca9dcf6166015b1", "type": "github" }, "original": { From 138aebe374df5386039502cb7600b7df5e27cb88 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Mon, 31 Jul 2023 13:44:21 +0200 Subject: [PATCH 27/75] Update flake.lock --- CONTRBUTING.md | 2 +- flake.lock | 6 +++--- 2 files changed, 4 insertions(+), 4 deletions(-) diff --git a/CONTRBUTING.md b/CONTRBUTING.md index 7cdaa7420..7ae35ec52 100644 --- a/CONTRBUTING.md +++ b/CONTRBUTING.md @@ -62,7 +62,7 @@ the pinned index state you may need to call `cabal update` in order for `cabal` The Nix code which builds our packages also cares about the index state. This is represented by inputs managed by `nix flake`: You can update these by running: -- `nix flake lock --update-input hackage` for Hackage +- `nix flake lock --update-input haskellNix/hackage` for Hackage - `nix flake lock --update-input CHaP` for CHaP If you fail to do this you may get an error like this from Nix: diff --git a/flake.lock b/flake.lock index d8d1656ef..075692c34 100644 --- a/flake.lock +++ b/flake.lock @@ -343,11 +343,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1689553923, - "narHash": "sha256-B5pnktSnsj+sci6zEFmg52gWhmYmMUzyOTIbf9b1VAY=", + "lastModified": 1690676776, + "narHash": "sha256-6z8zYs1b4ZZWSM58H41TtfM7bKEqjFW2xaCSCJUbBHk=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "6debf045a11c4bcdd816ba0c7561d82abdf9c8dc", + "rev": "a21057809f37315eaba0188d8a737ababcaba7f5", "type": "github" }, "original": { From 3452c9e4c4423aae0bc52dfc357e9247a9444c0a Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 1 Aug 2023 14:21:44 +0200 Subject: [PATCH 28/75] strict-checked-vars: export checkInvariant Also build `strict-checked-vars` with invariants on CI --- .github/workflows/haskell.yml | 3 +++ .../Concurrent/Class/MonadMVar/Strict/Checked.hs | 2 ++ .../Class/MonadMVar/Strict/Checked/Switch.hs | 11 ++++++++++- .../Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs | 2 ++ .../Class/MonadSTM/Strict/TVar/Checked/Switch.hs | 11 ++++++++++- 5 files changed, 27 insertions(+), 2 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 2a1bb8750..dd4f303f9 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -96,6 +96,9 @@ jobs: MSYSTEM: MINGW64 run: cabal test all --enable-tests --test-show-details=direct -j1 + - name: Build strict-checked-vars with invariants + run: cabal build -f+checktvarinvariants -f+checkmvarinvariants strict-checked-vars + - uses: actions/upload-artifact@v3 with: name: Build & test logs diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs index a4a65e910..68b2490f0 100644 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs @@ -31,6 +31,8 @@ module Control.Concurrent.Class.MonadMVar.Strict.Checked ( , tryTakeMVar , withMVar , withMVarMasked + -- * Invariant + , checkInvariant -- * Re-exports , MonadMVar ) where diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs index faa9c5528..867f3e02a 100644 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs @@ -25,13 +25,15 @@ module Control.Concurrent.Class.MonadMVar.Strict.Checked.Switch ( , tryTakeMVar , withMVar , withMVarMasked + -- * Invariant + , checkInvariant -- * Re-exports , MonadMVar ) where #if CHECK_MVAR_INVARIANTS import qualified Control.Concurrent.Class.MonadMVar.Strict.Checked as StrictMVar.Checked -import Control.Concurrent.Class.MonadMVar.Strict.Checked hiding (newMVarWithInvariant, newEmptyMVarWithInvariant) +import Control.Concurrent.Class.MonadMVar.Strict.Checked hiding (checkInvariant, newMVarWithInvariant, newEmptyMVarWithInvariant) #else import qualified Control.Concurrent.Class.MonadMVar.Strict as StrictMVar import Control.Concurrent.Class.MonadMVar.Strict @@ -55,4 +57,11 @@ newMVarWithInvariant :: (HasCallStack, MonadMVar m) newMVarWithInvariant = StrictMVar.Checked.newMVarWithInvariant #else newMVarWithInvariant _ = StrictMVar.newMVar +#endif + +checkInvariant :: HasCallStack => Maybe String -> a -> a +#if CHECK_MVAR_INVARIANTS +checkInvariant = StrictMVar.Checked.checkInvariant +#else +checkInvariant = \_ a -> a #endif \ No newline at end of file diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs index fa369f61a..4b6d6df85 100644 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs @@ -29,6 +29,8 @@ module Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked ( -- * MonadTraceSTM , traceTVar , traceTVarIO + -- * Invariant + , checkInvariant ) where import Control.Concurrent.Class.MonadSTM (InspectMonad, diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/Switch.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/Switch.hs index ec8ea36f8..11150490a 100644 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/Switch.hs +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/Switch.hs @@ -23,12 +23,14 @@ module Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.Switch ( -- * MonadTraceSTM , traceTVar , traceTVarIO + -- * invariant + , checkInvariant ) where import Control.Concurrent.Class.MonadSTM (MonadSTM, STM) #if CHECK_TVAR_INVARIANTS import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked as StrictTVar.Checked -import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked hiding (newTVarWithInvariant, newTVarWithInvariantIO) +import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked hiding (checkInvariant, newTVarWithInvariant, newTVarWithInvariantIO) #else import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar as StrictTVar import Control.Concurrent.Class.MonadSTM.Strict.TVar @@ -53,4 +55,11 @@ newTVarWithInvariantIO :: (MonadSTM m, HasCallStack) newTVarWithInvariantIO = StrictTVar.Checked.newTVarWithInvariantIO #else newTVarWithInvariantIO _ = StrictTVar.newTVarIO +#endif + +checkInvariant :: HasCallStack => Maybe String -> a -> a +#if CHECK_TVAR_INVARIANTS +checkInvariant = StrictTVar.Checked.checkInvariant +#else +checkInvariant = \_ a -> a #endif \ No newline at end of file From 88fe5b18f1dc5bb594b72821b110e3d534a9f13e Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 1 Aug 2023 14:43:46 +0200 Subject: [PATCH 29/75] strict-checked-vars-0.1.0.1 --- strict-checked-vars/CHANGELOG.md | 4 ++++ strict-checked-vars/strict-checked-vars.cabal | 2 +- 2 files changed, 5 insertions(+), 1 deletion(-) diff --git a/strict-checked-vars/CHANGELOG.md b/strict-checked-vars/CHANGELOG.md index f50aed29f..497d75557 100644 --- a/strict-checked-vars/CHANGELOG.md +++ b/strict-checked-vars/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history of strict-checked-vars +## 0.1.0.1 + +* Export `checkInvariant`. + ## 0.1.0.0 * Initial version, not released on Hackage. diff --git a/strict-checked-vars/strict-checked-vars.cabal b/strict-checked-vars/strict-checked-vars.cabal index b9db30265..5d29385fd 100644 --- a/strict-checked-vars/strict-checked-vars.cabal +++ b/strict-checked-vars/strict-checked-vars.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: strict-checked-vars -version: 0.1.0.0 +version: 0.1.0.1 synopsis: Strict MVars and TVars with invariant checking for IO and IOSim From 0e2f101cd76eec14eb1e7b9f597d6b3fffa335cd Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Thu, 3 Aug 2023 22:28:33 +0200 Subject: [PATCH 30/75] More strict newTVarWithInvariant, newTVarWithInvariantIO and newMVarWithInvariant Although the underlying mutable variable is strict, we execute the invariant on the initial data, for this reason we have to evaluate it before writing it to the variable. --- strict-checked-vars/CHANGELOG.md | 4 ++++ .../src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs | 3 ++- .../Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs | 5 +++-- strict-checked-vars/strict-checked-vars.cabal | 2 +- 4 files changed, 10 insertions(+), 4 deletions(-) diff --git a/strict-checked-vars/CHANGELOG.md b/strict-checked-vars/CHANGELOG.md index 497d75557..e028fe4c1 100644 --- a/strict-checked-vars/CHANGELOG.md +++ b/strict-checked-vars/CHANGELOG.md @@ -1,5 +1,9 @@ # Revision history of strict-checked-vars +## 0.1.0.2 + +* Make `newTVarWithInvariant`, `newTVarWithInvariantIO` and `newMVarWithInvariant` strict. + ## 0.1.0.1 * Export `checkInvariant`. diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs index 68b2490f0..581dccabd 100644 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -99,7 +100,7 @@ newMVarWithInvariant :: (HasCallStack, MonadMVar m) => (a -> Maybe String) -> a -> m (StrictMVar m a) -newMVarWithInvariant inv a = +newMVarWithInvariant inv !a = checkInvariant (inv a) $ StrictMVar inv <$> Strict.newMVar a diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs index 4b6d6df85..8bcb27ada 100644 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE BangPatterns #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -85,7 +86,7 @@ newTVarWithInvariant :: (MonadSTM m, HasCallStack) => (a -> Maybe String) -> a -> STM m (StrictTVar m a) -newTVarWithInvariant inv a = +newTVarWithInvariant inv !a = checkInvariant (inv a) $ StrictTVar inv <$> Strict.newTVar a @@ -93,7 +94,7 @@ newTVarWithInvariantIO :: (MonadSTM m, HasCallStack) => (a -> Maybe String) -> a -> m (StrictTVar m a) -newTVarWithInvariantIO inv a = +newTVarWithInvariantIO inv !a = checkInvariant (inv a) $ StrictTVar inv <$> Strict.newTVarIO a diff --git a/strict-checked-vars/strict-checked-vars.cabal b/strict-checked-vars/strict-checked-vars.cabal index 5d29385fd..352c5d538 100644 --- a/strict-checked-vars/strict-checked-vars.cabal +++ b/strict-checked-vars/strict-checked-vars.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: strict-checked-vars -version: 0.1.0.1 +version: 0.1.0.2 synopsis: Strict MVars and TVars with invariant checking for IO and IOSim From 0d16bb3b08bd1527f88d5363312574478e3f3a89 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Fri, 4 Aug 2023 13:04:39 +0200 Subject: [PATCH 31/75] Make writeTVar more strict It needs to evaluate the argument to WHNF before passing it to `checkInvariant`. --- .../Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs | 2 +- strict-checked-vars/strict-checked-vars.cabal | 2 +- 2 files changed, 2 insertions(+), 2 deletions(-) diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs index 8bcb27ada..4ff3f9bd3 100644 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs @@ -105,7 +105,7 @@ readTVarIO :: MonadSTM m => StrictTVar m a -> m a readTVarIO = Strict.readTVarIO . tvar writeTVar :: (MonadSTM m, HasCallStack) => StrictTVar m a -> a -> STM m () -writeTVar v a = +writeTVar v !a = checkInvariant (invariant v a) $ Strict.writeTVar (tvar v) a diff --git a/strict-checked-vars/strict-checked-vars.cabal b/strict-checked-vars/strict-checked-vars.cabal index 352c5d538..6334a0f9f 100644 --- a/strict-checked-vars/strict-checked-vars.cabal +++ b/strict-checked-vars/strict-checked-vars.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: strict-checked-vars -version: 0.1.0.2 +version: 0.1.0.3 synopsis: Strict MVars and TVars with invariant checking for IO and IOSim From 565ee61ae2a8f1d15609f83e62e5c5ea0028eef4 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Fri, 4 Aug 2023 16:34:05 +0200 Subject: [PATCH 32/75] WHNF tests for strict-checked-vars --- .../Class/MonadMVar/Strict/Checked.hs | 4 + strict-checked-vars/strict-checked-vars.cabal | 4 + strict-checked-vars/test/Main.hs | 8 +- .../Class/MonadMVar/Strict/Checked.hs | 2 + .../Class/MonadMVar/Strict/Checked/WHNF.hs | 208 ++++++++++++++++++ .../MonadSTM/Strict/TVar/Checked/WHNF.hs | 192 ++++++++++++++++ strict-checked-vars/test/Test/Utils.hs | 40 ++++ 7 files changed, 455 insertions(+), 3 deletions(-) create mode 100644 strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked/WHNF.hs create mode 100644 strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/WHNF.hs diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs index 581dccabd..49929bf23 100644 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs @@ -96,6 +96,10 @@ newEmptyMVarWithInvariant inv = StrictMVar inv <$> Strict.newEmptyMVar newMVar :: MonadMVar m => a -> m (StrictMVar m a) newMVar a = StrictMVar (const Nothing) <$> Strict.newMVar a +-- | Create a 'StrictMVar' with an invariant. +-- +-- Contrary to functions that modify a 'StrictMVar', this function checks the +-- invariant /before/ putting the value in a new 'StrictMVar'. newMVarWithInvariant :: (HasCallStack, MonadMVar m) => (a -> Maybe String) -> a diff --git a/strict-checked-vars/strict-checked-vars.cabal b/strict-checked-vars/strict-checked-vars.cabal index 6334a0f9f..c3ee536dd 100644 --- a/strict-checked-vars/strict-checked-vars.cabal +++ b/strict-checked-vars/strict-checked-vars.cabal @@ -73,12 +73,16 @@ test-suite test main-is: Main.hs other-modules: Test.Control.Concurrent.Class.MonadMVar.Strict.Checked + Test.Control.Concurrent.Class.MonadMVar.Strict.Checked.WHNF + Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.WHNF Test.Utils default-language: Haskell2010 build-depends: , base >=4.9 && <4.19 + , io-classes , io-sim + , nothunks , QuickCheck , strict-checked-vars , tasty diff --git a/strict-checked-vars/test/Main.hs b/strict-checked-vars/test/Main.hs index 4b7213dbc..cc170dd78 100644 --- a/strict-checked-vars/test/Main.hs +++ b/strict-checked-vars/test/Main.hs @@ -1,9 +1,11 @@ module Main where -import qualified Test.Control.Concurrent.Class.MonadMVar.Strict.Checked as Checked -import Test.Tasty +import qualified Test.Control.Concurrent.Class.MonadMVar.Strict.Checked as Test.StrictMVar.Checked +import qualified Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.WHNF as Test.StrictTVar.Checked +import Test.Tasty (defaultMain, testGroup) main :: IO () main = defaultMain $ testGroup "strict-checked-vars" [ - Checked.tests + Test.StrictMVar.Checked.tests + , Test.StrictTVar.Checked.tests ] diff --git a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs index bdedfa2d4..039746e62 100644 --- a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs +++ b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs @@ -3,6 +3,7 @@ module Test.Control.Concurrent.Class.MonadMVar.Strict.Checked where import Control.Concurrent.Class.MonadMVar.Strict.Checked +import qualified Test.Control.Concurrent.Class.MonadMVar.Strict.Checked.WHNF as Test.WHNF import Test.QuickCheck.Monadic import Test.Tasty import Test.Tasty.QuickCheck @@ -23,6 +24,7 @@ tests = testGroup "Test.Control.Concurrent.Class.MonadMVar.Strict" [ , testProperty "prop_invariantShouldNotFail" $ once $ monadicSim prop_invariantShouldNotFail ] + , Test.WHNF.tests ] ] diff --git a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked/WHNF.hs b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked/WHNF.hs new file mode 100644 index 000000000..d249e2821 --- /dev/null +++ b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked/WHNF.hs @@ -0,0 +1,208 @@ +{-# LANGUAGE LambdaCase #-} + +module Test.Control.Concurrent.Class.MonadMVar.Strict.Checked.WHNF where + +import Control.Concurrent.Class.MonadMVar.Strict.Checked hiding + (newEmptyMVar, newEmptyMVarWithInvariant, newMVar, + newMVarWithInvariant) +import qualified Control.Concurrent.Class.MonadMVar.Strict.Checked as Checked +import Control.Monad (void) +import Data.Typeable (Typeable) +import NoThunks.Class (OnlyCheckWhnf (OnlyCheckWhnf), unsafeNoThunks) +import Test.QuickCheck.Monadic (PropertyM, monadicIO, monitor, run) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (Fun, applyFun, counterexample, + testProperty) +import Test.Utils (Invariant (..), monadicSim, noInvariant, + trivialInvariant, whnfInvariant, (.:)) + +{------------------------------------------------------------------------------- + Main test tree +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "WHNF" [ + testGroup "IO" [ + testIO "No invariant" noInvariant + , testIO "Trivial invariant" trivialInvariant + , testIO "WHNF invariant" whnfInvariant + ] + , testGroup "IOSim" [ + testIOSim "No invariant" noInvariant + , testIOSim "Trivial invariant" trivialInvariant + , testIOSim "WHNF invariant" whnfInvariant + ] + ] + where + testIO name inv = testGroup name [ + testProperty "prop_newMVarWithInvariant" $ + monadicIO .: prop_newMVarWithInvariant inv + , testProperty "prop_putMVar" $ + monadicIO .: prop_putMVar inv + , testProperty "prop_swapMVar" $ + monadicIO .: prop_swapMVar inv + , testProperty "prop_tryPutMVarJust" $ + monadicIO .: prop_tryPutMVarNothing inv + , testProperty "prop_tryPutMVarNothing" $ + monadicIO .: prop_tryPutMVarNothing inv + , testProperty "prop_modifyMVar_" $ + monadicIO .: prop_modifyMVar_ inv + , testProperty "prop_modifyMVar" $ + monadicIO .: prop_modifyMVar inv + , testProperty "prop_modifyMVarMasked_" $ + monadicIO .: prop_modifyMVarMasked_ inv + , testProperty "prop_modifyMVarMasked" $ + monadicIO .: prop_modifyMVarMasked inv + ] + + testIOSim name inv = testGroup name [ + testProperty "prop_newMVarWithInvariant" $ \x f -> + monadicSim $ prop_newMVarWithInvariant inv x f + , testProperty "prop_putMVar" $ \x f -> + monadicSim $ prop_putMVar inv x f + , testProperty "prop_swapMVar" $ \x f -> + monadicSim $ prop_swapMVar inv x f + , testProperty "prop_tryPutMVarJust" $ \x f -> + monadicSim $ prop_tryPutMVarJust inv x f + , testProperty "prop_tryPutMVarNothing" $ \x f -> + monadicSim $ prop_tryPutMVarNothing inv x f + , testProperty "prop_modifyMVar_" $ \x f -> + monadicSim $ prop_modifyMVar_ inv x f + , testProperty "prop_modifyMVar" $ \x f -> + monadicSim $ prop_modifyMVar inv x f + , testProperty "prop_modifyMVarMasked_" $ \x f -> + monadicSim $ prop_modifyMVarMasked_ inv x f + , testProperty "prop_modifyMVarMasked" $ \x f -> + monadicSim $ prop_modifyMVarMasked inv x f + ] + +{------------------------------------------------------------------------------- + Utilities +-------------------------------------------------------------------------------} + +isInWHNF :: (MonadMVar m, Typeable a) => StrictMVar m a -> PropertyM m Bool +isInWHNF v = do + x <- run $ readMVar v + case unsafeNoThunks (OnlyCheckWhnf x) of + Nothing -> pure True + Just tinfo -> monitor (counterexample $ "Not in WHNF: " ++ show tinfo) + >> pure False + +-- | Wrapper around 'Checked.newMVar' and 'Checked.newMVarWithInvariant'. +newMVarWithInvariant :: MonadMVar m => Invariant a -> a -> m (StrictMVar m a) +newMVarWithInvariant = \case + NoInvariant -> Checked.newMVar + Invariant inv -> Checked.newMVarWithInvariant inv + +-- | Wrapper around 'Checked.newEmptyMVar' and +-- 'Checked.newEmptyMVarWithInvariant'. +newEmptyMVarWithInvariant :: MonadMVar m => Invariant a -> m (StrictMVar m a) +newEmptyMVarWithInvariant = \case + NoInvariant -> Checked.newEmptyMVar + Invariant inv -> Checked.newEmptyMVarWithInvariant inv + +{------------------------------------------------------------------------------- + Properties +-------------------------------------------------------------------------------} + +-- | Test 'newMVarWithInvariant', not to be confused with +-- 'Checked.newMVarWithInvariant'. +prop_newMVarWithInvariant :: + MonadMVar m + => Invariant Int + -> Int + -> Fun Int Int + -> PropertyM m Bool +prop_newMVarWithInvariant inv x f = do + v <- run $ newMVarWithInvariant inv (applyFun f x) + isInWHNF v + +prop_putMVar :: + MonadMVar m + => Invariant Int + -> Int + -> Fun Int Int + -> PropertyM m Bool +prop_putMVar inv x f = do + v <- run $ newEmptyMVarWithInvariant inv + run $ putMVar v (applyFun f x) + isInWHNF v + +prop_swapMVar :: + MonadMVar m + => Invariant Int + -> Int + -> Fun Int Int + -> PropertyM m Bool +prop_swapMVar inv x f = do + v <- run $ newMVarWithInvariant inv x + void $ run $ swapMVar v (applyFun f x) + isInWHNF v + +prop_tryPutMVarJust :: + MonadMVar m + => Invariant Int + -> Int + -> Fun Int Int + -> PropertyM m Bool +prop_tryPutMVarJust inv x f = do + v <- run $ newEmptyMVarWithInvariant inv + b <- run $ tryPutMVar v (applyFun f x) + b' <- isInWHNF v + pure (b && b') + +prop_tryPutMVarNothing :: + MonadMVar m + => Invariant Int + -> Int + -> Fun Int Int + -> PropertyM m Bool +prop_tryPutMVarNothing inv x f = do + v <- run $ newMVarWithInvariant inv x + b <- run $ tryPutMVar v (applyFun f x) + b' <- isInWHNF v + pure (not b && b') + +prop_modifyMVar_ :: + MonadMVar m + => Invariant Int + -> Int + -> Fun Int Int + -> PropertyM m Bool +prop_modifyMVar_ inv x f = do + v <- run $ newMVarWithInvariant inv x + run $ modifyMVar_ v (pure . applyFun f) + isInWHNF v + +prop_modifyMVar :: + MonadMVar m + => Invariant Int + -> Int + -> Fun Int (Int, Char) + -> PropertyM m Bool +prop_modifyMVar inv x f =do + v <- run $ newMVarWithInvariant inv x + void $ run $ modifyMVar v (pure . applyFun f) + isInWHNF v + +prop_modifyMVarMasked_ :: + MonadMVar m + => Invariant Int + -> Int + -> Fun Int Int + -> PropertyM m Bool +prop_modifyMVarMasked_ inv x f =do + v <- run $ newMVarWithInvariant inv x + void $ run $ modifyMVarMasked_ v (pure . applyFun f) + isInWHNF v + +prop_modifyMVarMasked :: + MonadMVar m + => Invariant Int + -> Int + -> Fun Int (Int, Char) + -> PropertyM m Bool +prop_modifyMVarMasked inv x f =do + v <- run $ newMVarWithInvariant inv x + void $ run $ modifyMVarMasked v (pure . applyFun f) + isInWHNF v diff --git a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/WHNF.hs b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/WHNF.hs new file mode 100644 index 000000000..b561a470a --- /dev/null +++ b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/WHNF.hs @@ -0,0 +1,192 @@ +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE TupleSections #-} + +module Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.WHNF where + +import Control.Concurrent.Class.MonadSTM (MonadSTM, STM, atomically) +import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked hiding + (newTVar, newTVarIO, newTVarWithInvariant, + newTVarWithInvariantIO) +import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked as Checked +import Control.Monad (void) +import Data.Typeable (Typeable) +import NoThunks.Class (OnlyCheckWhnf (OnlyCheckWhnf), unsafeNoThunks) +import Test.QuickCheck.Monadic (PropertyM, monadicIO, monitor, run) +import Test.Tasty (TestTree, testGroup) +import Test.Tasty.QuickCheck (Fun, applyFun, counterexample, + testProperty) +import Test.Utils (Invariant (..), monadicSim, noInvariant, + trivialInvariant, whnfInvariant, (.:)) + +{------------------------------------------------------------------------------- + Main test tree +-------------------------------------------------------------------------------} + +tests :: TestTree +tests = testGroup "Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.WHNF" [ + testGroup "IO" [ + testIO "No invariant" sanityCheckWhnf noInvariant + , testIO "Trivial invariant" sanityCheckWhnf trivialInvariant + , testIO "WHNF invariant" sanityCheckWhnf whnfInvariant + ] + -- Sanity checks for WHNF fail in IOSim because IOSim runs in the lazy ST + -- monad, so we turn off sanity checks here. + , testGroup "IOSim" [ + testIOSim "No invariant" noSanityCheckWhnf noInvariant + , testIOSim "Trivial invariant" noSanityCheckWhnf trivialInvariant + , testIOSim "WHNF invariant" noSanityCheckWhnf whnfInvariant + ] + ] + where + testIO name check inv = testGroup name [ + testProperty "prop_newTVarWithInvariant" $ + monadicIO .: prop_newTVarWithInvariant check inv + , testProperty "prop_newTVarWithInvariantIO" $ + monadicIO .: prop_newTVarWithInvariantIO check inv + , testProperty "prop_writeTVar" $ + monadicIO .: prop_writeTVar check inv + , testProperty "prop_modifyTVar" $ + monadicIO .: prop_modifyTVar check inv + , testProperty "prop_stateTVar" $ + monadicIO .: prop_stateTVar check inv + , testProperty "prop_swapTVar" $ + monadicIO .: prop_swapTVar check inv + ] + + testIOSim name check inv = testGroup name [ + testProperty "prop_newTVarWithInvariant" $ \x f -> + monadicSim $ prop_newTVarWithInvariant check inv x f + , testProperty "prop_newTVarWithInvariantIO" $ \x f -> + monadicSim $ prop_newTVarWithInvariantIO check inv x f + , testProperty "prop_writeTVar" $ \x f -> + monadicSim $ prop_writeTVar check inv x f + , testProperty "prop_modifyTVar" $ \x f -> + monadicSim $ prop_modifyTVar check inv x f + , testProperty "prop_stateTVar" $ \x f -> + monadicSim $ prop_stateTVar check inv x f + , testProperty "prop_swapTVar" $ \x f -> + monadicSim $ prop_swapTVar check inv x f + ] + +{------------------------------------------------------------------------------- + Utilities +-------------------------------------------------------------------------------} + + +isInWHNF :: (MonadSTM m, Typeable a) => StrictTVar m a -> PropertyM m Bool +isInWHNF v = do + x <- run $ readTVarIO v + case unsafeNoThunks (OnlyCheckWhnf x) of + Nothing -> pure True + Just tinfo -> monitor (counterexample $ "Not in WHNF: " ++ show tinfo) + >> pure False + +-- | Wrapper around 'Checked.newTVar' and 'Checked.newTVarWithInvariant'. +newTVarWithInvariant :: MonadSTM m => Invariant a -> a -> STM m (StrictTVar m a) +newTVarWithInvariant = \case + NoInvariant -> Checked.newTVar + Invariant inv -> Checked.newTVarWithInvariant inv + +-- | Wrapper around 'Checked.newTVarIO' and 'Checked.newTVarWithInvariantIO'. +newTVarWithInvariantIO :: MonadSTM m => Invariant a -> a -> m (StrictTVar m a) +newTVarWithInvariantIO = \case + NoInvariant -> Checked.newTVarIO + Invariant inv -> Checked.newTVarWithInvariantIO inv + +newtype SanityCheckWhnf = SanityCheckWhnf { getSanityCheckWhnf :: Bool } + deriving (Show, Eq) + +noSanityCheckWhnf :: SanityCheckWhnf +noSanityCheckWhnf = SanityCheckWhnf False + +sanityCheckWhnf :: SanityCheckWhnf +sanityCheckWhnf = SanityCheckWhnf True + +withSanityCheckWhnf :: + (MonadSTM m, Typeable a) + => SanityCheckWhnf + -> StrictTVar m a + -> PropertyM m Bool +withSanityCheckWhnf check v = + if getSanityCheckWhnf check then + isInWHNF v + else + pure True + +{------------------------------------------------------------------------------- + Properties +-------------------------------------------------------------------------------} + +-- | Test 'newTVarWithInvariant', not to be confused with +-- 'Checked.newTVarWithInvariant'. +prop_newTVarWithInvariant :: + MonadSTM m + => SanityCheckWhnf + -> Invariant Int + -> Int + -> Fun Int Int + -> PropertyM m Bool +prop_newTVarWithInvariant check inv x f = do + v <- run $ atomically $ newTVarWithInvariant inv (applyFun f x) + withSanityCheckWhnf check v + +-- | Test 'newTVarWithInvariantIO', not to be confused with +-- 'Checked.newTVarWithInvariantIO'. +prop_newTVarWithInvariantIO :: + MonadSTM m + => SanityCheckWhnf + -> Invariant Int + -> Int + -> Fun Int Int + -> PropertyM m Bool +prop_newTVarWithInvariantIO check inv x f = do + v <- run $ newTVarWithInvariantIO inv (applyFun f x) + withSanityCheckWhnf check v + +prop_writeTVar :: + MonadSTM m + => SanityCheckWhnf + -> Invariant Int + -> Int + -> Fun Int Int + -> PropertyM m Bool +prop_writeTVar check inv x f = do + v <- run $ newTVarWithInvariantIO inv x + run $ atomically $ writeTVar v (applyFun f x) + withSanityCheckWhnf check v + +prop_modifyTVar :: + MonadSTM m + => SanityCheckWhnf + -> Invariant Int + -> Int + -> Fun Int Int + -> PropertyM m Bool +prop_modifyTVar check inv x f = do + v <- run $ newTVarWithInvariantIO inv x + run $ atomically $ modifyTVar v (applyFun f) + withSanityCheckWhnf check v + +prop_stateTVar :: + MonadSTM m + => SanityCheckWhnf + -> Invariant Int + -> Int + -> Fun Int Int + -> PropertyM m Bool +prop_stateTVar check inv x f = do + v <- run $ newTVarWithInvariantIO inv x + run $ atomically $ stateTVar v (((),) . applyFun f) + withSanityCheckWhnf check v + +prop_swapTVar :: + MonadSTM m + => SanityCheckWhnf + -> Invariant Int + -> Int + -> Fun Int Int + -> PropertyM m Bool +prop_swapTVar check inv x f = do + v <- run $ newTVarWithInvariantIO inv x + void $ run $ atomically $ swapTVar v (applyFun f x) + withSanityCheckWhnf check v diff --git a/strict-checked-vars/test/Test/Utils.hs b/strict-checked-vars/test/Test/Utils.hs index 8600a2c6d..2788b6b8c 100644 --- a/strict-checked-vars/test/Test/Utils.hs +++ b/strict-checked-vars/test/Test/Utils.hs @@ -1,11 +1,21 @@ {-# LANGUAGE RankNTypes #-} module Test.Utils ( + -- * Property runners monadicSim , runSimGen + -- * Function composition + , (.:) + -- * Invariants + , Invariant (..) + , noInvariant + , trivialInvariant + , whnfInvariant ) where import Control.Monad.IOSim (IOSim, runSimOrThrow) +import Data.Typeable (Typeable) +import NoThunks.Class (OnlyCheckWhnf (..), unsafeNoThunks) import Test.QuickCheck (Gen, Property, Testable (..)) import Test.QuickCheck.Gen.Unsafe (Capture (..), capture) import Test.QuickCheck.Monadic (PropertyM, monadic') @@ -21,3 +31,33 @@ runSimGen f = do monadicSim :: Testable a => (forall s. PropertyM (IOSim s) a) -> Property monadicSim m = property (runSimGen (monadic' m)) + +{------------------------------------------------------------------------------- + Function composition +-------------------------------------------------------------------------------} + +infixr 9 .: + +(.:) :: (y -> z) -> (x0 -> x1 -> y) -> (x0 -> x1 -> z) +(.:) g f x0 x1 = g (f x0 x1) + +{------------------------------------------------------------------------------- + Invariants +-------------------------------------------------------------------------------} + +-- | Invariants +-- +-- Testing with @'Invariant' (const Nothing)'@ /should/ be the same as testing +-- with 'NoInvariant'. +data Invariant a = + NoInvariant + | Invariant (a -> Maybe String) + +noInvariant :: Invariant a +noInvariant = NoInvariant + +whnfInvariant :: Typeable a => Invariant a +whnfInvariant = Invariant $ fmap show . unsafeNoThunks . OnlyCheckWhnf + +trivialInvariant :: Invariant a +trivialInvariant = Invariant $ const Nothing From f9c308e5124838b8970fb1bdc9084ab9fd9de4bf Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Mon, 7 Aug 2023 15:18:50 +0200 Subject: [PATCH 33/75] Refactoring --- cabal.project | 2 +- .../Class/MonadMVar/Strict/Checked/WHNF.hs | 292 +++++++++++------ .../MonadSTM/Strict/TVar/Checked/WHNF.hs | 299 ++++++++++++------ strict-checked-vars/test/Test/Utils.hs | 8 +- 4 files changed, 408 insertions(+), 193 deletions(-) diff --git a/cabal.project b/cabal.project index 6fe3a68f5..fa99ce943 100644 --- a/cabal.project +++ b/cabal.project @@ -12,7 +12,7 @@ repository cardano-haskell-packages -- The hackage index-state index-state: 2023-07-31T10:10:32Z -- The CHaP index-state -index-state: cardano-haskell-packages 2023-07-31T10:10:32Z +index-state: cardano-haskell-packages 2023-08-08T14:32:15Z packages: base-deriving-via diff --git a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked/WHNF.hs b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked/WHNF.hs index d249e2821..d59665b15 100644 --- a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked/WHNF.hs +++ b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked/WHNF.hs @@ -7,14 +7,14 @@ import Control.Concurrent.Class.MonadMVar.Strict.Checked hiding newMVarWithInvariant) import qualified Control.Concurrent.Class.MonadMVar.Strict.Checked as Checked import Control.Monad (void) +import Control.Monad.IOSim (runSimOrThrow) import Data.Typeable (Typeable) -import NoThunks.Class (OnlyCheckWhnf (OnlyCheckWhnf), unsafeNoThunks) -import Test.QuickCheck.Monadic (PropertyM, monadicIO, monitor, run) +import NoThunks.Class (OnlyCheckWhnf (..), unsafeNoThunks) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (Fun, applyFun, counterexample, - testProperty) -import Test.Utils (Invariant (..), monadicSim, noInvariant, - trivialInvariant, whnfInvariant, (.:)) +import Test.Tasty.QuickCheck (Fun, Property, applyFun, counterexample, + ioProperty, property, testProperty, (.&&.)) +import Test.Utils (Invariant (..), noInvariant, trivialInvariant, + whnfInvariant, (..:)) {------------------------------------------------------------------------------- Main test tree @@ -35,58 +35,58 @@ tests = testGroup "WHNF" [ ] where testIO name inv = testGroup name [ - testProperty "prop_newMVarWithInvariant" $ - monadicIO .: prop_newMVarWithInvariant inv - , testProperty "prop_putMVar" $ - monadicIO .: prop_putMVar inv - , testProperty "prop_swapMVar" $ - monadicIO .: prop_swapMVar inv - , testProperty "prop_tryPutMVarJust" $ - monadicIO .: prop_tryPutMVarNothing inv - , testProperty "prop_tryPutMVarNothing" $ - monadicIO .: prop_tryPutMVarNothing inv - , testProperty "prop_modifyMVar_" $ - monadicIO .: prop_modifyMVar_ inv - , testProperty "prop_modifyMVar" $ - monadicIO .: prop_modifyMVar inv - , testProperty "prop_modifyMVarMasked_" $ - monadicIO .: prop_modifyMVarMasked_ inv - , testProperty "prop_modifyMVarMasked" $ - monadicIO .: prop_modifyMVarMasked inv + testProperty "prop_IO_newMVarWithInvariant" $ + prop_IO_newMVarWithInvariant inv + , testProperty "prop_IO_putMVar" $ + prop_IO_putMVar inv + , testProperty "prop_IO_swapMVar" $ + prop_IO_swapMVar inv + , testProperty "prop_IO_tryPutMVarJust" $ + prop_IO_tryPutMVarJust inv + , testProperty "prop_IO_tryPutMVarNothing" $ + prop_IO_tryPutMVarNothing inv + , testProperty "prop_IO_modifyMVar_" $ + prop_IO_modifyMVar_ inv + , testProperty "prop_IO_modifyMVar" $ + prop_IO_modifyMVar inv + , testProperty "prop_IO_modifyMVarMasked_" $ + prop_IO_modifyMVarMasked_ inv + , testProperty "prop_IO_modifyMVarMasked" $ + prop_IO_modifyMVarMasked inv ] testIOSim name inv = testGroup name [ - testProperty "prop_newMVarWithInvariant" $ \x f -> - monadicSim $ prop_newMVarWithInvariant inv x f - , testProperty "prop_putMVar" $ \x f -> - monadicSim $ prop_putMVar inv x f - , testProperty "prop_swapMVar" $ \x f -> - monadicSim $ prop_swapMVar inv x f - , testProperty "prop_tryPutMVarJust" $ \x f -> - monadicSim $ prop_tryPutMVarJust inv x f - , testProperty "prop_tryPutMVarNothing" $ \x f -> - monadicSim $ prop_tryPutMVarNothing inv x f - , testProperty "prop_modifyMVar_" $ \x f -> - monadicSim $ prop_modifyMVar_ inv x f - , testProperty "prop_modifyMVar" $ \x f -> - monadicSim $ prop_modifyMVar inv x f - , testProperty "prop_modifyMVarMasked_" $ \x f -> - monadicSim $ prop_modifyMVarMasked_ inv x f - , testProperty "prop_modifyMVarMasked" $ \x f -> - monadicSim $ prop_modifyMVarMasked inv x f + testProperty "prop_IOSim_newMVarWithInvariant" $ + prop_IOSim_newMVarWithInvariant inv + , testProperty "prop_IOSim_putMVar" $ + prop_IOSim_putMVar inv + , testProperty "prop_IOSim_swapMVar" $ + prop_IOSim_swapMVar inv + , testProperty "prop_IOSim_tryPutMVarJust" $ + prop_IOSim_tryPutMVarJust inv + , testProperty "prop_IOSim_tryPutMVarNothing" $ + prop_IOSim_tryPutMVarNothing inv + , testProperty "prop_IOSim_modifyMVar_" $ + prop_IOSim_modifyMVar_ inv + , testProperty "prop_IOSim_modifyMVar" $ + prop_IOSim_modifyMVar inv + , testProperty "prop_IOSim_modifyMVarMasked_" $ + prop_IOSim_modifyMVarMasked_ inv + , testProperty "prop_IOSim_modifyMVarMasked" $ + prop_IOSim_modifyMVarMasked inv ] {------------------------------------------------------------------------------- Utilities -------------------------------------------------------------------------------} -isInWHNF :: (MonadMVar m, Typeable a) => StrictMVar m a -> PropertyM m Bool +isInWHNF :: (MonadMVar m, Typeable a) => StrictMVar m a -> m Property isInWHNF v = do - x <- run $ readMVar v - case unsafeNoThunks (OnlyCheckWhnf x) of - Nothing -> pure True - Just tinfo -> monitor (counterexample $ "Not in WHNF: " ++ show tinfo) - >> pure False + x <- readMVar v + pure $ case unsafeNoThunks (OnlyCheckWhnf x) of + Nothing -> property True + Just tinfo -> counterexample ("Not in WHNF: " ++ show tinfo) + $ property False -- | Wrapper around 'Checked.newMVar' and 'Checked.newMVarWithInvariant'. newMVarWithInvariant :: MonadMVar m => Invariant a -> a -> m (StrictMVar m a) @@ -105,104 +105,208 @@ newEmptyMVarWithInvariant = \case Properties -------------------------------------------------------------------------------} +-- +-- newMVarWithInvariant +-- + -- | Test 'newMVarWithInvariant', not to be confused with -- 'Checked.newMVarWithInvariant'. -prop_newMVarWithInvariant :: +prop_M_newMVarWithInvariant :: MonadMVar m => Invariant Int -> Int -> Fun Int Int - -> PropertyM m Bool -prop_newMVarWithInvariant inv x f = do - v <- run $ newMVarWithInvariant inv (applyFun f x) + -> m Property +prop_M_newMVarWithInvariant inv x f = do + v <- newMVarWithInvariant inv (applyFun f x) isInWHNF v -prop_putMVar :: +prop_IO_newMVarWithInvariant :: Invariant Int -> Int -> Fun Int Int -> Property +prop_IO_newMVarWithInvariant = ioProperty ..: + prop_M_newMVarWithInvariant + +prop_IOSim_newMVarWithInvariant :: Invariant Int -> Int -> Fun Int Int -> Property +prop_IOSim_newMVarWithInvariant inv x f = runSimOrThrow $ + prop_M_newMVarWithInvariant inv x f + +-- +-- putMVar +-- + +prop_M_putMVar :: MonadMVar m => Invariant Int -> Int -> Fun Int Int - -> PropertyM m Bool -prop_putMVar inv x f = do - v <- run $ newEmptyMVarWithInvariant inv - run $ putMVar v (applyFun f x) + -> m Property +prop_M_putMVar inv x f = do + v <- newEmptyMVarWithInvariant inv + putMVar v (applyFun f x) isInWHNF v -prop_swapMVar :: +prop_IO_putMVar :: Invariant Int -> Int -> Fun Int Int -> Property +prop_IO_putMVar = ioProperty ..: + prop_M_putMVar + +prop_IOSim_putMVar :: Invariant Int -> Int -> Fun Int Int -> Property +prop_IOSim_putMVar inv x f = runSimOrThrow $ + prop_M_putMVar inv x f + + +-- +-- swapMVar +-- + +prop_M_swapMVar :: MonadMVar m => Invariant Int -> Int -> Fun Int Int - -> PropertyM m Bool -prop_swapMVar inv x f = do - v <- run $ newMVarWithInvariant inv x - void $ run $ swapMVar v (applyFun f x) + -> m Property +prop_M_swapMVar inv x f = do + v <- newMVarWithInvariant inv x + void $ swapMVar v (applyFun f x) isInWHNF v -prop_tryPutMVarJust :: +prop_IO_swapMVar :: Invariant Int -> Int -> Fun Int Int -> Property +prop_IO_swapMVar = ioProperty ..: + prop_M_swapMVar + +prop_IOSim_swapMVar :: Invariant Int -> Int -> Fun Int Int -> Property +prop_IOSim_swapMVar inv x f = runSimOrThrow $ + prop_M_swapMVar inv x f +-- +-- tryPutMVar +-- + +prop_M_tryPutMVarJust :: MonadMVar m => Invariant Int -> Int -> Fun Int Int - -> PropertyM m Bool -prop_tryPutMVarJust inv x f = do - v <- run $ newEmptyMVarWithInvariant inv - b <- run $ tryPutMVar v (applyFun f x) + -> m Property +prop_M_tryPutMVarJust inv x f = do + v <- newEmptyMVarWithInvariant inv + b <- tryPutMVar v (applyFun f x) b' <- isInWHNF v - pure (b && b') + pure (property b .&&. b') -prop_tryPutMVarNothing :: +prop_IO_tryPutMVarJust :: Invariant Int -> Int -> Fun Int Int -> Property +prop_IO_tryPutMVarJust = ioProperty ..: + prop_M_tryPutMVarJust + +prop_IOSim_tryPutMVarJust :: Invariant Int -> Int -> Fun Int Int -> Property +prop_IOSim_tryPutMVarJust inv x f = runSimOrThrow $ + prop_M_tryPutMVarJust inv x f + +prop_M_tryPutMVarNothing :: MonadMVar m => Invariant Int -> Int -> Fun Int Int - -> PropertyM m Bool -prop_tryPutMVarNothing inv x f = do - v <- run $ newMVarWithInvariant inv x - b <- run $ tryPutMVar v (applyFun f x) + -> m Property +prop_M_tryPutMVarNothing inv x f = do + v <- newMVarWithInvariant inv x + b <- tryPutMVar v (applyFun f x) b' <- isInWHNF v - pure (not b && b') + pure (property (not b) .&&. b') + +prop_IO_tryPutMVarNothing :: Invariant Int -> Int -> Fun Int Int -> Property +prop_IO_tryPutMVarNothing = ioProperty ..: + prop_M_tryPutMVarNothing +prop_IOSim_tryPutMVarNothing :: Invariant Int -> Int -> Fun Int Int -> Property -prop_modifyMVar_ :: +prop_IOSim_tryPutMVarNothing inv x f = runSimOrThrow $ + prop_M_tryPutMVarNothing inv x f + +-- +-- modifyMVar_ +-- + +prop_M_modifyMVar_ :: MonadMVar m => Invariant Int -> Int -> Fun Int Int - -> PropertyM m Bool -prop_modifyMVar_ inv x f = do - v <- run $ newMVarWithInvariant inv x - run $ modifyMVar_ v (pure . applyFun f) + -> m Property +prop_M_modifyMVar_ inv x f = do + v <- newMVarWithInvariant inv x + modifyMVar_ v (pure . applyFun f) isInWHNF v -prop_modifyMVar :: +prop_IO_modifyMVar_ :: Invariant Int -> Int -> Fun Int Int -> Property +prop_IO_modifyMVar_ = ioProperty ..: + prop_M_modifyMVar_ + +prop_IOSim_modifyMVar_ :: Invariant Int -> Int -> Fun Int Int -> Property +prop_IOSim_modifyMVar_ inv x f = runSimOrThrow $ + prop_M_modifyMVar_ inv x f + +-- +-- modifyMVar_ +-- + +prop_M_modifyMVar :: MonadMVar m => Invariant Int -> Int -> Fun Int (Int, Char) - -> PropertyM m Bool -prop_modifyMVar inv x f =do - v <- run $ newMVarWithInvariant inv x - void $ run $ modifyMVar v (pure . applyFun f) + -> m Property +prop_M_modifyMVar inv x f =do + v <- newMVarWithInvariant inv x + void $ modifyMVar v (pure . applyFun f) isInWHNF v -prop_modifyMVarMasked_ :: +prop_IO_modifyMVar :: Invariant Int -> Int -> Fun Int (Int, Char) -> Property +prop_IO_modifyMVar = ioProperty ..: + prop_M_modifyMVar + +prop_IOSim_modifyMVar :: Invariant Int -> Int -> Fun Int (Int, Char) -> Property +prop_IOSim_modifyMVar inv x f = runSimOrThrow $ + prop_M_modifyMVar inv x f + +-- +-- modifyMVarMasked_ +-- + +prop_M_modifyMVarMasked_ :: MonadMVar m => Invariant Int -> Int -> Fun Int Int - -> PropertyM m Bool -prop_modifyMVarMasked_ inv x f =do - v <- run $ newMVarWithInvariant inv x - void $ run $ modifyMVarMasked_ v (pure . applyFun f) + -> m Property +prop_M_modifyMVarMasked_ inv x f =do + v <- newMVarWithInvariant inv x + void $ modifyMVarMasked_ v (pure . applyFun f) isInWHNF v -prop_modifyMVarMasked :: +prop_IO_modifyMVarMasked_ :: Invariant Int -> Int -> Fun Int Int -> Property +prop_IO_modifyMVarMasked_ = ioProperty ..: + prop_M_modifyMVarMasked_ + +prop_IOSim_modifyMVarMasked_ :: Invariant Int -> Int -> Fun Int Int -> Property +prop_IOSim_modifyMVarMasked_ inv x f = runSimOrThrow $ + prop_M_modifyMVarMasked_ inv x f + +-- +-- modifyMVarMasked +-- + +prop_M_modifyMVarMasked :: MonadMVar m => Invariant Int -> Int -> Fun Int (Int, Char) - -> PropertyM m Bool -prop_modifyMVarMasked inv x f =do - v <- run $ newMVarWithInvariant inv x - void $ run $ modifyMVarMasked v (pure . applyFun f) + -> m Property +prop_M_modifyMVarMasked inv x f = do + v <-newMVarWithInvariant inv x + void $ modifyMVarMasked v (pure . applyFun f) isInWHNF v + +prop_IO_modifyMVarMasked :: Invariant Int -> Int -> Fun Int (Int, Char) -> Property +prop_IO_modifyMVarMasked = ioProperty ..: + prop_M_modifyMVarMasked + +prop_IOSim_modifyMVarMasked :: Invariant Int -> Int -> Fun Int (Int, Char) -> Property +prop_IOSim_modifyMVarMasked inv x f = runSimOrThrow $ + prop_M_modifyMVarMasked inv x f diff --git a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/WHNF.hs b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/WHNF.hs index b561a470a..83583a058 100644 --- a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/WHNF.hs +++ b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/WHNF.hs @@ -9,14 +9,14 @@ import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked hiding newTVarWithInvariantIO) import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked as Checked import Control.Monad (void) +import Control.Monad.IOSim (runSimOrThrow) import Data.Typeable (Typeable) -import NoThunks.Class (OnlyCheckWhnf (OnlyCheckWhnf), unsafeNoThunks) -import Test.QuickCheck.Monadic (PropertyM, monadicIO, monitor, run) +import NoThunks.Class (OnlyCheckWhnf (..), unsafeNoThunks) import Test.Tasty (TestTree, testGroup) -import Test.Tasty.QuickCheck (Fun, applyFun, counterexample, - testProperty) -import Test.Utils (Invariant (..), monadicSim, noInvariant, - trivialInvariant, whnfInvariant, (.:)) +import Test.Tasty.QuickCheck (Fun, Property, applyFun, counterexample, + ioProperty, property, testProperty) +import Test.Utils (Invariant (..), noInvariant, trivialInvariant, + whnfInvariant, (..:)) {------------------------------------------------------------------------------- Main test tree @@ -25,61 +25,58 @@ import Test.Utils (Invariant (..), monadicSim, noInvariant, tests :: TestTree tests = testGroup "Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.WHNF" [ testGroup "IO" [ - testIO "No invariant" sanityCheckWhnf noInvariant - , testIO "Trivial invariant" sanityCheckWhnf trivialInvariant - , testIO "WHNF invariant" sanityCheckWhnf whnfInvariant + testIO "No invariant" noInvariant + , testIO "Trivial invariant" trivialInvariant + , testIO "WHNF invariant" whnfInvariant ] - -- Sanity checks for WHNF fail in IOSim because IOSim runs in the lazy ST - -- monad, so we turn off sanity checks here. , testGroup "IOSim" [ - testIOSim "No invariant" noSanityCheckWhnf noInvariant - , testIOSim "Trivial invariant" noSanityCheckWhnf trivialInvariant - , testIOSim "WHNF invariant" noSanityCheckWhnf whnfInvariant + testIOSim "No invariant" noInvariant + , testIOSim "Trivial invariant" trivialInvariant + , testIOSim "WHNF invariant" whnfInvariant ] ] where - testIO name check inv = testGroup name [ - testProperty "prop_newTVarWithInvariant" $ - monadicIO .: prop_newTVarWithInvariant check inv - , testProperty "prop_newTVarWithInvariantIO" $ - monadicIO .: prop_newTVarWithInvariantIO check inv - , testProperty "prop_writeTVar" $ - monadicIO .: prop_writeTVar check inv - , testProperty "prop_modifyTVar" $ - monadicIO .: prop_modifyTVar check inv - , testProperty "prop_stateTVar" $ - monadicIO .: prop_stateTVar check inv - , testProperty "prop_swapTVar" $ - monadicIO .: prop_swapTVar check inv + testIO name inv = testGroup name [ + testProperty "prop_newTVarWithInvariant_IO" $ + prop_newTVarWithInvariant_IO inv + , testProperty "prop_newTVarWithInvariantIO_IO" $ + prop_newTVarWithInvariantIO_IO inv + , testProperty "prop_writeTVar_IO" $ + prop_writeTVar_IO inv + , testProperty "prop_modifyTVar_IO" $ + prop_modifyTVar_IO inv + , testProperty "prop_stateTVar_IO" $ + prop_stateTVar_IO inv + , testProperty "prop_swapTVar_IO" $ + prop_swapTVar_IO inv ] - testIOSim name check inv = testGroup name [ - testProperty "prop_newTVarWithInvariant" $ \x f -> - monadicSim $ prop_newTVarWithInvariant check inv x f - , testProperty "prop_newTVarWithInvariantIO" $ \x f -> - monadicSim $ prop_newTVarWithInvariantIO check inv x f - , testProperty "prop_writeTVar" $ \x f -> - monadicSim $ prop_writeTVar check inv x f - , testProperty "prop_modifyTVar" $ \x f -> - monadicSim $ prop_modifyTVar check inv x f - , testProperty "prop_stateTVar" $ \x f -> - monadicSim $ prop_stateTVar check inv x f - , testProperty "prop_swapTVar" $ \x f -> - monadicSim $ prop_swapTVar check inv x f + testIOSim name inv = testGroup name [ + testProperty "prop_newTVarWithInvariant_IOSim" $ + prop_newTVarWithInvariant_IOSim inv + , testProperty "prop_newTVarWithInvariantIO_IOSim" $ + prop_newTVarWithInvariantIO_IOSim inv + , testProperty "prop_writeTVar_IOSim" $ + prop_writeTVar_IOSim inv + , testProperty "prop_modifyTVar_IOSim" $ + prop_modifyTVar_IOSim inv + , testProperty "prop_stateTVar" $ + prop_stateTVar_IOSim inv + , testProperty "prop_swapTVar" $ + prop_swapTVar_IOSim inv ] {------------------------------------------------------------------------------- Utilities -------------------------------------------------------------------------------} - -isInWHNF :: (MonadSTM m, Typeable a) => StrictTVar m a -> PropertyM m Bool +isInWHNF :: (MonadSTM m, Typeable a) => StrictTVar m a -> m Property isInWHNF v = do - x <- run $ readTVarIO v - case unsafeNoThunks (OnlyCheckWhnf x) of - Nothing -> pure True - Just tinfo -> monitor (counterexample $ "Not in WHNF: " ++ show tinfo) - >> pure False + x <- readTVarIO v + pure $ case unsafeNoThunks (OnlyCheckWhnf x) of + Nothing -> property True + Just tinfo -> counterexample ("Not in WHNF: " ++ show tinfo) + $ property False -- | Wrapper around 'Checked.newTVar' and 'Checked.newTVarWithInvariant'. newTVarWithInvariant :: MonadSTM m => Invariant a -> a -> STM m (StrictTVar m a) @@ -93,100 +90,214 @@ newTVarWithInvariantIO = \case NoInvariant -> Checked.newTVarIO Invariant inv -> Checked.newTVarWithInvariantIO inv -newtype SanityCheckWhnf = SanityCheckWhnf { getSanityCheckWhnf :: Bool } - deriving (Show, Eq) - -noSanityCheckWhnf :: SanityCheckWhnf -noSanityCheckWhnf = SanityCheckWhnf False - -sanityCheckWhnf :: SanityCheckWhnf -sanityCheckWhnf = SanityCheckWhnf True - +-- | The 'isInWHNF' check fails when running tests in 'IOSim', since 'IOSim' +-- runs in the lazy 'ST' monad. 'withSanityCheckWhnf' can be used to perform the +-- test conditionally. withSanityCheckWhnf :: (MonadSTM m, Typeable a) - => SanityCheckWhnf + => Bool -> StrictTVar m a - -> PropertyM m Bool + -> m Property withSanityCheckWhnf check v = - if getSanityCheckWhnf check then + if check then isInWHNF v else - pure True + pure $ property True {------------------------------------------------------------------------------- Properties -------------------------------------------------------------------------------} +-- +-- newTVarWithInvariant +-- + -- | Test 'newTVarWithInvariant', not to be confused with -- 'Checked.newTVarWithInvariant'. -prop_newTVarWithInvariant :: +prop_newTVarWithInvariant_M :: MonadSTM m - => SanityCheckWhnf + => Bool -> Invariant Int -> Int -> Fun Int Int - -> PropertyM m Bool -prop_newTVarWithInvariant check inv x f = do - v <- run $ atomically $ newTVarWithInvariant inv (applyFun f x) + -> m Property +prop_newTVarWithInvariant_M check inv x f = do + v <- atomically $ newTVarWithInvariant inv (applyFun f x) withSanityCheckWhnf check v +prop_newTVarWithInvariant_IO :: + Invariant Int + -> Int + -> Fun Int Int + -> Property +prop_newTVarWithInvariant_IO = ioProperty ..: + prop_newTVarWithInvariant_M True + +prop_newTVarWithInvariant_IOSim :: + Invariant Int + -> Int + -> Fun Int Int + -> Property +prop_newTVarWithInvariant_IOSim inv x f = runSimOrThrow $ + prop_newTVarWithInvariant_M False inv x f + +-- +-- newTVarWithInvariantIO +-- + -- | Test 'newTVarWithInvariantIO', not to be confused with -- 'Checked.newTVarWithInvariantIO'. -prop_newTVarWithInvariantIO :: +prop_newTVarWithInvariantIO_M :: MonadSTM m - => SanityCheckWhnf + => Bool -> Invariant Int -> Int -> Fun Int Int - -> PropertyM m Bool -prop_newTVarWithInvariantIO check inv x f = do - v <- run $ newTVarWithInvariantIO inv (applyFun f x) + -> m Property +prop_newTVarWithInvariantIO_M check inv x f = do + v <- newTVarWithInvariantIO inv (applyFun f x) withSanityCheckWhnf check v -prop_writeTVar :: +prop_newTVarWithInvariantIO_IO :: + Invariant Int + -> Int + -> Fun Int Int + -> Property +prop_newTVarWithInvariantIO_IO = ioProperty ..: + prop_newTVarWithInvariantIO_M True + +prop_newTVarWithInvariantIO_IOSim :: + Invariant Int + -> Int + -> Fun Int Int + -> Property +prop_newTVarWithInvariantIO_IOSim inv x f = runSimOrThrow $ + prop_newTVarWithInvariantIO_M False inv x f + +-- +-- writeTVar +-- + +prop_writeTVar_M :: MonadSTM m - => SanityCheckWhnf + => Bool -> Invariant Int -> Int -> Fun Int Int - -> PropertyM m Bool -prop_writeTVar check inv x f = do - v <- run $ newTVarWithInvariantIO inv x - run $ atomically $ writeTVar v (applyFun f x) + -> m Property +prop_writeTVar_M check inv x f = do + v <- newTVarWithInvariantIO inv x + atomically $ writeTVar v (applyFun f x) withSanityCheckWhnf check v -prop_modifyTVar :: +prop_writeTVar_IO :: + Invariant Int + -> Int + -> Fun Int Int + -> Property +prop_writeTVar_IO = ioProperty ..: + prop_writeTVar_M True + +prop_writeTVar_IOSim :: + Invariant Int + -> Int + -> Fun Int Int + -> Property +prop_writeTVar_IOSim inv x f = runSimOrThrow $ + prop_writeTVar_M False inv x f + +-- +-- modifyTVar +-- + +prop_modifyTVar_M :: MonadSTM m - => SanityCheckWhnf + => Bool -> Invariant Int -> Int -> Fun Int Int - -> PropertyM m Bool -prop_modifyTVar check inv x f = do - v <- run $ newTVarWithInvariantIO inv x - run $ atomically $ modifyTVar v (applyFun f) + -> m Property +prop_modifyTVar_M check inv x f = do + v <- newTVarWithInvariantIO inv x + atomically $ modifyTVar v (applyFun f) withSanityCheckWhnf check v -prop_stateTVar :: +prop_modifyTVar_IO :: + Invariant Int + -> Int + -> Fun Int Int + -> Property +prop_modifyTVar_IO = ioProperty ..: + prop_modifyTVar_M True + +prop_modifyTVar_IOSim :: + Invariant Int + -> Int + -> Fun Int Int + -> Property +prop_modifyTVar_IOSim inv x f = runSimOrThrow $ + prop_modifyTVar_M False inv x f + +-- +-- stateTVar +-- + +prop_stateTVar_M :: MonadSTM m - => SanityCheckWhnf + => Bool -> Invariant Int -> Int -> Fun Int Int - -> PropertyM m Bool -prop_stateTVar check inv x f = do - v <- run $ newTVarWithInvariantIO inv x - run $ atomically $ stateTVar v (((),) . applyFun f) + -> m Property +prop_stateTVar_M check inv x f = do + v <- newTVarWithInvariantIO inv x + atomically $ stateTVar v (((),) . applyFun f) withSanityCheckWhnf check v -prop_swapTVar :: +prop_stateTVar_IO :: + Invariant Int + -> Int + -> Fun Int Int + -> Property +prop_stateTVar_IO = ioProperty ..: + prop_stateTVar_M True + +prop_stateTVar_IOSim :: + Invariant Int + -> Int + -> Fun Int Int + -> Property +prop_stateTVar_IOSim inv x f = runSimOrThrow $ + prop_stateTVar_M False inv x f + +-- +-- swapTVar +-- + +prop_swapTVar_M :: MonadSTM m - => SanityCheckWhnf + => Bool -> Invariant Int -> Int -> Fun Int Int - -> PropertyM m Bool -prop_swapTVar check inv x f = do - v <- run $ newTVarWithInvariantIO inv x - void $ run $ atomically $ swapTVar v (applyFun f x) + -> m Property +prop_swapTVar_M check inv x f = do + v <- newTVarWithInvariantIO inv x + void $ atomically $ swapTVar v (applyFun f x) withSanityCheckWhnf check v + +prop_swapTVar_IO :: + Invariant Int + -> Int + -> Fun Int Int + -> Property +prop_swapTVar_IO = ioProperty ..: + prop_swapTVar_M True + +prop_swapTVar_IOSim :: + Invariant Int + -> Int + -> Fun Int Int + -> Property +prop_swapTVar_IOSim inv x f = runSimOrThrow $ + prop_swapTVar_M False inv x f diff --git a/strict-checked-vars/test/Test/Utils.hs b/strict-checked-vars/test/Test/Utils.hs index 2788b6b8c..7f31b285c 100644 --- a/strict-checked-vars/test/Test/Utils.hs +++ b/strict-checked-vars/test/Test/Utils.hs @@ -5,7 +5,7 @@ module Test.Utils ( monadicSim , runSimGen -- * Function composition - , (.:) + , (..:) -- * Invariants , Invariant (..) , noInvariant @@ -36,10 +36,10 @@ monadicSim m = property (runSimGen (monadic' m)) Function composition -------------------------------------------------------------------------------} -infixr 9 .: +infixr 9 ..: -(.:) :: (y -> z) -> (x0 -> x1 -> y) -> (x0 -> x1 -> z) -(.:) g f x0 x1 = g (f x0 x1) +(..:) :: (y -> z) -> (x0 -> x1 -> x2 -> y) -> (x0 -> x1 -> x2 -> z) +(..:) g f x0 x1 x2 = g (f x0 x1 x2) {------------------------------------------------------------------------------- Invariants From f73e7ef1d6d18e1df114f77f8a8cd3c532984b22 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Wed, 23 Aug 2023 18:12:46 +0200 Subject: [PATCH 34/75] Resolve PR comments: provide `Arbitrary` instance for `Invariant`. --- cabal.project | 8 -- .../Class/MonadMVar/Strict/Checked/WHNF.hs | 101 ++++++++---------- .../MonadSTM/Strict/TVar/Checked/WHNF.hs | 75 ++++++------- strict-checked-vars/test/Test/Utils.hs | 20 +++- 4 files changed, 95 insertions(+), 109 deletions(-) diff --git a/cabal.project b/cabal.project index fa99ce943..c678bee29 100644 --- a/cabal.project +++ b/cabal.project @@ -37,11 +37,3 @@ benchmarks: true program-options ghc-options: -Werror - -if impl(ghc >= 9.6) - allow-newer: - , *:base - , protolude:ghc-prim - , protolude:binary - , protolude:bytestring - , protolude:text diff --git a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked/WHNF.hs b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked/WHNF.hs index d59665b15..9abe5c4ed 100644 --- a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked/WHNF.hs +++ b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked/WHNF.hs @@ -13,8 +13,7 @@ import NoThunks.Class (OnlyCheckWhnf (..), unsafeNoThunks) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (Fun, Property, applyFun, counterexample, ioProperty, property, testProperty, (.&&.)) -import Test.Utils (Invariant (..), noInvariant, trivialInvariant, - whnfInvariant, (..:)) +import Test.Utils (Invariant (..), (..:)) {------------------------------------------------------------------------------- Main test tree @@ -22,58 +21,50 @@ import Test.Utils (Invariant (..), noInvariant, trivialInvariant, tests :: TestTree tests = testGroup "WHNF" [ - testGroup "IO" [ - testIO "No invariant" noInvariant - , testIO "Trivial invariant" trivialInvariant - , testIO "WHNF invariant" whnfInvariant - ] - , testGroup "IOSim" [ - testIOSim "No invariant" noInvariant - , testIOSim "Trivial invariant" trivialInvariant - , testIOSim "WHNF invariant" whnfInvariant - ] + testGroup "IO" testIO + , testGroup "IOSim" testIOSim ] where - testIO name inv = testGroup name [ - testProperty "prop_IO_newMVarWithInvariant" $ - prop_IO_newMVarWithInvariant inv - , testProperty "prop_IO_putMVar" $ - prop_IO_putMVar inv - , testProperty "prop_IO_swapMVar" $ - prop_IO_swapMVar inv - , testProperty "prop_IO_tryPutMVarJust" $ - prop_IO_tryPutMVarJust inv - , testProperty "prop_IO_tryPutMVarNothing" $ - prop_IO_tryPutMVarNothing inv - , testProperty "prop_IO_modifyMVar_" $ - prop_IO_modifyMVar_ inv - , testProperty "prop_IO_modifyMVar" $ - prop_IO_modifyMVar inv - , testProperty "prop_IO_modifyMVarMasked_" $ - prop_IO_modifyMVarMasked_ inv - , testProperty "prop_IO_modifyMVarMasked" $ - prop_IO_modifyMVarMasked inv + testIO = [ + testProperty "prop_IO_newMVarWithInvariant" + prop_IO_newMVarWithInvariant + , testProperty "prop_IO_putMVar" + prop_IO_putMVar + , testProperty "prop_IO_swapMVar" + prop_IO_swapMVar + , testProperty "prop_IO_tryPutMVarJust" + prop_IO_tryPutMVarJust + , testProperty "prop_IO_tryPutMVarNothing" + prop_IO_tryPutMVarNothing + , testProperty "prop_IO_modifyMVar_" + prop_IO_modifyMVar_ + , testProperty "prop_IO_modifyMVar" + prop_IO_modifyMVar + , testProperty "prop_IO_modifyMVarMasked_" + prop_IO_modifyMVarMasked_ + , testProperty "prop_IO_modifyMVarMasked" + prop_IO_modifyMVarMasked ] - testIOSim name inv = testGroup name [ - testProperty "prop_IOSim_newMVarWithInvariant" $ - prop_IOSim_newMVarWithInvariant inv - , testProperty "prop_IOSim_putMVar" $ - prop_IOSim_putMVar inv - , testProperty "prop_IOSim_swapMVar" $ - prop_IOSim_swapMVar inv - , testProperty "prop_IOSim_tryPutMVarJust" $ - prop_IOSim_tryPutMVarJust inv - , testProperty "prop_IOSim_tryPutMVarNothing" $ - prop_IOSim_tryPutMVarNothing inv - , testProperty "prop_IOSim_modifyMVar_" $ - prop_IOSim_modifyMVar_ inv - , testProperty "prop_IOSim_modifyMVar" $ - prop_IOSim_modifyMVar inv - , testProperty "prop_IOSim_modifyMVarMasked_" $ - prop_IOSim_modifyMVarMasked_ inv - , testProperty "prop_IOSim_modifyMVarMasked" $ - prop_IOSim_modifyMVarMasked inv + testIOSim = [ + testProperty "prop_IOSim_newMVarWithInvariant" + prop_IOSim_newMVarWithInvariant + , testProperty "prop_IOSim_putMVar" + prop_IOSim_putMVar + , testProperty "prop_IOSim_swapMVar" + prop_IOSim_swapMVar + , testProperty "prop_IOSim_tryPutMVarJust" + prop_IOSim_tryPutMVarJust + , testProperty "prop_IOSim_tryPutMVarNothing" + prop_IOSim_tryPutMVarNothing + , testProperty "prop_IOSim_modifyMVar_" + prop_IOSim_modifyMVar_ + , testProperty "prop_IOSim_modifyMVar" + prop_IOSim_modifyMVar + , testProperty "prop_IOSim_modifyMVarMasked_" + prop_IOSim_modifyMVarMasked_ + , testProperty "prop_IOSim_modifyMVarMasked" + prop_IOSim_modifyMVarMasked ] {------------------------------------------------------------------------------- @@ -91,15 +82,15 @@ isInWHNF v = do -- | Wrapper around 'Checked.newMVar' and 'Checked.newMVarWithInvariant'. newMVarWithInvariant :: MonadMVar m => Invariant a -> a -> m (StrictMVar m a) newMVarWithInvariant = \case - NoInvariant -> Checked.newMVar - Invariant inv -> Checked.newMVarWithInvariant inv + NoInvariant -> Checked.newMVar + Invariant _ inv -> Checked.newMVarWithInvariant inv -- | Wrapper around 'Checked.newEmptyMVar' and -- 'Checked.newEmptyMVarWithInvariant'. newEmptyMVarWithInvariant :: MonadMVar m => Invariant a -> m (StrictMVar m a) newEmptyMVarWithInvariant = \case - NoInvariant -> Checked.newEmptyMVar - Invariant inv -> Checked.newEmptyMVarWithInvariant inv + NoInvariant -> Checked.newEmptyMVar + Invariant _ inv -> Checked.newEmptyMVarWithInvariant inv {------------------------------------------------------------------------------- Properties @@ -152,7 +143,6 @@ prop_IOSim_putMVar :: Invariant Int -> Int -> Fun Int Int -> Property prop_IOSim_putMVar inv x f = runSimOrThrow $ prop_M_putMVar inv x f - -- -- swapMVar -- @@ -175,6 +165,7 @@ prop_IO_swapMVar = ioProperty ..: prop_IOSim_swapMVar :: Invariant Int -> Int -> Fun Int Int -> Property prop_IOSim_swapMVar inv x f = runSimOrThrow $ prop_M_swapMVar inv x f + -- -- tryPutMVar -- diff --git a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/WHNF.hs b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/WHNF.hs index 83583a058..ccc19d720 100644 --- a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/WHNF.hs +++ b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/WHNF.hs @@ -15,8 +15,7 @@ import NoThunks.Class (OnlyCheckWhnf (..), unsafeNoThunks) import Test.Tasty (TestTree, testGroup) import Test.Tasty.QuickCheck (Fun, Property, applyFun, counterexample, ioProperty, property, testProperty) -import Test.Utils (Invariant (..), noInvariant, trivialInvariant, - whnfInvariant, (..:)) +import Test.Utils (Invariant (..), (..:)) {------------------------------------------------------------------------------- Main test tree @@ -24,46 +23,38 @@ import Test.Utils (Invariant (..), noInvariant, trivialInvariant, tests :: TestTree tests = testGroup "Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.WHNF" [ - testGroup "IO" [ - testIO "No invariant" noInvariant - , testIO "Trivial invariant" trivialInvariant - , testIO "WHNF invariant" whnfInvariant - ] - , testGroup "IOSim" [ - testIOSim "No invariant" noInvariant - , testIOSim "Trivial invariant" trivialInvariant - , testIOSim "WHNF invariant" whnfInvariant - ] + testGroup "IO" testIO + , testGroup "IOSim" testIOSim ] where - testIO name inv = testGroup name [ - testProperty "prop_newTVarWithInvariant_IO" $ - prop_newTVarWithInvariant_IO inv - , testProperty "prop_newTVarWithInvariantIO_IO" $ - prop_newTVarWithInvariantIO_IO inv - , testProperty "prop_writeTVar_IO" $ - prop_writeTVar_IO inv - , testProperty "prop_modifyTVar_IO" $ - prop_modifyTVar_IO inv - , testProperty "prop_stateTVar_IO" $ - prop_stateTVar_IO inv - , testProperty "prop_swapTVar_IO" $ - prop_swapTVar_IO inv + testIO = [ + testProperty "prop_newTVarWithInvariant_IO" + prop_newTVarWithInvariant_IO + , testProperty "prop_newTVarWithInvariantIO_IO" + prop_newTVarWithInvariantIO_IO + , testProperty "prop_writeTVar_IO" + prop_writeTVar_IO + , testProperty "prop_modifyTVar_IO" + prop_modifyTVar_IO + , testProperty "prop_stateTVar_IO" + prop_stateTVar_IO + , testProperty "prop_swapTVar_IO" + prop_swapTVar_IO ] - testIOSim name inv = testGroup name [ - testProperty "prop_newTVarWithInvariant_IOSim" $ - prop_newTVarWithInvariant_IOSim inv - , testProperty "prop_newTVarWithInvariantIO_IOSim" $ - prop_newTVarWithInvariantIO_IOSim inv - , testProperty "prop_writeTVar_IOSim" $ - prop_writeTVar_IOSim inv - , testProperty "prop_modifyTVar_IOSim" $ - prop_modifyTVar_IOSim inv - , testProperty "prop_stateTVar" $ - prop_stateTVar_IOSim inv - , testProperty "prop_swapTVar" $ - prop_swapTVar_IOSim inv + testIOSim = [ + testProperty "prop_newTVarWithInvariant_IOSim" + prop_newTVarWithInvariant_IOSim + , testProperty "prop_newTVarWithInvariantIO_IOSim" + prop_newTVarWithInvariantIO_IOSim + , testProperty "prop_writeTVar_IOSim" + prop_writeTVar_IOSim + , testProperty "prop_modifyTVar_IOSim" + prop_modifyTVar_IOSim + , testProperty "prop_stateTVar" + prop_stateTVar_IOSim + , testProperty "prop_swapTVar" + prop_swapTVar_IOSim ] {------------------------------------------------------------------------------- @@ -81,14 +72,14 @@ isInWHNF v = do -- | Wrapper around 'Checked.newTVar' and 'Checked.newTVarWithInvariant'. newTVarWithInvariant :: MonadSTM m => Invariant a -> a -> STM m (StrictTVar m a) newTVarWithInvariant = \case - NoInvariant -> Checked.newTVar - Invariant inv -> Checked.newTVarWithInvariant inv + NoInvariant -> Checked.newTVar + Invariant _ inv -> Checked.newTVarWithInvariant inv -- | Wrapper around 'Checked.newTVarIO' and 'Checked.newTVarWithInvariantIO'. newTVarWithInvariantIO :: MonadSTM m => Invariant a -> a -> m (StrictTVar m a) newTVarWithInvariantIO = \case - NoInvariant -> Checked.newTVarIO - Invariant inv -> Checked.newTVarWithInvariantIO inv + NoInvariant -> Checked.newTVarIO + Invariant _ inv -> Checked.newTVarWithInvariantIO inv -- | The 'isInWHNF' check fails when running tests in 'IOSim', since 'IOSim' -- runs in the lazy 'ST' monad. 'withSanityCheckWhnf' can be used to perform the diff --git a/strict-checked-vars/test/Test/Utils.hs b/strict-checked-vars/test/Test/Utils.hs index 7f31b285c..d40c481a0 100644 --- a/strict-checked-vars/test/Test/Utils.hs +++ b/strict-checked-vars/test/Test/Utils.hs @@ -16,7 +16,8 @@ module Test.Utils ( import Control.Monad.IOSim (IOSim, runSimOrThrow) import Data.Typeable (Typeable) import NoThunks.Class (OnlyCheckWhnf (..), unsafeNoThunks) -import Test.QuickCheck (Gen, Property, Testable (..)) +import Test.QuickCheck (Arbitrary (..), Gen, Property, Testable (..), + elements) import Test.QuickCheck.Gen.Unsafe (Capture (..), capture) import Test.QuickCheck.Monadic (PropertyM, monadic') @@ -51,13 +52,24 @@ infixr 9 ..: -- with 'NoInvariant'. data Invariant a = NoInvariant - | Invariant (a -> Maybe String) + | Invariant String (a -> Maybe String) + +instance Show (Invariant a) where + show NoInvariant = "NoInvariant" + show (Invariant name _) = "Invariant " <> name + +instance Typeable a => Arbitrary (Invariant a) where + arbitrary = elements [ + noInvariant + , whnfInvariant + , trivialInvariant + ] noInvariant :: Invariant a noInvariant = NoInvariant whnfInvariant :: Typeable a => Invariant a -whnfInvariant = Invariant $ fmap show . unsafeNoThunks . OnlyCheckWhnf +whnfInvariant = Invariant "WHNF" $ fmap show . unsafeNoThunks . OnlyCheckWhnf trivialInvariant :: Invariant a -trivialInvariant = Invariant $ const Nothing +trivialInvariant = Invariant "Trivial" $ const Nothing From 23d5462362bc39dc7ed572591ab673094678bc28 Mon Sep 17 00:00:00 2001 From: Yvan Sraka Date: Wed, 30 Aug 2023 12:37:43 +0200 Subject: [PATCH 35/75] Fix #241: Create `devcontainer.json` to enable GitHub CodeSpaces (#422) * Fix #241: Create `devcontainer.json` to enable GitHub CodeSpaces --- .devcontainer/devcontainer.json | 13 +++++++++++++ 1 file changed, 13 insertions(+) create mode 100644 .devcontainer/devcontainer.json diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json new file mode 100644 index 000000000..89fdf0805 --- /dev/null +++ b/.devcontainer/devcontainer.json @@ -0,0 +1,13 @@ +{ + "image":"ghcr.io/input-output-hk/devx-devcontainer:ghc962-iog", + "customizations":{ + "vscode":{ + "extensions":[ + "haskell.haskell" + ], + "settings":{ + "haskell.manageHLS":"PATH" + } + } + } +} From b379b130d9f8d1ef4c1bbbbbf43fe48586ec3a1f Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Thu, 31 Aug 2023 15:16:35 +0200 Subject: [PATCH 36/75] Propagate HasCallStack constraints in the `Switch` module for checked strict MVars. --- strict-checked-vars/CHANGELOG.md | 9 ++ .../Class/MonadMVar/Strict/Checked/Switch.hs | 86 +++++++++++++++---- strict-checked-vars/strict-checked-vars.cabal | 2 +- 3 files changed, 79 insertions(+), 18 deletions(-) diff --git a/strict-checked-vars/CHANGELOG.md b/strict-checked-vars/CHANGELOG.md index e028fe4c1..a013dd5cc 100644 --- a/strict-checked-vars/CHANGELOG.md +++ b/strict-checked-vars/CHANGELOG.md @@ -1,5 +1,14 @@ # Revision history of strict-checked-vars +## 0.1.0.4 + +* Propagate HasCallStack constraints in the `Switch` module for checked strict + MVars. + +## 0.1.0.3 + +* Make `writeTVar` more strict. + ## 0.1.0.2 * Make `newTVarWithInvariant`, `newTVarWithInvariantIO` and `newMVarWithInvariant` strict. diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs index 867f3e02a..69a8abd90 100644 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs @@ -32,36 +32,88 @@ module Control.Concurrent.Class.MonadMVar.Strict.Checked.Switch ( ) where #if CHECK_MVAR_INVARIANTS +import Control.Concurrent.Class.MonadMVar.Strict.Checked hiding + (checkInvariant, + modifyMVar, + modifyMVarMasked, + modifyMVarMasked_, + modifyMVar_, + newEmptyMVarWithInvariant, + newMVarWithInvariant, + putMVar, + swapMVar, + tryPutMVar) import qualified Control.Concurrent.Class.MonadMVar.Strict.Checked as StrictMVar.Checked -import Control.Concurrent.Class.MonadMVar.Strict.Checked hiding (checkInvariant, newMVarWithInvariant, newEmptyMVarWithInvariant) #else -import qualified Control.Concurrent.Class.MonadMVar.Strict as StrictMVar -import Control.Concurrent.Class.MonadMVar.Strict +import Control.Concurrent.Class.MonadMVar.Strict hiding + (modifyMVar, + modifyMVarMasked, + modifyMVarMasked_, + modifyMVar_, + putMVar, + swapMVar, + tryPutMVar) +import qualified Control.Concurrent.Class.MonadMVar.Strict as StrictMVar #endif -import GHC.Stack (HasCallStack) +import GHC.Stack (HasCallStack) newEmptyMVarWithInvariant :: MonadMVar m => (a -> Maybe String) -> m (StrictMVar m a) -#if CHECK_MVAR_INVARIANTS -newEmptyMVarWithInvariant = StrictMVar.Checked.newEmptyMVarWithInvariant -#else -newEmptyMVarWithInvariant _ = StrictMVar.newEmptyMVar -#endif newMVarWithInvariant :: (HasCallStack, MonadMVar m) => (a -> Maybe String) -> a -> m (StrictMVar m a) -#if CHECK_MVAR_INVARIANTS -newMVarWithInvariant = StrictMVar.Checked.newMVarWithInvariant -#else -newMVarWithInvariant _ = StrictMVar.newMVar -#endif + +putMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m () + +swapMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m a + +tryPutMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m Bool + +modifyMVar_ :: (HasCallStack, MonadMVar m) + => StrictMVar m a + -> (a -> m a) + -> m () + +modifyMVar :: (HasCallStack, MonadMVar m) + => StrictMVar m a + -> (a -> m (a,b)) + -> m b + +modifyMVarMasked_ :: (HasCallStack, MonadMVar m) + => StrictMVar m a + -> (a -> m a) + -> m () + +modifyMVarMasked :: (HasCallStack, MonadMVar m) + => StrictMVar m a + -> (a -> m (a,b)) + -> m b checkInvariant :: HasCallStack => Maybe String -> a -> a + #if CHECK_MVAR_INVARIANTS -checkInvariant = StrictMVar.Checked.checkInvariant +newEmptyMVarWithInvariant = StrictMVar.Checked.newEmptyMVarWithInvariant +newMVarWithInvariant = StrictMVar.Checked.newMVarWithInvariant +putMVar = StrictMVar.Checked.putMVar +swapMVar = StrictMVar.Checked.swapMVar +tryPutMVar = StrictMVar.Checked.tryPutMVar +modifyMVar_ = StrictMVar.Checked.modifyMVar_ +modifyMVar = StrictMVar.Checked.modifyMVar +modifyMVarMasked_ = StrictMVar.Checked.modifyMVarMasked_ +modifyMVarMasked = StrictMVar.Checked.modifyMVarMasked +checkInvariant = StrictMVar.Checked.checkInvariant #else -checkInvariant = \_ a -> a -#endif \ No newline at end of file +newEmptyMVarWithInvariant _ = StrictMVar.newEmptyMVar +newMVarWithInvariant _ = StrictMVar.newMVar +putMVar = StrictMVar.putMVar +swapMVar = StrictMVar.swapMVar +tryPutMVar = StrictMVar.tryPutMVar +modifyMVar_ = StrictMVar.modifyMVar_ +modifyMVar = StrictMVar.modifyMVar +modifyMVarMasked_ = StrictMVar.modifyMVarMasked_ +modifyMVarMasked = StrictMVar.modifyMVarMasked +checkInvariant = \_ a -> a +#endif diff --git a/strict-checked-vars/strict-checked-vars.cabal b/strict-checked-vars/strict-checked-vars.cabal index c3ee536dd..c45408e4b 100644 --- a/strict-checked-vars/strict-checked-vars.cabal +++ b/strict-checked-vars/strict-checked-vars.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: strict-checked-vars -version: 0.1.0.3 +version: 0.1.0.4 synopsis: Strict MVars and TVars with invariant checking for IO and IOSim From 28c44431b3070c07510499fc561f06b07ab6f83c Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Thu, 5 Oct 2023 09:46:09 +1100 Subject: [PATCH 37/75] Make it build with ghc-9.8 --- cabal.project | 27 +++++++++++++++++-- cardano-binary/cardano-binary.cabal | 2 +- cardano-binary/test/cardano-binary-test.cabal | 2 +- .../cardano-crypto-class.cabal | 2 +- .../src/Cardano/Crypto/KES/Mock.hs | 2 +- .../src/Cardano/Crypto/PinnedSizedBytes.hs | 7 +++-- .../cardano-crypto-praos.cabal | 2 +- .../cardano-crypto-tests.cabal | 4 +-- cardano-slotting/cardano-slotting.cabal | 2 +- strict-checked-vars/strict-checked-vars.cabal | 4 +-- 10 files changed, 40 insertions(+), 14 deletions(-) diff --git a/cabal.project b/cabal.project index c678bee29..c23617ad7 100644 --- a/cabal.project +++ b/cabal.project @@ -10,9 +10,9 @@ repository cardano-haskell-packages d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee -- The hackage index-state -index-state: 2023-07-31T10:10:32Z +index-state: 2023-10-05T21:19:55Z -- The CHaP index-state -index-state: cardano-haskell-packages 2023-08-08T14:32:15Z +index-state: cardano-haskell-packages 2023-10-05T20:34:14Z packages: base-deriving-via @@ -37,3 +37,26 @@ benchmarks: true program-options ghc-options: -Werror + +if impl(ghc >= 9.8) + allow-newer: + , *:base + , *:deepseq + , *:ghc-prim + , *:template-haskell + , aeson:th-abstraction + + constraints: + , aeson >= 2.0.0.0 + , bytestring >= 0.11 + , hastache >= 0.6.1 + , monad-par >= 0.3.5 + , statistics >= 0.16.2.0 + , th-abstraction >= 0.6.0.0 + + -- Git head compiles with `ghc-9.8`, but Hackage version does not. + source-repository-package + type: git + location: https://github.com/recursion-schemes/recursion-schemes + tag: cc2e88c3400a6548e975830c9addb12ab087545f + --sha256: 06shyihy6cpblv3pf18xgdfjgxqw2y2awvpcy33r76fr642gdvgn diff --git a/cardano-binary/cardano-binary.cabal b/cardano-binary/cardano-binary.cabal index 940910f6e..959cc093f 100644 --- a/cardano-binary/cardano-binary.cabal +++ b/cardano-binary/cardano-binary.cabal @@ -16,7 +16,7 @@ build-type: Simple extra-source-files: README.md CHANGELOG.md -common base { build-depends: base >= 4.14 && < 4.19 } +common base { build-depends: base >= 4.14 && < 5 } common project-config default-language: Haskell2010 diff --git a/cardano-binary/test/cardano-binary-test.cabal b/cardano-binary/test/cardano-binary-test.cabal index 240b88e88..7bf67858f 100644 --- a/cardano-binary/test/cardano-binary-test.cabal +++ b/cardano-binary/test/cardano-binary-test.cabal @@ -13,7 +13,7 @@ category: Currency build-type: Simple extra-source-files: CHANGELOG.md -common base { build-depends: base >= 4.14 && < 4.19 } +common base { build-depends: base >= 4.14 && < 5 } common project-config default-language: Haskell2010 diff --git a/cardano-crypto-class/cardano-crypto-class.cabal b/cardano-crypto-class/cardano-crypto-class.cabal index 79870ac34..76f88de60 100644 --- a/cardano-crypto-class/cardano-crypto-class.cabal +++ b/cardano-crypto-class/cardano-crypto-class.cabal @@ -26,7 +26,7 @@ flag secp256k1-support default: True manual: True -common base { build-depends: base >= 4.14 && < 4.19 } +common base { build-depends: base >= 4.14 && < 5 } common project-config default-language: Haskell2010 diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs index ed0d7480d..ae9b1b82c 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs @@ -64,7 +64,7 @@ instance KnownNat t => KESAlgorithm (MockKES t) where data SigKES (MockKES t) = SigMockKES !(Hash ShortHash ()) !(SignKeyKES (MockKES t)) - deriving stock (Show, Eq, Ord, Generic) + deriving stock (Show, Eq, Generic) deriving anyclass (NoThunks) -- diff --git a/cardano-crypto-class/src/Cardano/Crypto/PinnedSizedBytes.hs b/cardano-crypto-class/src/Cardano/Crypto/PinnedSizedBytes.hs index 283b70f55..1eaabe2cd 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/PinnedSizedBytes.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/PinnedSizedBytes.hs @@ -385,9 +385,12 @@ ptrPsbToSizedPtr = SizedPtr . castPtr -- then this throws an exception. pinnedByteArrayFromListN :: forall a. Prim.Prim a => Int -> [a] -> ByteArray pinnedByteArrayFromListN 0 _ = - die "pinnedByteArrayFromListN" "list length zero" + die "pinnedByteArrayFromListN" "list length zero #1" pinnedByteArrayFromListN n ys = runST $ do - marr <- newPinnedByteArray (n * Prim.sizeOf (head ys)) + let headYs = case ys of + [] -> die "pinnedByteArrayFromListN" "list length zero #2" + (y:_) -> y + marr <- newPinnedByteArray (n * Prim.sizeOf headYs) let go !ix [] = if ix == n then return () else die "pinnedByteArrayFromListN" "list length less than specified size" diff --git a/cardano-crypto-praos/cardano-crypto-praos.cabal b/cardano-crypto-praos/cardano-crypto-praos.cabal index 2b1f53e04..40342bbc8 100644 --- a/cardano-crypto-praos/cardano-crypto-praos.cabal +++ b/cardano-crypto-praos/cardano-crypto-praos.cabal @@ -44,7 +44,7 @@ flag external-libsodium-vrf default: True manual: True -common base { build-depends: base >= 4.14 && < 4.19 } +common base { build-depends: base >= 4.14 && < 5 } common project-config default-language: Haskell2010 diff --git a/cardano-crypto-tests/cardano-crypto-tests.cabal b/cardano-crypto-tests/cardano-crypto-tests.cabal index ad8acf63d..4d044eb82 100644 --- a/cardano-crypto-tests/cardano-crypto-tests.cabal +++ b/cardano-crypto-tests/cardano-crypto-tests.cabal @@ -27,7 +27,7 @@ flag secp256k1-support default: True manual: True -common base { build-depends: base >= 4.14 && < 4.19 } +common base { build-depends: base >= 4.14 && < 5 } common project-config default-language: Haskell2010 @@ -66,7 +66,7 @@ library build-depends: base , bytestring >=0.10.12.0 , cardano-binary - , cardano-crypto-class >= 2.2 + , cardano-crypto-class >= 2.1 , cardano-crypto-praos , cborg , containers diff --git a/cardano-slotting/cardano-slotting.cabal b/cardano-slotting/cardano-slotting.cabal index 75c9070ea..e48157734 100644 --- a/cardano-slotting/cardano-slotting.cabal +++ b/cardano-slotting/cardano-slotting.cabal @@ -13,7 +13,7 @@ copyright: IOHK build-type: Simple extra-source-files: CHANGELOG.md -common base { build-depends: base >= 4.14 && < 4.19 } +common base { build-depends: base >= 4.14 && < 5 } common project-config default-language: Haskell2010 diff --git a/strict-checked-vars/strict-checked-vars.cabal b/strict-checked-vars/strict-checked-vars.cabal index c45408e4b..8648d80e0 100644 --- a/strict-checked-vars/strict-checked-vars.cabal +++ b/strict-checked-vars/strict-checked-vars.cabal @@ -51,7 +51,7 @@ library default-language: Haskell2010 build-depends: - , base >=4.9 && <4.19 + , base >=4.9 && <5 , io-classes ^>=1.2 , strict-mvar ^>=1.2 , strict-stm ^>=1.2 @@ -79,7 +79,7 @@ test-suite test default-language: Haskell2010 build-depends: - , base >=4.9 && <4.19 + , base , io-classes , io-sim , nothunks From e088124fd13c07d03b08b1116f2c07886353a057 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Fri, 6 Oct 2023 11:52:30 +1100 Subject: [PATCH 38/75] Nix updates --- flake.lock | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/flake.lock b/flake.lock index 075692c34..8ef042851 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1690795016, - "narHash": "sha256-UOIamXYb+xLDrTYs41BaaCun2C3P/cscH4jQ+/1R3w0=", + "lastModified": 1696538731, + "narHash": "sha256-oTsPiABmN7mw9hctagxzNcIDtvmyK4EuBzvMD2iXeeQ=", "owner": "input-output-hk", "repo": "cardano-haskell-packages", - "rev": "75cb0539932adc80f03ebcdfbca9dcf6166015b1", + "rev": "4276a203ed968d067b6c31c943b5bae5fc2ec4a2", "type": "github" }, "original": { @@ -486,11 +486,11 @@ "sodium": "sodium" }, "locked": { - "lastModified": 1684223806, - "narHash": "sha256-IyLoP+zhuyygLtr83XXsrvKyqqLQ8FHXTiySFf4FJOI=", + "lastModified": 1696471795, + "narHash": "sha256-aNNvjUtCGXaXSp5M/HSj1SOeLjqLyTRWYbIHqAEeUp0=", "owner": "input-output-hk", "repo": "iohk-nix", - "rev": "86421fdd89b3af43fa716ccd07638f96c6ecd1e4", + "rev": "91f16fa8acb58b312f94977715c630d8bf77e33e", "type": "github" }, "original": { From ad0bf6cf56033a31f51a9937713e09e2c0378a67 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Thu, 12 Oct 2023 09:55:58 +1100 Subject: [PATCH 39/75] CI: Add ghc-9.8.1 to the build matrix --- .github/workflows/haskell.yml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index dd4f303f9..109706ec1 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -34,7 +34,7 @@ jobs: strategy: fail-fast: false matrix: - ghc: ["8.10.7", "9.2.7", "9.6.2"] + ghc: ["8.10.7", "9.2.7", "9.6.2", "9.8.1"] os: [ubuntu-latest, macos-latest, windows-latest] env: From 5f7cffd6231993c907f1f7325dd6a67d7f5c53d1 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Thu, 11 May 2023 09:29:53 +0200 Subject: [PATCH 40/75] Merge DSIGN classes and KES classes --- .../cardano-crypto-class.cabal | 2 - .../src/Cardano/Crypto/DSIGN.hs | 2 - .../src/Cardano/Crypto/DSIGN/Class.hs | 150 ++++++- .../src/Cardano/Crypto/DSIGN/Ed25519.hs | 197 ++++++++- .../src/Cardano/Crypto/DSIGNM/Class.hs | 387 ------------------ .../src/Cardano/Crypto/KES/Class.hs | 53 ++- .../src/Cardano/Crypto/KES/CompactSingle.hs | 83 ++-- .../src/Cardano/Crypto/KES/CompactSum.hs | 35 +- .../src/Cardano/Crypto/KES/Mock.hs | 14 +- .../src/Cardano/Crypto/KES/NeverUsed.hs | 9 +- .../src/Cardano/Crypto/KES/Simple.hs | 111 +++-- .../src/Cardano/Crypto/KES/Single.hs | 70 ++-- .../src/Cardano/Crypto/KES/Sum.hs | 31 +- cardano-crypto-tests/src/Bench/Crypto/KES.hs | 12 +- cardano-crypto-tests/src/Test/Crypto/DSIGN.hs | 130 +++--- cardano-crypto-tests/src/Test/Crypto/EqST.hs | 8 +- cardano-crypto-tests/src/Test/Crypto/KES.hs | 66 +-- 17 files changed, 612 insertions(+), 748 deletions(-) delete mode 100644 cardano-crypto-class/src/Cardano/Crypto/DSIGNM/Class.hs diff --git a/cardano-crypto-class/cardano-crypto-class.cabal b/cardano-crypto-class/cardano-crypto-class.cabal index 76f88de60..048b420a5 100644 --- a/cardano-crypto-class/cardano-crypto-class.cabal +++ b/cardano-crypto-class/cardano-crypto-class.cabal @@ -42,9 +42,7 @@ library Cardano.Crypto.DSIGN Cardano.Crypto.DSIGN.Class Cardano.Crypto.DSIGN.Ed25519 - Cardano.Crypto.DSIGN.Ed25519ML Cardano.Crypto.DSIGN.Ed448 - Cardano.Crypto.DSIGNM.Class Cardano.Crypto.DSIGN.Mock Cardano.Crypto.DSIGN.NeverUsed Cardano.Crypto.EllipticCurve.BLS12_381 diff --git a/cardano-crypto-class/src/Cardano/Crypto/DSIGN.hs b/cardano-crypto-class/src/Cardano/Crypto/DSIGN.hs index b3dca9a69..f82880315 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/DSIGN.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/DSIGN.hs @@ -6,9 +6,7 @@ module Cardano.Crypto.DSIGN where import Cardano.Crypto.DSIGN.Class as X -import Cardano.Crypto.DSIGNM.Class as X import Cardano.Crypto.DSIGN.Ed25519 as X -import Cardano.Crypto.DSIGN.Ed25519ML as X import Cardano.Crypto.DSIGN.Ed448 as X import Cardano.Crypto.DSIGN.Mock as X import Cardano.Crypto.DSIGN.NeverUsed as X diff --git a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Class.hs b/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Class.hs index 796ff6b06..76e656747 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Class.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Class.hs @@ -3,6 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE StandaloneDeriving #-} @@ -21,6 +22,14 @@ module Cardano.Crypto.DSIGN.Class , sizeSignKeyDSIGN , sizeSigDSIGN + -- * MLocked DSIGN algorithm class + , DSIGNMAlgorithm (..) + + , genKeyDSIGNM + , cloneKeyDSIGNM + , getSeedDSIGNM + , forgetSignKeyDSIGNM + -- * 'SignedDSIGN' wrapper , SignedDSIGN (..) , signedDSIGN @@ -43,12 +52,20 @@ module Cardano.Crypto.DSIGN.Class -- * Helper , failSizeCheck + + -- * Unsound CBOR encoding and decoding of MLocked DSIGN keys + , UnsoundDSIGNMAlgorithm (..) + , encodeSignKeyDSIGNM + , decodeSignKeyDSIGNM + , rawDeserialiseSignKeyDSIGNM ) where import Control.DeepSeq (NFData) -import qualified Data.ByteString as BS +import Control.Monad.Class.MonadST (MonadST) +import Control.Monad.Class.MonadThrow (MonadThrow) import Data.ByteString (ByteString) +import qualified Data.ByteString as BS import Data.Kind (Type) import Data.Proxy (Proxy(..)) import Data.Typeable (Typeable) @@ -60,12 +77,16 @@ import NoThunks.Class (NoThunks) import Cardano.Binary (Decoder, decodeBytes, Encoding, encodeBytes, Size, withWordSize) -import Cardano.Crypto.Util (Empty) -import Cardano.Crypto.Seed import Cardano.Crypto.Hash.Class (HashAlgorithm, Hash, hashWith) +import Cardano.Crypto.Libsodium (MLockedAllocator, mlockedMalloc) +import Cardano.Crypto.Libsodium.MLockedSeed +import Cardano.Crypto.Seed +import Cardano.Crypto.Util (Empty) +-- | The pure DSIGN API, which supports the full set of DSIGN operations, but +-- does not allow for secure forgetting of private keys. class ( Typeable v , Show (VerKeyDSIGN v) , Eq (VerKeyDSIGN v) @@ -307,3 +328,126 @@ encodedSigDSIGNSizeExpr _proxy = fromIntegral ((withWordSize :: Word -> Integer) (sizeSigDSIGN (Proxy :: Proxy v))) -- payload + fromIntegral (sizeSigDSIGN (Proxy :: Proxy v)) + +class (DSIGNAlgorithm v, NoThunks (SignKeyDSIGNM v)) => DSIGNMAlgorithm v where + + data SignKeyDSIGNM v :: Type + + deriveVerKeyDSIGNM :: (MonadThrow m, MonadST m) => SignKeyDSIGNM v -> m (VerKeyDSIGN v) + + -- + -- Core algorithm operations + -- + + signDSIGNM + :: (Signable v a, MonadST m, MonadThrow m) + => ContextDSIGN v + -> a + -> SignKeyDSIGNM v + -> m (SigDSIGN v) + + -- + -- Key generation + -- + + genKeyDSIGNMWith :: (MonadST m, MonadThrow m) + => MLockedAllocator m + -> MLockedSeed (SeedSizeDSIGN v) + -> m (SignKeyDSIGNM v) + + cloneKeyDSIGNMWith :: MonadST m => MLockedAllocator m -> SignKeyDSIGNM v -> m (SignKeyDSIGNM v) + + getSeedDSIGNMWith :: (MonadST m, MonadThrow m) + => MLockedAllocator m + -> Proxy v + -> SignKeyDSIGNM v + -> m (MLockedSeed (SeedSizeDSIGN v)) + + -- + -- Secure forgetting + -- + + forgetSignKeyDSIGNMWith :: (MonadST m, MonadThrow m) => MLockedAllocator m -> SignKeyDSIGNM v -> m () + + +forgetSignKeyDSIGNM :: (DSIGNMAlgorithm v, MonadST m, MonadThrow m) => SignKeyDSIGNM v -> m () +forgetSignKeyDSIGNM = forgetSignKeyDSIGNMWith mlockedMalloc + + +genKeyDSIGNM :: + (DSIGNMAlgorithm v, MonadST m, MonadThrow m) + => MLockedSeed (SeedSizeDSIGN v) + -> m (SignKeyDSIGNM v) +genKeyDSIGNM = genKeyDSIGNMWith mlockedMalloc + +cloneKeyDSIGNM :: + (DSIGNMAlgorithm v, MonadST m) => SignKeyDSIGNM v -> m (SignKeyDSIGNM v) +cloneKeyDSIGNM = cloneKeyDSIGNMWith mlockedMalloc + +getSeedDSIGNM :: + (DSIGNMAlgorithm v, MonadST m, MonadThrow m) + => Proxy v + -> SignKeyDSIGNM v + -> m (MLockedSeed (SeedSizeDSIGN v)) +getSeedDSIGNM = getSeedDSIGNMWith mlockedMalloc + + +-- | Unsound operations on DSIGNM sign keys. These operations violate secure +-- forgetting constraints by leaking secrets to unprotected memory. Consider +-- using the 'DirectSerialise' / 'DirectDeserialise' APIs instead. +class DSIGNMAlgorithm v => UnsoundDSIGNMAlgorithm v where + -- + -- Serialisation/(de)serialisation in fixed-size raw format + -- + + rawSerialiseSignKeyDSIGNM :: + (MonadST m, MonadThrow m) => SignKeyDSIGNM v -> m ByteString + + rawDeserialiseSignKeyDSIGNMWith :: + (MonadST m, MonadThrow m) => MLockedAllocator m -> ByteString -> m (Maybe (SignKeyDSIGNM v)) + +rawDeserialiseSignKeyDSIGNM :: + (UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m) + => ByteString + -> m (Maybe (SignKeyDSIGNM v)) +rawDeserialiseSignKeyDSIGNM = + rawDeserialiseSignKeyDSIGNMWith mlockedMalloc + + +-- +-- Do not provide Ord instances for keys, see #38 +-- + +instance ( TypeError ('Text "Ord not supported for signing keys, use the hash instead") + , Eq (SignKeyDSIGNM v) + ) + => Ord (SignKeyDSIGNM v) where + compare = error "unsupported" + +-- +-- Convenient CBOR encoding/decoding +-- +-- Implementations in terms of the raw (de)serialise +-- + +encodeSignKeyDSIGNM :: + (UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m) + => SignKeyDSIGNM v + -> m Encoding +encodeSignKeyDSIGNM = fmap encodeBytes . rawSerialiseSignKeyDSIGNM + +decodeSignKeyDSIGNM :: forall m v s + . (UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m) + => Decoder s (m (SignKeyDSIGNM v)) +decodeSignKeyDSIGNM = do + bs <- decodeBytes + return $ rawDeserialiseSignKeyDSIGNM bs >>= \case + Just vk -> return vk + Nothing + | actual /= expected + -> error ("decodeSignKeyDSIGNM: wrong length, expected " ++ + show expected ++ " bytes but got " ++ show actual) + | otherwise -> error "decodeSignKeyDSIGNM: cannot decode key" + where + expected = fromIntegral (sizeSignKeyDSIGN (Proxy :: Proxy v)) + actual = BS.length bs diff --git a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519.hs b/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519.hs index 6140ec5c5..f80079276 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519.hs @@ -3,9 +3,13 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE RankNTypes #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE TypeApplications #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE UndecidableInstances #-} + -- According to the documentation for unsafePerformIO: -- -- > Make sure that the either you switch off let-floating @@ -23,30 +27,54 @@ module Cardano.Crypto.DSIGN.Ed25519 ( Ed25519DSIGN , SigDSIGN (..) , SignKeyDSIGN (..) + , SignKeyDSIGNM (..) , VerKeyDSIGN (..) ) where -import Control.DeepSeq (NFData) +import Control.DeepSeq (NFData (..), rwhnf) +import Control.Monad ((<$!>), unless, guard) +import Control.Monad.Class.MonadST (MonadST (..)) +import Control.Monad.Class.MonadThrow (MonadThrow (..), throwIO) +import Control.Monad.ST (ST, stToIO) +import Control.Monad.ST.Unsafe (unsafeIOToST) +import qualified Data.ByteString as BS +import Data.Proxy +import Foreign.C.Error (errnoToIOError, getErrno, Errno) +import Foreign.Ptr (castPtr, nullPtr) import GHC.Generics (Generic) +import GHC.IO.Exception (ioException) +import GHC.TypeLits (TypeError, ErrorMessage (..)) import NoThunks.Class (NoThunks) import System.IO.Unsafe (unsafeDupablePerformIO) -import GHC.IO.Exception (ioException) -import Control.Monad (unless, guard) -import Foreign.C.Error (errnoToIOError, getErrno) -import Foreign.Ptr (castPtr, nullPtr) -import qualified Data.ByteString as BS -import Cardano.Binary (FromCBOR (..), ToCBOR (..)) -import Cardano.Foreign -import Cardano.Crypto.PinnedSizedBytes -import Cardano.Crypto.Libsodium.C +import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Cardano.Crypto.DSIGN.Class +import Cardano.Crypto.Libsodium + ( MLockedSizedBytes + , mlsbToByteString + , mlsbFromByteStringCheckWith + , mlsbUseAsSizedPtr + , mlsbNewWith + , mlsbFinalize + , mlsbCopyWith + ) +import Cardano.Crypto.Libsodium.C +import Cardano.Crypto.Libsodium.MLockedSeed +import Cardano.Crypto.PinnedSizedBytes + ( PinnedSizedBytes + , psbUseAsSizedPtr + , psbToByteString + , psbFromByteStringCheck + , psbCreateSized + , psbCreateSizedResult + ) import Cardano.Crypto.Seed import Cardano.Crypto.Util (SignableRepresentation(..)) -import Data.Proxy +import Cardano.Foreign + data Ed25519DSIGN @@ -55,18 +83,47 @@ instance NoThunks (VerKeyDSIGN Ed25519DSIGN) instance NoThunks (SignKeyDSIGN Ed25519DSIGN) instance NoThunks (SigDSIGN Ed25519DSIGN) +deriving via (MLockedSizedBytes (SizeSignKeyDSIGN Ed25519DSIGN)) + instance NoThunks (SignKeyDSIGNM Ed25519DSIGN) + +instance NFData (SignKeyDSIGNM Ed25519DSIGN) where + rnf = rwhnf + -- | Convert C-style return code / errno error reporting into Haskell -- exceptions. -- -- Runs an IO action (which should be some FFI call into C) that returns a -- result code; if the result code returned is nonzero, fetch the errno, and -- throw a suitable IO exception. -cOrError :: String -> String -> IO Int -> IO () -cOrError contextDesc cFunName action = do +cOrThrowError :: String -> String -> IO Int -> IO () +cOrThrowError contextDesc cFunName action = do res <- action unless (res == 0) $ do errno <- getErrno ioException $ errnoToIOError (contextDesc ++ ": " ++ cFunName) errno Nothing Nothing +-- +-- | Convert C-style return code / errno error reporting into Haskell +-- exceptions. +-- +-- Runs an IO action (which should be some FFI call into C) that returns a +-- result code; if the result code returned is nonzero, fetch the errno, and +-- return it. +cOrError :: MonadST m => (forall s. ST s Int) -> m (Maybe Errno) +cOrError action = do + withLiftST $ \fromST -> fromST $ do + res <- action + if res == 0 then + return Nothing + else + Just <$> unsafeIOToST getErrno + +-- | Throws an error when 'Just' an 'Errno' is given. +throwOnErrno :: MonadThrow m => String -> String -> Maybe Errno -> m () +throwOnErrno contextDesc cFunName maybeErrno = do + case maybeErrno of + Just errno -> throwIO $ errnoToIOError (contextDesc ++ ": " ++ cFunName) errno Nothing Nothing + Nothing -> return () + instance DSIGNAlgorithm Ed25519DSIGN where -- | Seed size is 32 octets, the same as sign key size, because generating @@ -121,7 +178,7 @@ instance DSIGNAlgorithm Ed25519DSIGN where unsafeDupablePerformIO $ psbUseAsSizedPtr sk $ \skPtr -> psbCreateSized $ \pkPtr -> - cOrError "deriveVerKeyDSIGN @Ed25519DSIGN" "c_crypto_sign_ed25519_sk_to_pk" + cOrThrowError "deriveVerKeyDSIGN @Ed25519DSIGN" "c_crypto_sign_ed25519_sk_to_pk" $ c_crypto_sign_ed25519_sk_to_pk pkPtr skPtr -- @@ -136,10 +193,10 @@ instance DSIGNAlgorithm Ed25519DSIGN where BS.useAsCStringLen bs $ \(ptr, len) -> psbUseAsSizedPtr sk $ \skPtr -> allocaSized $ \pkPtr -> do - cOrError "signDSIGN @Ed25519DSIGN" "c_crypto_sign_ed25519_sk_to_pk" + cOrThrowError "signDSIGN @Ed25519DSIGN" "c_crypto_sign_ed25519_sk_to_pk" $ c_crypto_sign_ed25519_sk_to_pk pkPtr skPtr psbCreateSized $ \sigPtr -> do - cOrError "signDSIGN @Ed25519DSIGN" "c_crypto_sign_ed25519_detached" + cOrThrowError "signDSIGN @Ed25519DSIGN" "c_crypto_sign_ed25519_detached" $ c_crypto_sign_ed25519_detached sigPtr nullPtr (castPtr ptr) (fromIntegral len) skPtr verifyDSIGN () (VerKeyEd25519DSIGN vk) a (SigEd25519DSIGN sig) = @@ -164,7 +221,7 @@ instance DSIGNAlgorithm Ed25519DSIGN where psbCreateSized $ \skPtr -> BS.useAsCStringLen sb $ \(seedPtr, _) -> allocaSized $ \pkPtr -> do - cOrError "genKeyDSIGN @Ed25519DSIGN" "c_crypto_sign_ed25519_seed_keypair" + cOrThrowError "genKeyDSIGN @Ed25519DSIGN" "c_crypto_sign_ed25519_seed_keypair" $ c_crypto_sign_ed25519_seed_keypair pkPtr skPtr (SizedPtr . castPtr $ seedPtr) -- -- raw serialise/deserialise @@ -175,7 +232,7 @@ instance DSIGNAlgorithm Ed25519DSIGN where psbToByteString @(SeedSizeDSIGN Ed25519DSIGN) $ unsafeDupablePerformIO $ do psbCreateSized $ \seedPtr -> psbUseAsSizedPtr sk $ \skPtr -> - cOrError "deriveVerKeyDSIGN @Ed25519DSIGN" "c_crypto_sign_ed25519_sk_to_seed" + cOrThrowError "deriveVerKeyDSIGN @Ed25519DSIGN" "c_crypto_sign_ed25519_sk_to_seed" $ c_crypto_sign_ed25519_sk_to_seed seedPtr skPtr rawSerialiseSigDSIGN (SigEd25519DSIGN sig) = psbToByteString sig @@ -188,6 +245,98 @@ instance DSIGNAlgorithm Ed25519DSIGN where rawDeserialiseSigDSIGN = fmap SigEd25519DSIGN . psbFromByteStringCheck {-# INLINE rawDeserialiseSigDSIGN #-} +instance DSIGNMAlgorithm Ed25519DSIGN where + -- Note that the size of the internal key data structure is the SECRET KEY + -- bytes as per libsodium, while the declared key size (for serialization) + -- is libsodium's SEED bytes. We expand 32-octet keys to 64-octet ones + -- during deserialization, and we delete the 32 octets that contain the + -- public key from the secret key before serializing. + newtype SignKeyDSIGNM Ed25519DSIGN = SignKeyEd25519DSIGNM (MLockedSizedBytes CRYPTO_SIGN_ED25519_SECRETKEYBYTES) + deriving (Show) + + deriveVerKeyDSIGNM (SignKeyEd25519DSIGNM sk) = + VerKeyEd25519DSIGN <$!> do + mlsbUseAsSizedPtr sk $ \skPtr -> do + (psb, maybeErrno) <- + psbCreateSizedResult $ \pkPtr -> + withLiftST $ \fromST -> fromST $ do + cOrError $ unsafeIOToST $ + c_crypto_sign_ed25519_sk_to_pk pkPtr skPtr + throwOnErrno "deriveVerKeyDSIGNM @Ed25519DSIGN" "c_crypto_sign_ed25519_sk_to_pk" maybeErrno + return psb + + + signDSIGNM () a (SignKeyEd25519DSIGNM sk) = + let bs = getSignableRepresentation a + in SigEd25519DSIGN <$!> do + mlsbUseAsSizedPtr sk $ \skPtr -> do + (psb, maybeErrno) <- + psbCreateSizedResult $ \sigPtr -> do + withLiftST $ \fromST -> fromST $ do + cOrError $ unsafeIOToST $ do + BS.useAsCStringLen bs $ \(ptr, len) -> + c_crypto_sign_ed25519_detached sigPtr nullPtr (castPtr ptr) (fromIntegral len) skPtr + throwOnErrno "signDSIGNM @Ed25519DSIGN" "c_crypto_sign_ed25519_detached" maybeErrno + return psb + + -- + -- Key generation + -- + {-# NOINLINE genKeyDSIGNMWith #-} + genKeyDSIGNMWith allocator seed = SignKeyEd25519DSIGNM <$!> do + sk <- mlsbNewWith allocator + mlsbUseAsSizedPtr sk $ \skPtr -> + mlockedSeedUseAsCPtr seed $ \seedPtr -> do + maybeErrno <- withLiftST $ \fromST -> + fromST $ allocaSizedST $ \pkPtr -> do + cOrError $ unsafeIOToST $ + c_crypto_sign_ed25519_seed_keypair pkPtr skPtr (SizedPtr . castPtr $ seedPtr) + throwOnErrno "genKeyDSIGNM @Ed25519DSIGN" "c_crypto_sign_ed25519_seed_keypair" maybeErrno + return sk + where + allocaSizedST k = + unsafeIOToST $ allocaSized $ \ptr -> stToIO $ k ptr + + cloneKeyDSIGNMWith allocator (SignKeyEd25519DSIGNM sk) = + SignKeyEd25519DSIGNM <$!> mlsbCopyWith allocator sk + + getSeedDSIGNMWith allocator _ (SignKeyEd25519DSIGNM sk) = do + seed <- mlockedSeedNewWith allocator + mlsbUseAsSizedPtr sk $ \skPtr -> + mlockedSeedUseAsSizedPtr seed $ \seedPtr -> do + maybeErrno <- withLiftST $ \fromST -> + fromST $ + cOrError $ unsafeIOToST $ + c_crypto_sign_ed25519_sk_to_seed seedPtr skPtr + throwOnErrno "genKeyDSIGNM @Ed25519DSIGN" "c_crypto_sign_ed25519_seed_keypair" maybeErrno + return seed + + -- + -- Secure forgetting + -- + forgetSignKeyDSIGNMWith _ (SignKeyEd25519DSIGNM sk) = mlsbFinalize sk + +instance UnsoundDSIGNMAlgorithm Ed25519DSIGN where + -- + -- Ser/deser (dangerous - do not use in production code) + -- + rawSerialiseSignKeyDSIGNM sk = do + seed <- getSeedDSIGNM (Proxy @Ed25519DSIGN) sk + -- We need to copy the seed into unsafe memory and finalize the MLSB, in + -- order to avoid leaking mlocked memory. This will, however, expose the + -- secret seed to the unprotected Haskell heap (see 'mlsbToByteString'). + raw <- mlsbToByteString . mlockedSeedMLSB $ seed + mlockedSeedFinalize seed + return raw + + rawDeserialiseSignKeyDSIGNMWith allocator raw = do + mseed <- fmap MLockedSeed <$> mlsbFromByteStringCheckWith allocator raw + case mseed of + Nothing -> return Nothing + Just seed -> do + sk <- Just <$> genKeyDSIGNMWith allocator seed + mlockedSeedFinalize seed + return sk instance ToCBOR (VerKeyDSIGN Ed25519DSIGN) where toCBOR = encodeVerKeyDSIGN @@ -209,3 +358,13 @@ instance ToCBOR (SigDSIGN Ed25519DSIGN) where instance FromCBOR (SigDSIGN Ed25519DSIGN) where fromCBOR = decodeSigDSIGN + + +instance TypeError ('Text "CBOR encoding would violate mlocking guarantees") + => ToCBOR (SignKeyDSIGNM Ed25519DSIGN) where + toCBOR = error "unsupported" + encodedSizeExpr _ = error "unsupported" + +instance TypeError ('Text "CBOR decoding would violate mlocking guarantees") + => FromCBOR (SignKeyDSIGNM Ed25519DSIGN) where + fromCBOR = error "unsupported" diff --git a/cardano-crypto-class/src/Cardano/Crypto/DSIGNM/Class.hs b/cardano-crypto-class/src/Cardano/Crypto/DSIGNM/Class.hs deleted file mode 100644 index 68c1fe580..000000000 --- a/cardano-crypto-class/src/Cardano/Crypto/DSIGNM/Class.hs +++ /dev/null @@ -1,387 +0,0 @@ -{-# LANGUAGE DataKinds #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TypeApplications #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE UndecidableInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE RankNTypes #-} - --- | Abstract digital signatures. -module Cardano.Crypto.DSIGNM.Class - ( - -- * DSIGNMM algorithm class - DSIGNMAlgorithmBase (..) - , DSIGNMAlgorithm (..) - , MLockedSeed - , seedSizeDSIGNM - , sizeVerKeyDSIGNM - , sizeSignKeyDSIGNM - , sizeSigDSIGNM - , genKeyDSIGNM - , cloneKeyDSIGNM - , getSeedDSIGNM - , forgetSignKeyDSIGNM - - -- * 'SignedDSIGNM' wrapper - , SignedDSIGNM (..) - , signedDSIGNM - , verifySignedDSIGNM - - -- * CBOR encoding and decoding - , encodeVerKeyDSIGNM - , decodeVerKeyDSIGNM - , encodeSigDSIGNM - , decodeSigDSIGNM - , encodeSignedDSIGNM - , decodeSignedDSIGNM - - -- * Encoded 'Size' expresssions - , encodedVerKeyDSIGNMSizeExpr - , encodedSignKeyDSIGNMSizeExpr - , encodedSigDSIGNMSizeExpr - - -- * Unsound API - , UnsoundDSIGNMAlgorithm (..) - , encodeSignKeyDSIGNM - , decodeSignKeyDSIGNM - , rawDeserialiseSignKeyDSIGNM - ) -where - -import qualified Data.ByteString as BS -import Data.ByteString (ByteString) -import Data.Kind (Type) -import Data.Proxy (Proxy(..)) -import Data.Typeable (Typeable) -import GHC.Exts (Constraint) -import GHC.Generics (Generic) -import GHC.Stack (HasCallStack) -import GHC.TypeLits (KnownNat, Nat, natVal, TypeError, ErrorMessage (..)) -import NoThunks.Class (NoThunks) -import Control.Monad.Class.MonadST (MonadST) -import Control.Monad.Class.MonadThrow (MonadThrow) - -import Cardano.Binary (Decoder, decodeBytes, Encoding, encodeBytes, Size, withWordSize) - -import Cardano.Crypto.Util (Empty) -import Cardano.Crypto.Libsodium.MLockedSeed -import Cardano.Crypto.Libsodium (MLockedAllocator, mlockedMalloc) -import Cardano.Crypto.Hash.Class (HashAlgorithm, Hash, hashWith) - -class ( Typeable v - , Show (VerKeyDSIGNM v) - , Eq (VerKeyDSIGNM v) - , Show (SignKeyDSIGNM v) - , Show (SigDSIGNM v) - , Eq (SigDSIGNM v) - , NoThunks (SigDSIGNM v) - , NoThunks (SignKeyDSIGNM v) - , NoThunks (VerKeyDSIGNM v) - , KnownNat (SeedSizeDSIGNM v) - , KnownNat (SizeVerKeyDSIGNM v) - , KnownNat (SizeSignKeyDSIGNM v) - , KnownNat (SizeSigDSIGNM v) - ) - => DSIGNMAlgorithmBase v where - - type SeedSizeDSIGNM v :: Nat - type SizeVerKeyDSIGNM v :: Nat - type SizeSignKeyDSIGNM v :: Nat - type SizeSigDSIGNM v :: Nat - - -- - -- Key and signature types - -- - - data VerKeyDSIGNM v :: Type - data SignKeyDSIGNM v :: Type - data SigDSIGNM v :: Type - - -- - -- Metadata and basic key operations - -- - - algorithmNameDSIGNM :: proxy v -> String - - hashVerKeyDSIGNM :: HashAlgorithm h => VerKeyDSIGNM v -> Hash h (VerKeyDSIGNM v) - hashVerKeyDSIGNM = hashWith rawSerialiseVerKeyDSIGNM - - -- - -- Core algorithm operations - -- - - -- | Context required to run the DSIGNM algorithm - -- - -- Unit by default (no context required) - type ContextDSIGNM v :: Type - type ContextDSIGNM v = () - - type SignableM v :: Type -> Constraint - type SignableM v = Empty - - verifyDSIGNM - :: (SignableM v a, HasCallStack) - => ContextDSIGNM v - -> VerKeyDSIGNM v - -> a - -> SigDSIGNM v - -> Either String () - - -- - -- Serialisation/(de)serialisation in fixed-size raw format - -- - - rawSerialiseVerKeyDSIGNM :: VerKeyDSIGNM v -> ByteString - rawSerialiseSigDSIGNM :: SigDSIGNM v -> ByteString - - rawDeserialiseVerKeyDSIGNM :: ByteString -> Maybe (VerKeyDSIGNM v) - rawDeserialiseSigDSIGNM :: ByteString -> Maybe (SigDSIGNM v) - -class DSIGNMAlgorithmBase v => DSIGNMAlgorithm v where - - -- - -- Metadata and basic key operations - -- - - deriveVerKeyDSIGNM :: (MonadThrow m, MonadST m) => SignKeyDSIGNM v -> m (VerKeyDSIGNM v) - - -- - -- Core algorithm operations - -- - - signDSIGNM - :: (SignableM v a, MonadST m, MonadThrow m) - => ContextDSIGNM v - -> a - -> SignKeyDSIGNM v - -> m (SigDSIGNM v) - - -- - -- Key generation - -- - - genKeyDSIGNMWith :: (MonadST m, MonadThrow m) - => MLockedAllocator m - -> MLockedSeed (SeedSizeDSIGNM v) - -> m (SignKeyDSIGNM v) - - cloneKeyDSIGNMWith :: MonadST m => MLockedAllocator m -> SignKeyDSIGNM v -> m (SignKeyDSIGNM v) - - getSeedDSIGNMWith :: (MonadST m, MonadThrow m) - => MLockedAllocator m - -> Proxy v - -> SignKeyDSIGNM v - -> m (MLockedSeed (SeedSizeDSIGNM v)) - - -- - -- Secure forgetting - -- - - forgetSignKeyDSIGNMWith :: (MonadST m, MonadThrow m) => MLockedAllocator m -> SignKeyDSIGNM v -> m () - - -forgetSignKeyDSIGNM :: (DSIGNMAlgorithm v, MonadST m, MonadThrow m) => SignKeyDSIGNM v -> m () -forgetSignKeyDSIGNM = forgetSignKeyDSIGNMWith mlockedMalloc - - -genKeyDSIGNM :: - (DSIGNMAlgorithm v, MonadST m, MonadThrow m) - => MLockedSeed (SeedSizeDSIGNM v) - -> m (SignKeyDSIGNM v) -genKeyDSIGNM = genKeyDSIGNMWith mlockedMalloc - -cloneKeyDSIGNM :: - (DSIGNMAlgorithm v, MonadST m) => SignKeyDSIGNM v -> m (SignKeyDSIGNM v) -cloneKeyDSIGNM = cloneKeyDSIGNMWith mlockedMalloc - -getSeedDSIGNM :: - (DSIGNMAlgorithm v, MonadST m, MonadThrow m) - => Proxy v - -> SignKeyDSIGNM v - -> m (MLockedSeed (SeedSizeDSIGNM v)) -getSeedDSIGNM = getSeedDSIGNMWith mlockedMalloc - - --- | Unsound operations on DSIGNM sign keys. These operations violate secure --- forgetting constraints by leaking secrets to unprotected memory. Consider --- using the 'DirectSerialise' / 'DirectDeserialise' APIs instead. -class DSIGNMAlgorithm v => UnsoundDSIGNMAlgorithm v where - -- - -- Serialisation/(de)serialisation in fixed-size raw format - -- - - rawSerialiseSignKeyDSIGNM :: - (MonadST m, MonadThrow m) => SignKeyDSIGNM v -> m ByteString - - rawDeserialiseSignKeyDSIGNMWith :: - (MonadST m, MonadThrow m) => MLockedAllocator m -> ByteString -> m (Maybe (SignKeyDSIGNM v)) - -rawDeserialiseSignKeyDSIGNM :: - (UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m) - => ByteString - -> m (Maybe (SignKeyDSIGNM v)) -rawDeserialiseSignKeyDSIGNM = - rawDeserialiseSignKeyDSIGNMWith mlockedMalloc - - --- --- Do not provide Ord instances for keys, see #38 --- - -instance ( TypeError ('Text "Ord not supported for signing keys, use the hash instead") - , Eq (SignKeyDSIGNM v) - ) - => Ord (SignKeyDSIGNM v) where - compare = error "unsupported" - -instance ( TypeError ('Text "Ord not supported for verification keys, use the hash instead") - , Eq (VerKeyDSIGNM v) - ) - => Ord (VerKeyDSIGNM v) where - compare = error "unsupported" - --- | The upper bound on the seed size needed by 'genKeyDSIGNM' -seedSizeDSIGNM :: forall v proxy. DSIGNMAlgorithmBase v => proxy v -> Word -seedSizeDSIGNM _ = fromInteger (natVal (Proxy @(SeedSizeDSIGNM v))) - -sizeVerKeyDSIGNM :: forall v proxy. DSIGNMAlgorithmBase v => proxy v -> Word -sizeVerKeyDSIGNM _ = fromInteger (natVal (Proxy @(SizeVerKeyDSIGNM v))) -sizeSignKeyDSIGNM :: forall v proxy. DSIGNMAlgorithmBase v => proxy v -> Word -sizeSignKeyDSIGNM _ = fromInteger (natVal (Proxy @(SizeSignKeyDSIGNM v))) -sizeSigDSIGNM :: forall v proxy. DSIGNMAlgorithmBase v => proxy v -> Word -sizeSigDSIGNM _ = fromInteger (natVal (Proxy @(SizeSigDSIGNM v))) - --- --- Convenient CBOR encoding/decoding --- --- Implementations in terms of the raw (de)serialise --- - -encodeVerKeyDSIGNM :: DSIGNMAlgorithmBase v => VerKeyDSIGNM v -> Encoding -encodeVerKeyDSIGNM = encodeBytes . rawSerialiseVerKeyDSIGNM - -encodeSignKeyDSIGNM :: - (UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m) - => SignKeyDSIGNM v - -> m Encoding -encodeSignKeyDSIGNM = fmap encodeBytes . rawSerialiseSignKeyDSIGNM - -encodeSigDSIGNM :: DSIGNMAlgorithmBase v => SigDSIGNM v -> Encoding -encodeSigDSIGNM = encodeBytes . rawSerialiseSigDSIGNM - -decodeVerKeyDSIGNM :: forall v s. DSIGNMAlgorithmBase v => Decoder s (VerKeyDSIGNM v) -decodeVerKeyDSIGNM = do - bs <- decodeBytes - case rawDeserialiseVerKeyDSIGNM bs of - Just vk -> return vk - Nothing - | actual /= expected - -> fail ("decodeVerKeyDSIGNM: wrong length, expected " ++ - show expected ++ " bytes but got " ++ show actual) - | otherwise -> fail "decodeVerKeyDSIGNM: cannot decode key" - where - expected = fromIntegral (sizeVerKeyDSIGNM (Proxy :: Proxy v)) - actual = BS.length bs - -decodeSignKeyDSIGNM :: forall m v s - . (UnsoundDSIGNMAlgorithm v, MonadST m, MonadThrow m) - => Decoder s (m (SignKeyDSIGNM v)) -decodeSignKeyDSIGNM = do - bs <- decodeBytes - return $ rawDeserialiseSignKeyDSIGNM bs >>= \case - Just vk -> return vk - Nothing - | actual /= expected - -> error ("decodeSignKeyDSIGNM: wrong length, expected " ++ - show expected ++ " bytes but got " ++ show actual) - | otherwise -> error "decodeSignKeyDSIGNM: cannot decode key" - where - expected = fromIntegral (sizeSignKeyDSIGNM (Proxy :: Proxy v)) - actual = BS.length bs - -decodeSigDSIGNM :: forall v s. DSIGNMAlgorithmBase v => Decoder s (SigDSIGNM v) -decodeSigDSIGNM = do - bs <- decodeBytes - case rawDeserialiseSigDSIGNM bs of - Just sig -> return sig - Nothing - | actual /= expected - -> fail ("decodeSigDSIGNM: wrong length, expected " ++ - show expected ++ " bytes but got " ++ show actual) - | otherwise -> fail "decodeSigDSIGNM: cannot decode signature" - where - expected = fromIntegral (sizeSigDSIGNM (Proxy :: Proxy v)) - actual = BS.length bs - - -newtype SignedDSIGNM v a = SignedDSIGNM (SigDSIGNM v) - deriving Generic - -deriving instance DSIGNMAlgorithmBase v => Show (SignedDSIGNM v a) -deriving instance DSIGNMAlgorithmBase v => Eq (SignedDSIGNM v a) - -instance DSIGNMAlgorithmBase v => NoThunks (SignedDSIGNM v a) - -- use generic instance - -signedDSIGNM - :: (DSIGNMAlgorithm v, SignableM v a, MonadST m, MonadThrow m) - => ContextDSIGNM v - -> a - -> SignKeyDSIGNM v - -> m (SignedDSIGNM v a) -signedDSIGNM ctxt a key = SignedDSIGNM <$> signDSIGNM ctxt a key - -verifySignedDSIGNM - :: (DSIGNMAlgorithmBase v, SignableM v a, HasCallStack) - => ContextDSIGNM v - -> VerKeyDSIGNM v - -> a - -> SignedDSIGNM v a - -> Either String () -verifySignedDSIGNM ctxt key a (SignedDSIGNM s) = verifyDSIGNM ctxt key a s - -encodeSignedDSIGNM :: DSIGNMAlgorithmBase v => SignedDSIGNM v a -> Encoding -encodeSignedDSIGNM (SignedDSIGNM s) = encodeSigDSIGNM s - -decodeSignedDSIGNM :: DSIGNMAlgorithmBase v => Decoder s (SignedDSIGNM v a) -decodeSignedDSIGNM = SignedDSIGNM <$> decodeSigDSIGNM - --- --- Encoded 'Size' expressions for 'ToCBOR' instances --- - --- | 'Size' expression for 'VerKeyDSIGNM' which is using 'sizeVerKeyDSIGNM' --- encoded as 'Size'. --- -encodedVerKeyDSIGNMSizeExpr :: forall v. DSIGNMAlgorithmBase v => Proxy (VerKeyDSIGNM v) -> Size -encodedVerKeyDSIGNMSizeExpr _proxy = - -- 'encodeBytes' envelope - fromIntegral ((withWordSize :: Word -> Integer) (sizeVerKeyDSIGNM (Proxy :: Proxy v))) - -- payload - + fromIntegral (sizeVerKeyDSIGNM (Proxy :: Proxy v)) - --- | 'Size' expression for 'SignKeyDSIGNM' which is using 'sizeSignKeyDSIGNM' --- encoded as 'Size'. --- -encodedSignKeyDSIGNMSizeExpr :: forall v. DSIGNMAlgorithmBase v => Proxy (SignKeyDSIGNM v) -> Size -encodedSignKeyDSIGNMSizeExpr _proxy = - -- 'encodeBytes' envelope - fromIntegral ((withWordSize :: Word -> Integer) (sizeSignKeyDSIGNM (Proxy :: Proxy v))) - -- payload - + fromIntegral (sizeSignKeyDSIGNM (Proxy :: Proxy v)) - --- | 'Size' expression for 'SigDSIGNM' which is using 'sizeSigDSIGNM' encoded as --- 'Size'. --- -encodedSigDSIGNMSizeExpr :: forall v. DSIGNMAlgorithmBase v => Proxy (SigDSIGNM v) -> Size -encodedSigDSIGNMSizeExpr _proxy = - -- 'encodeBytes' envelope - fromIntegral ((withWordSize :: Word -> Integer) (sizeSigDSIGNM (Proxy :: Proxy v))) - -- payload - + fromIntegral (sizeSigDSIGNM (Proxy :: Proxy v)) diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Class.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Class.hs index 6e61adb94..afeda1b76 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Class.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/Class.hs @@ -16,7 +16,6 @@ module Cardano.Crypto.KES.Class ( -- * KES algorithm class KESAlgorithm (..) - , KESSignAlgorithm (..) , genKeyKES , updateKES , forgetSignKeyKES @@ -50,7 +49,7 @@ module Cardano.Crypto.KES.Class , seedSizeKES -- * Unsound API - , UnsoundKESSignAlgorithm (..) + , UnsoundKESAlgorithm (..) , encodeSignKeyKES , decodeSignKeyKES , rawDeserialiseSignKeyKES @@ -106,6 +105,8 @@ class ( Typeable v -- data VerKeyKES v :: Type data SigKES v :: Type + data SignKeyKES v :: Type + type SeedSizeKES v :: Nat type SizeVerKeyKES v :: Nat @@ -166,24 +167,6 @@ class ( Typeable v rawDeserialiseVerKeyKES :: ByteString -> Maybe (VerKeyKES v) rawDeserialiseSigKES :: ByteString -> Maybe (SigKES v) -sizeVerKeyKES :: forall v proxy. KESAlgorithm v => proxy v -> Word -sizeVerKeyKES _ = fromInteger (natVal (Proxy @(SizeVerKeyKES v))) - -sizeSigKES :: forall v proxy. KESAlgorithm v => proxy v -> Word -sizeSigKES _ = fromInteger (natVal (Proxy @(SizeSigKES v))) - -sizeSignKeyKES :: forall v proxy. KESAlgorithm v => proxy v -> Word -sizeSignKeyKES _ = fromInteger (natVal (Proxy @(SizeSignKeyKES v))) - --- | The upper bound on the 'Seed' size needed by 'genKeyKES' -seedSizeKES :: forall v proxy. KESAlgorithm v => proxy v -> Word -seedSizeKES _ = fromInteger (natVal (Proxy @(SeedSizeKES v))) - - -class KESAlgorithm v => KESSignAlgorithm v where - - data SignKeyKES v :: Type - deriveVerKeyKES :: (MonadST m, MonadThrow m) => SignKeyKES v -> m (VerKeyKES v) -- @@ -229,6 +212,20 @@ class KESAlgorithm v => KESSignAlgorithm v where -> SignKeyKES v -> m () +sizeVerKeyKES :: forall v proxy. KESAlgorithm v => proxy v -> Word +sizeVerKeyKES _ = fromInteger (natVal (Proxy @(SizeVerKeyKES v))) + +sizeSigKES :: forall v proxy. KESAlgorithm v => proxy v -> Word +sizeSigKES _ = fromInteger (natVal (Proxy @(SizeSigKES v))) + +sizeSignKeyKES :: forall v proxy. KESAlgorithm v => proxy v -> Word +sizeSignKeyKES _ = fromInteger (natVal (Proxy @(SizeSignKeyKES v))) + +-- | The upper bound on the 'Seed' size needed by 'genKeyKES' +seedSizeKES :: forall v proxy. KESAlgorithm v => proxy v -> Word +seedSizeKES _ = fromInteger (natVal (Proxy @(SeedSizeKES v))) + + -- | Forget a signing key synchronously, rather than waiting for GC. In some -- non-mock instances this provides a guarantee that the signing key is no -- longer in memory. @@ -236,7 +233,7 @@ class KESAlgorithm v => KESSignAlgorithm v where -- The precondition is that this key value will not be used again. -- forgetSignKeyKES - :: (KESSignAlgorithm v, MonadST m, MonadThrow m) + :: (KESAlgorithm v, MonadST m, MonadThrow m) => SignKeyKES v -> m () forgetSignKeyKES = forgetSignKeyKESWith mlockedMalloc @@ -244,7 +241,7 @@ forgetSignKeyKES = forgetSignKeyKESWith mlockedMalloc -- | Key generation -- genKeyKES - :: forall v m. (KESSignAlgorithm v, MonadST m, MonadThrow m) + :: forall v m. (KESAlgorithm v, MonadST m, MonadThrow m) => MLockedSeed (SeedSizeKES v) -> m (SignKeyKES v) genKeyKES = genKeyKESWith mlockedMalloc @@ -267,7 +264,7 @@ genKeyKES = genKeyKESWith mlockedMalloc -- increments one period at once. -- updateKES - :: forall v m. (KESSignAlgorithm v, MonadST m, MonadThrow m) + :: forall v m. (KESAlgorithm v, MonadST m, MonadThrow m) => ContextKES v -> SignKeyKES v -> Period -- ^ The /current/ period for the key, not the target period. @@ -278,7 +275,7 @@ updateKES = updateKESWith mlockedMalloc -- | Unsound operations on KES sign keys. These operations violate secure -- forgetting constraints by leaking secrets to unprotected memory. Consider -- using the 'DirectSerialise' / 'DirectDeserialise' APIs instead. -class KESSignAlgorithm v => UnsoundKESSignAlgorithm v where +class KESAlgorithm v => UnsoundKESAlgorithm v where rawDeserialiseSignKeyKESWith :: (MonadST m, MonadThrow m) => MLockedAllocator m -> ByteString @@ -287,7 +284,7 @@ class KESSignAlgorithm v => UnsoundKESSignAlgorithm v where rawSerialiseSignKeyKES :: (MonadST m, MonadThrow m) => SignKeyKES v -> m ByteString rawDeserialiseSignKeyKES :: - (UnsoundKESSignAlgorithm v, MonadST m, MonadThrow m) + (UnsoundKESAlgorithm v, MonadST m, MonadThrow m) => ByteString -> m (Maybe (SignKeyKES v)) rawDeserialiseSignKeyKES = rawDeserialiseSignKeyKESWith mlockedMalloc @@ -364,7 +361,7 @@ encodeSigKES :: KESAlgorithm v => SigKES v -> Encoding encodeSigKES = encodeBytes . rawSerialiseSigKES encodeSignKeyKES :: - forall v m. (UnsoundKESSignAlgorithm v, MonadST m, MonadThrow m) + forall v m. (UnsoundKESAlgorithm v, MonadST m, MonadThrow m) => SignKeyKES v -> m Encoding encodeSignKeyKES = fmap encodeBytes . rawSerialiseSignKeyKES @@ -386,7 +383,7 @@ decodeSigKES = do {-# INLINE decodeSigKES #-} decodeSignKeyKES :: - forall v s m. (UnsoundKESSignAlgorithm v, MonadST m, MonadThrow m) + forall v s m. (UnsoundKESAlgorithm v, MonadST m, MonadThrow m) => Decoder s (m (Maybe (SignKeyKES v))) decodeSignKeyKES = do bs <- decodeBytes @@ -415,7 +412,7 @@ instance KESAlgorithm v => NoThunks (SignedKES v a) -- use generic instance signedKES - :: (KESSignAlgorithm v, Signable v a, MonadST m, MonadThrow m) + :: (KESAlgorithm v, Signable v a, MonadST m, MonadThrow m) => ContextKES v -> Period -> a diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs index 07cc9a9a9..cce1102f1 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSingle.hs @@ -58,7 +58,7 @@ import Control.DeepSeq (NFData) import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Cardano.Crypto.Hash.Class -import Cardano.Crypto.DSIGNM.Class as DSIGNM +import Cardano.Crypto.DSIGN.Class as DSIGN import Cardano.Crypto.KES.Class @@ -67,38 +67,41 @@ import Cardano.Crypto.KES.Class -- data CompactSingleKES d -deriving newtype instance NFData (VerKeyDSIGNM d) => NFData (VerKeyKES (CompactSingleKES d)) +deriving newtype instance NFData (VerKeyDSIGN d) => NFData (VerKeyKES (CompactSingleKES d)) deriving newtype instance NFData (SignKeyDSIGNM d) => NFData (SignKeyKES (CompactSingleKES d)) -deriving instance (NFData (SigDSIGNM d), NFData (VerKeyDSIGNM d)) => NFData (SigKES (CompactSingleKES d)) +deriving instance (NFData (SigDSIGN d), NFData (VerKeyDSIGN d)) => NFData (SigKES (CompactSingleKES d)) -instance ( DSIGNMAlgorithmBase d - , KnownNat (SizeSigDSIGNM d + SizeVerKeyDSIGNM d) +instance ( DSIGNMAlgorithm d + , KnownNat (SizeSigDSIGN d + SizeVerKeyDSIGN d) ) => KESAlgorithm (CompactSingleKES d) where - type SeedSizeKES (CompactSingleKES d) = SeedSizeDSIGNM d + type SeedSizeKES (CompactSingleKES d) = SeedSizeDSIGN d + -- -- Key and signature types -- - newtype VerKeyKES (CompactSingleKES d) = VerKeyCompactSingleKES (VerKeyDSIGNM d) + newtype VerKeyKES (CompactSingleKES d) = VerKeyCompactSingleKES (VerKeyDSIGN d) deriving Generic - data SigKES (CompactSingleKES d) = SigCompactSingleKES !(SigDSIGNM d) !(VerKeyDSIGNM d) + data SigKES (CompactSingleKES d) = SigCompactSingleKES !(SigDSIGN d) !(VerKeyDSIGN d) deriving Generic - type ContextKES (CompactSingleKES d) = ContextDSIGNM d - type Signable (CompactSingleKES d) = DSIGNM.SignableM d + newtype SignKeyKES (CompactSingleKES d) = SignKeyCompactSingleKES (SignKeyDSIGNM d) + + type ContextKES (CompactSingleKES d) = ContextDSIGN d + type Signable (CompactSingleKES d) = DSIGN.Signable d -- -- Metadata and basic key operations -- - algorithmNameKES _ = algorithmNameDSIGNM (Proxy :: Proxy d) ++ "_kes_2^0" + algorithmNameKES _ = algorithmNameDSIGN (Proxy :: Proxy d) ++ "_kes_2^0" totalPeriodsKES _ = 1 @@ -112,41 +115,35 @@ instance ( DSIGNMAlgorithmBase d -- raw serialise/deserialise -- - type SizeVerKeyKES (CompactSingleKES d) = SizeVerKeyDSIGNM d - type SizeSignKeyKES (CompactSingleKES d) = SizeSignKeyDSIGNM d - type SizeSigKES (CompactSingleKES d) = SizeSigDSIGNM d + SizeVerKeyDSIGNM d + type SizeVerKeyKES (CompactSingleKES d) = SizeVerKeyDSIGN d + type SizeSignKeyKES (CompactSingleKES d) = SizeSignKeyDSIGN d + type SizeSigKES (CompactSingleKES d) = SizeSigDSIGN d + SizeVerKeyDSIGN d hashVerKeyKES (VerKeyCompactSingleKES vk) = - castHash (hashVerKeyDSIGNM vk) + castHash (hashVerKeyDSIGN vk) - rawSerialiseVerKeyKES (VerKeyCompactSingleKES vk) = rawSerialiseVerKeyDSIGNM vk + rawSerialiseVerKeyKES (VerKeyCompactSingleKES vk) = rawSerialiseVerKeyDSIGN vk rawSerialiseSigKES (SigCompactSingleKES sig vk) = - rawSerialiseSigDSIGNM sig <> rawSerialiseVerKeyDSIGNM vk + rawSerialiseSigDSIGN sig <> rawSerialiseVerKeyDSIGN vk - rawDeserialiseVerKeyKES = fmap VerKeyCompactSingleKES . rawDeserialiseVerKeyDSIGNM + rawDeserialiseVerKeyKES = fmap VerKeyCompactSingleKES . rawDeserialiseVerKeyDSIGN rawDeserialiseSigKES b = do guard (BS.length b == fromIntegral size_total) - sigma <- rawDeserialiseSigDSIGNM b_sig - vk <- rawDeserialiseVerKeyDSIGNM b_vk + sigma <- rawDeserialiseSigDSIGN b_sig + vk <- rawDeserialiseVerKeyDSIGN b_vk return (SigCompactSingleKES sigma vk) where b_sig = slice off_sig size_sig b b_vk = slice off_vk size_vk b - size_sig = sizeSigDSIGNM (Proxy :: Proxy d) - size_vk = sizeVerKeyDSIGNM (Proxy :: Proxy d) + size_sig = sizeSigDSIGN (Proxy :: Proxy d) + size_vk = sizeVerKeyDSIGN (Proxy :: Proxy d) size_total = sizeSigKES (Proxy :: Proxy (CompactSingleKES d)) off_sig = 0 :: Word off_vk = size_sig -instance ( DSIGNMAlgorithm d -- needed for secure forgetting - , KnownNat (SizeSigDSIGNM d + SizeVerKeyDSIGNM d) - ) - => KESSignAlgorithm (CompactSingleKES d) where - newtype SignKeyKES (CompactSingleKES d) = SignKeyCompactSingleKES (SignKeyDSIGNM d) - deriveVerKeyKES (SignKeyCompactSingleKES v) = VerKeyCompactSingleKES <$!> deriveVerKeyDSIGNM v @@ -172,18 +169,18 @@ instance ( DSIGNMAlgorithm d -- needed for secure forgetting forgetSignKeyDSIGNMWith allocator v instance ( KESAlgorithm (CompactSingleKES d) - , DSIGNMAlgorithmBase d + , DSIGNMAlgorithm d ) => OptimizedKESAlgorithm (CompactSingleKES d) where verifySigKES ctxt t a (SigCompactSingleKES sig vk) = assert (t == 0) $ - verifyDSIGNM ctxt vk a sig + verifyDSIGN ctxt vk a sig verKeyFromSigKES _ctxt t (SigCompactSingleKES _ vk) = assert (t == 0) $ VerKeyCompactSingleKES vk -instance (KESSignAlgorithm (CompactSingleKES d), UnsoundDSIGNMAlgorithm d) - => UnsoundKESSignAlgorithm (CompactSingleKES d) where +instance (KESAlgorithm (CompactSingleKES d), UnsoundDSIGNMAlgorithm d) + => UnsoundKESAlgorithm (CompactSingleKES d) where rawSerialiseSignKeyKES (SignKeyCompactSingleKES sk) = rawSerialiseSignKeyDSIGNM sk rawDeserialiseSignKeyKESWith allocator bs = fmap SignKeyCompactSingleKES <$> rawDeserialiseSignKeyDSIGNMWith allocator bs @@ -192,39 +189,39 @@ instance (KESSignAlgorithm (CompactSingleKES d), UnsoundDSIGNMAlgorithm d) -- VerKey instances -- -deriving instance DSIGNMAlgorithmBase d => Show (VerKeyKES (CompactSingleKES d)) -deriving instance DSIGNMAlgorithmBase d => Eq (VerKeyKES (CompactSingleKES d)) +deriving instance DSIGNMAlgorithm d => Show (VerKeyKES (CompactSingleKES d)) +deriving instance DSIGNMAlgorithm d => Eq (VerKeyKES (CompactSingleKES d)) -instance (DSIGNMAlgorithmBase d, KnownNat (SizeSigDSIGNM d + SizeVerKeyDSIGNM d)) => ToCBOR (VerKeyKES (CompactSingleKES d)) where +instance (DSIGNMAlgorithm d, KnownNat (SizeSigDSIGN d + SizeVerKeyDSIGN d)) => ToCBOR (VerKeyKES (CompactSingleKES d)) where toCBOR = encodeVerKeyKES encodedSizeExpr _size = encodedVerKeyKESSizeExpr -instance (DSIGNMAlgorithmBase d, KnownNat (SizeSigDSIGNM d + SizeVerKeyDSIGNM d)) => FromCBOR (VerKeyKES (CompactSingleKES d)) where +instance (DSIGNMAlgorithm d, KnownNat (SizeSigDSIGN d + SizeVerKeyDSIGN d)) => FromCBOR (VerKeyKES (CompactSingleKES d)) where fromCBOR = decodeVerKeyKES -instance DSIGNMAlgorithmBase d => NoThunks (VerKeyKES (CompactSingleKES d)) +instance DSIGNMAlgorithm d => NoThunks (VerKeyKES (CompactSingleKES d)) -- -- SignKey instances -- -deriving via (SignKeyDSIGNM d) instance DSIGNMAlgorithmBase d => NoThunks (SignKeyKES (CompactSingleKES d)) +deriving via (SignKeyDSIGNM d) instance DSIGNMAlgorithm d => NoThunks (SignKeyKES (CompactSingleKES d)) -- -- Sig instances -- -deriving instance DSIGNMAlgorithmBase d => Show (SigKES (CompactSingleKES d)) -deriving instance DSIGNMAlgorithmBase d => Eq (SigKES (CompactSingleKES d)) +deriving instance DSIGNMAlgorithm d => Show (SigKES (CompactSingleKES d)) +deriving instance DSIGNMAlgorithm d => Eq (SigKES (CompactSingleKES d)) -instance DSIGNMAlgorithmBase d => NoThunks (SigKES (CompactSingleKES d)) +instance DSIGNMAlgorithm d => NoThunks (SigKES (CompactSingleKES d)) -instance (DSIGNMAlgorithmBase d, KnownNat (SizeSigKES (CompactSingleKES d))) => ToCBOR (SigKES (CompactSingleKES d)) where +instance (DSIGNMAlgorithm d, KnownNat (SizeSigKES (CompactSingleKES d))) => ToCBOR (SigKES (CompactSingleKES d)) where toCBOR = encodeSigKES encodedSizeExpr _size = encodedSigKESSizeExpr -instance (DSIGNMAlgorithmBase d, KnownNat (SizeSigKES (CompactSingleKES d))) => FromCBOR (SigKES (CompactSingleKES d)) where +instance (DSIGNMAlgorithm d, KnownNat (SizeSigKES (CompactSingleKES d))) => FromCBOR (SigKES (CompactSingleKES d)) where fromCBOR = decodeSigKES slice :: Word -> Word -> ByteString -> ByteString diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs index 6f7e247e2..ce37acbe8 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/CompactSum.hs @@ -181,6 +181,16 @@ instance ( OptimizedKESAlgorithm d !(VerKeyKES d) deriving Generic + -- | From Figure 3: @(sk_0, r_1, vk_0, vk_1)@ + -- + data SignKeyKES (CompactSumKES h d) = + SignKeyCompactSumKES !(SignKeyKES d) + !(MLockedSeed (SeedSizeKES d)) + !(VerKeyKES d) + !(VerKeyKES d) + + + -- -- Metadata and basic key operations @@ -244,25 +254,6 @@ instance ( OptimizedKESAlgorithm d off_sig = 0 :: Word off_vk = size_sig -instance ( OptimizedKESAlgorithm d - , KESSignAlgorithm d - , SodiumHashAlgorithm h -- needed for secure forgetting - , SizeHash h ~ SeedSizeKES d -- can be relaxed - , NoThunks (VerKeyKES (CompactSumKES h d)) - , KnownNat (SizeVerKeyKES (CompactSumKES h d)) - , KnownNat (SizeSignKeyKES (CompactSumKES h d)) - , KnownNat (SizeSigKES (CompactSumKES h d)) - ) - => KESSignAlgorithm (CompactSumKES h d) where - -- | From Figure 3: @(sk_0, r_1, vk_0, vk_1)@ - -- - data SignKeyKES (CompactSumKES h d) = - SignKeyCompactSumKES !(SignKeyKES d) - !(MLockedSeed (SeedSizeKES d)) - !(VerKeyKES d) - !(VerKeyKES d) - - deriveVerKeyKES (SignKeyCompactSumKES _ _ vk_0 vk_1) = return $! VerKeyCompactSumKES (hashPairOfVKeys (vk_0, vk_1)) @@ -321,9 +312,9 @@ instance ( OptimizedKESAlgorithm d forgetSignKeyKESWith allocator sk_0 mlockedSeedFinalize r1 -instance ( KESSignAlgorithm (CompactSumKES h d) - , UnsoundKESSignAlgorithm d - ) => UnsoundKESSignAlgorithm (CompactSumKES h d) where +instance ( KESAlgorithm (CompactSumKES h d) + , UnsoundKESAlgorithm d + ) => UnsoundKESAlgorithm (CompactSumKES h d) where -- -- Raw serialise/deserialise - dangerous, do not use in production code. -- diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs index ae9b1b82c..4e2a91516 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/Mock.hs @@ -67,6 +67,12 @@ instance KnownNat t => KESAlgorithm (MockKES t) where deriving stock (Show, Eq, Generic) deriving anyclass (NoThunks) + data SignKeyKES (MockKES t) = + SignKeyMockKES !(VerKeyKES (MockKES t)) !Period + deriving stock (Show, Eq, Generic) + deriving anyclass (NoThunks) + + -- -- Metadata and basic key operations -- @@ -124,12 +130,6 @@ instance KnownNat t => KESAlgorithm (MockKES t) where | otherwise = Nothing -instance KnownNat t => KESSignAlgorithm (MockKES t) where - data SignKeyKES (MockKES t) = - SignKeyMockKES !(VerKeyKES (MockKES t)) !Period - deriving stock (Show, Eq, Generic) - deriving anyclass (NoThunks) - deriveVerKeyKES (SignKeyMockKES vk _) = return $! vk updateKESWith _allocator () (SignKeyMockKES vk t') t = @@ -156,7 +156,7 @@ instance KnownNat t => KESSignAlgorithm (MockKES t) where forgetSignKeyKESWith _ = const $ return () -instance KnownNat t => UnsoundKESSignAlgorithm (MockKES t) where +instance KnownNat t => UnsoundKESAlgorithm (MockKES t) where rawSerialiseSignKeyKES sk = return $ rawSerialiseSignKeyMockKES sk diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/NeverUsed.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/NeverUsed.hs index 8aaf910ab..202b397b5 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/NeverUsed.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/NeverUsed.hs @@ -33,6 +33,9 @@ instance KESAlgorithm NeverKES where data SigKES NeverKES = NeverUsedSigKES deriving (Show, Eq, Generic, NoThunks) + data SignKeyKES NeverKES = NeverUsedSignKeyKES + deriving (Show, Eq, Generic, NoThunks) + algorithmNameKES _ = "never" verifyKES = error "KES not available" @@ -49,10 +52,6 @@ instance KESAlgorithm NeverKES where rawDeserialiseVerKeyKES _ = Just NeverUsedVerKeyKES rawDeserialiseSigKES _ = Just NeverUsedSigKES -instance KESSignAlgorithm NeverKES where - data SignKeyKES NeverKES = NeverUsedSignKeyKES - deriving (Show, Eq, Generic, NoThunks) - deriveVerKeyKES _ = return NeverUsedVerKeyKES signKES = error "KES not available" @@ -63,6 +62,6 @@ instance KESSignAlgorithm NeverKES where forgetSignKeyKESWith _ = const $ return () -instance UnsoundKESSignAlgorithm NeverKES where +instance UnsoundKESAlgorithm NeverKES where rawSerialiseSignKeyKES _ = return mempty rawDeserialiseSignKeyKESWith _ _ = return $ Just NeverUsedSignKeyKES diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs index 8ec44fa14..b8bfe2186 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/Simple.hs @@ -38,6 +38,7 @@ import Control.Monad ( (<$!>) ) import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Cardano.Crypto.DSIGN +import qualified Cardano.Crypto.DSIGN.Class as DSIGN import Cardano.Crypto.KES.Class import Cardano.Crypto.Libsodium.MLockedSeed import Cardano.Crypto.Libsodium.MLockedBytes @@ -52,7 +53,7 @@ data SimpleKES d (t :: Nat) -- -- The alternative is to use an unboxed vector, but that would require an -- unreasonable 'Unbox' constraint. -pattern VerKeySimpleKES :: Vector (VerKeyDSIGNM d) -> VerKeyKES (SimpleKES d t) +pattern VerKeySimpleKES :: Vector (VerKeyDSIGN d) -> VerKeyKES (SimpleKES d t) pattern VerKeySimpleKES v <- ThunkyVerKeySimpleKES v where VerKeySimpleKES v = ThunkyVerKeySimpleKES (forceElemsToWHNF v) @@ -67,28 +68,31 @@ pattern SignKeySimpleKES v <- ThunkySignKeySimpleKES v {-# COMPLETE SignKeySimpleKES #-} -instance ( DSIGNMAlgorithmBase d +instance ( DSIGNMAlgorithm d , KnownNat t - , KnownNat (SeedSizeDSIGNM d * t) - , KnownNat (SizeVerKeyDSIGNM d * t) - , KnownNat (SizeSignKeyDSIGNM d * t) + , KnownNat (SeedSizeDSIGN d * t) + , KnownNat (SizeVerKeyDSIGN d * t) + , KnownNat (SizeSignKeyDSIGN d * t) ) => KESAlgorithm (SimpleKES d t) where - type SeedSizeKES (SimpleKES d t) = SeedSizeDSIGNM d * t + type SeedSizeKES (SimpleKES d t) = SeedSizeDSIGN d * t -- -- Key and signature types -- newtype VerKeyKES (SimpleKES d t) = - ThunkyVerKeySimpleKES (Vector (VerKeyDSIGNM d)) + ThunkyVerKeySimpleKES (Vector (VerKeyDSIGN d)) deriving Generic newtype SigKES (SimpleKES d t) = - SigSimpleKES (SigDSIGNM d) + SigSimpleKES (SigDSIGN d) deriving Generic + newtype SignKeyKES (SimpleKES d t) = + ThunkySignKeySimpleKES (Vector (SignKeyDSIGNM d)) + deriving Generic -- -- Metadata and basic key operations @@ -102,53 +106,40 @@ instance ( DSIGNMAlgorithmBase d -- Core algorithm operations -- - type ContextKES (SimpleKES d t) = ContextDSIGNM d - type Signable (SimpleKES d t) = SignableM d + type ContextKES (SimpleKES d t) = ContextDSIGN d + type Signable (SimpleKES d t) = DSIGN.Signable d verifyKES ctxt (VerKeySimpleKES vks) j a (SigSimpleKES sig) = case vks !? fromIntegral j of Nothing -> Left "KES verification failed: out of range" - Just vk -> verifyDSIGNM ctxt vk a sig + Just vk -> verifyDSIGN ctxt vk a sig -- -- raw serialise/deserialise -- - type SizeVerKeyKES (SimpleKES d t) = SizeVerKeyDSIGNM d * t - type SizeSignKeyKES (SimpleKES d t) = SizeSignKeyDSIGNM d * t - type SizeSigKES (SimpleKES d t) = SizeSigDSIGNM d + type SizeVerKeyKES (SimpleKES d t) = SizeVerKeyDSIGN d * t + type SizeSignKeyKES (SimpleKES d t) = SizeSignKeyDSIGN d * t + type SizeSigKES (SimpleKES d t) = SizeSigDSIGN d rawSerialiseVerKeyKES (VerKeySimpleKES vks) = - BS.concat [ rawSerialiseVerKeyDSIGNM vk | vk <- Vec.toList vks ] + BS.concat [ rawSerialiseVerKeyDSIGN vk | vk <- Vec.toList vks ] rawSerialiseSigKES (SigSimpleKES sig) = - rawSerialiseSigDSIGNM sig + rawSerialiseSigDSIGN sig rawDeserialiseVerKeyKES bs | let duration = fromIntegral (natVal (Proxy :: Proxy t)) - sizeKey = fromIntegral (sizeVerKeyDSIGNM (Proxy :: Proxy d)) + sizeKey = fromIntegral (sizeVerKeyDSIGN (Proxy :: Proxy d)) , vkbs <- splitsAt (replicate duration sizeKey) bs , length vkbs == duration - , Just vks <- mapM rawDeserialiseVerKeyDSIGNM vkbs + , Just vks <- mapM rawDeserialiseVerKeyDSIGN vkbs = Just $! VerKeySimpleKES (Vec.fromList vks) | otherwise = Nothing - rawDeserialiseSigKES = fmap SigSimpleKES . rawDeserialiseSigDSIGNM - - - -instance ( KESAlgorithm (SimpleKES d t) - , DSIGNMAlgorithm d - , KnownNat t - , KnownNat (SeedSizeDSIGNM d * t) - ) => - KESSignAlgorithm (SimpleKES d t) where - newtype SignKeyKES (SimpleKES d t) = - ThunkySignKeySimpleKES (Vector (SignKeyDSIGNM d)) - deriving Generic - + rawDeserialiseSigKES = fmap SigSimpleKES . rawDeserialiseSigDSIGN deriveVerKeyKES (SignKeySimpleKES sks) = VerKeySimpleKES <$!> Vec.mapM deriveVerKeyDSIGNM sks @@ -171,7 +162,7 @@ instance ( KESAlgorithm (SimpleKES d t) -- genKeyKESWith allocator (MLockedSeed mlsb) = do - let seedSize = seedSizeDSIGNM (Proxy :: Proxy d) + let seedSize = seedSizeDSIGN (Proxy :: Proxy d) duration = fromIntegral (natVal (Proxy @t)) sks <- Vec.generateM duration $ \t -> do withMLSBChunk mlsb (fromIntegral t * fromIntegral seedSize) $ \mlsb' -> do @@ -187,8 +178,8 @@ instance ( KESAlgorithm (SimpleKES d t) -instance ( UnsoundDSIGNMAlgorithm d, KnownNat t, KESSignAlgorithm (SimpleKES d t)) - => UnsoundKESSignAlgorithm (SimpleKES d t) where +instance ( UnsoundDSIGNMAlgorithm d, KnownNat t, KESAlgorithm (SimpleKES d t)) + => UnsoundKESAlgorithm (SimpleKES d t) where -- -- raw serialise/deserialise -- @@ -199,7 +190,7 @@ instance ( UnsoundDSIGNMAlgorithm d, KnownNat t, KESSignAlgorithm (SimpleKES d t rawDeserialiseSignKeyKESWith allocator bs | let duration = fromIntegral (natVal (Proxy :: Proxy t)) - sizeKey = fromIntegral (sizeSignKeyDSIGNM (Proxy :: Proxy d)) + sizeKey = fromIntegral (sizeSignKeyDSIGN (Proxy :: Proxy d)) , skbs <- splitsAt (replicate duration sizeKey) bs , length skbs == duration = runMaybeT $ do @@ -209,51 +200,51 @@ instance ( UnsoundDSIGNMAlgorithm d, KnownNat t, KESSignAlgorithm (SimpleKES d t | otherwise = return Nothing -deriving instance DSIGNMAlgorithmBase d => Show (VerKeyKES (SimpleKES d t)) -deriving instance DSIGNMAlgorithmBase d => Show (SignKeyKES (SimpleKES d t)) -deriving instance DSIGNMAlgorithmBase d => Show (SigKES (SimpleKES d t)) +deriving instance DSIGNMAlgorithm d => Show (VerKeyKES (SimpleKES d t)) +deriving instance (DSIGNMAlgorithm d, Show (SignKeyDSIGNM d)) => Show (SignKeyKES (SimpleKES d t)) +deriving instance DSIGNMAlgorithm d => Show (SigKES (SimpleKES d t)) -deriving instance DSIGNMAlgorithmBase d => Eq (VerKeyKES (SimpleKES d t)) -deriving instance DSIGNMAlgorithmBase d => Eq (SigKES (SimpleKES d t)) +deriving instance DSIGNMAlgorithm d => Eq (VerKeyKES (SimpleKES d t)) +deriving instance DSIGNMAlgorithm d => Eq (SigKES (SimpleKES d t)) -instance DSIGNMAlgorithmBase d => NoThunks (SigKES (SimpleKES d t)) -instance DSIGNMAlgorithmBase d => NoThunks (SignKeyKES (SimpleKES d t)) -instance DSIGNMAlgorithmBase d => NoThunks (VerKeyKES (SimpleKES d t)) +instance DSIGNMAlgorithm d => NoThunks (SigKES (SimpleKES d t)) +instance DSIGNMAlgorithm d => NoThunks (SignKeyKES (SimpleKES d t)) +instance DSIGNMAlgorithm d => NoThunks (VerKeyKES (SimpleKES d t)) -instance ( DSIGNMAlgorithmBase d +instance ( DSIGNMAlgorithm d , KnownNat t - , KnownNat (SeedSizeDSIGNM d * t) - , KnownNat (SizeVerKeyDSIGNM d * t) - , KnownNat (SizeSignKeyDSIGNM d * t) + , KnownNat (SeedSizeDSIGN d * t) + , KnownNat (SizeVerKeyDSIGN d * t) + , KnownNat (SizeSignKeyDSIGN d * t) ) => ToCBOR (VerKeyKES (SimpleKES d t)) where toCBOR = encodeVerKeyKES encodedSizeExpr _size = encodedVerKeyKESSizeExpr -instance ( DSIGNMAlgorithmBase d +instance ( DSIGNMAlgorithm d , KnownNat t - , KnownNat (SeedSizeDSIGNM d * t) - , KnownNat (SizeVerKeyDSIGNM d * t) - , KnownNat (SizeSignKeyDSIGNM d * t) + , KnownNat (SeedSizeDSIGN d * t) + , KnownNat (SizeVerKeyDSIGN d * t) + , KnownNat (SizeSignKeyDSIGN d * t) ) => FromCBOR (VerKeyKES (SimpleKES d t)) where fromCBOR = decodeVerKeyKES -instance ( DSIGNMAlgorithmBase d +instance ( DSIGNMAlgorithm d , KnownNat t - , KnownNat (SeedSizeDSIGNM d * t) - , KnownNat (SizeVerKeyDSIGNM d * t) - , KnownNat (SizeSignKeyDSIGNM d * t) + , KnownNat (SeedSizeDSIGN d * t) + , KnownNat (SizeVerKeyDSIGN d * t) + , KnownNat (SizeSignKeyDSIGN d * t) ) => ToCBOR (SigKES (SimpleKES d t)) where toCBOR = encodeSigKES encodedSizeExpr _size = encodedSigKESSizeExpr -instance (DSIGNMAlgorithmBase d +instance (DSIGNMAlgorithm d , KnownNat t - , KnownNat (SeedSizeDSIGNM d * t) - , KnownNat (SizeVerKeyDSIGNM d * t) - , KnownNat (SizeSignKeyDSIGNM d * t) + , KnownNat (SeedSizeDSIGN d * t) + , KnownNat (SizeVerKeyDSIGN d * t) + , KnownNat (SizeSignKeyDSIGN d * t) ) => FromCBOR (SigKES (SimpleKES d t)) where fromCBOR = decodeSigKES diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs index c2c8aced2..2d38fb527 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/Single.hs @@ -48,7 +48,7 @@ import Control.Monad ((<$!>)) import Cardano.Binary (FromCBOR (..), ToCBOR (..)) import Cardano.Crypto.Hash.Class -import Cardano.Crypto.DSIGNM.Class as DSIGNM +import Cardano.Crypto.DSIGN.Class as DSIGN import Cardano.Crypto.KES.Class @@ -57,63 +57,63 @@ import Cardano.Crypto.KES.Class -- data SingleKES d -deriving instance NFData (VerKeyDSIGNM d) => NFData (VerKeyKES (SingleKES d)) -deriving instance NFData (SigDSIGNM d) => NFData (SigKES (SingleKES d)) +deriving instance NFData (VerKeyDSIGN d) => NFData (VerKeyKES (SingleKES d)) +deriving instance NFData (SigDSIGN d) => NFData (SigKES (SingleKES d)) deriving via (SignKeyDSIGNM d) instance NFData (SignKeyDSIGNM d) => NFData (SignKeyKES (SingleKES d)) -instance (DSIGNMAlgorithmBase d) => KESAlgorithm (SingleKES d) where - type SeedSizeKES (SingleKES d) = SeedSizeDSIGNM d +instance (DSIGNMAlgorithm d) => KESAlgorithm (SingleKES d) where + type SeedSizeKES (SingleKES d) = SeedSizeDSIGN d -- -- Key and signature types -- - newtype VerKeyKES (SingleKES d) = VerKeySingleKES (VerKeyDSIGNM d) + newtype VerKeyKES (SingleKES d) = VerKeySingleKES (VerKeyDSIGN d) deriving Generic - newtype SigKES (SingleKES d) = SigSingleKES (SigDSIGNM d) + newtype SigKES (SingleKES d) = SigSingleKES (SigDSIGN d) deriving Generic - type ContextKES (SingleKES d) = ContextDSIGNM d - type Signable (SingleKES d) = DSIGNM.SignableM d + newtype SignKeyKES (SingleKES d) = SignKeySingleKES (SignKeyDSIGNM d) + + + type ContextKES (SingleKES d) = ContextDSIGN d + type Signable (SingleKES d) = DSIGN.Signable d -- -- Metadata and basic key operations -- - algorithmNameKES _ = algorithmNameDSIGNM (Proxy :: Proxy d) ++ "_kes_2^0" + algorithmNameKES _ = algorithmNameDSIGN (Proxy :: Proxy d) ++ "_kes_2^0" totalPeriodsKES _ = 1 verifyKES ctxt (VerKeySingleKES vk) t a (SigSingleKES sig) = assert (t == 0) $ - verifyDSIGNM ctxt vk a sig + verifyDSIGN ctxt vk a sig -- -- raw serialise/deserialise -- - type SizeVerKeyKES (SingleKES d) = SizeVerKeyDSIGNM d - type SizeSignKeyKES (SingleKES d) = SizeSignKeyDSIGNM d - type SizeSigKES (SingleKES d) = SizeSigDSIGNM d + type SizeVerKeyKES (SingleKES d) = SizeVerKeyDSIGN d + type SizeSignKeyKES (SingleKES d) = SizeSignKeyDSIGN d + type SizeSigKES (SingleKES d) = SizeSigDSIGN d hashVerKeyKES (VerKeySingleKES vk) = - castHash (hashVerKeyDSIGNM vk) + castHash (hashVerKeyDSIGN vk) - rawSerialiseVerKeyKES (VerKeySingleKES vk) = rawSerialiseVerKeyDSIGNM vk - rawSerialiseSigKES (SigSingleKES sig) = rawSerialiseSigDSIGNM sig + rawSerialiseVerKeyKES (VerKeySingleKES vk) = rawSerialiseVerKeyDSIGN vk + rawSerialiseSigKES (SigSingleKES sig) = rawSerialiseSigDSIGN sig - rawDeserialiseVerKeyKES = fmap VerKeySingleKES . rawDeserialiseVerKeyDSIGNM + rawDeserialiseVerKeyKES = fmap VerKeySingleKES . rawDeserialiseVerKeyDSIGN {-# INLINE rawDeserialiseVerKeyKES #-} - rawDeserialiseSigKES = fmap SigSingleKES . rawDeserialiseSigDSIGNM + rawDeserialiseSigKES = fmap SigSingleKES . rawDeserialiseSigDSIGN {-# INLINE rawDeserialiseSigKES #-} -instance DSIGNMAlgorithm d => KESSignAlgorithm (SingleKES d) where - newtype SignKeyKES (SingleKES d) = SignKeySingleKES (SignKeyDSIGNM d) - deriveVerKeyKES (SignKeySingleKES v) = VerKeySingleKES <$!> deriveVerKeyDSIGNM v @@ -140,8 +140,8 @@ instance DSIGNMAlgorithm d => KESSignAlgorithm (SingleKES d) where forgetSignKeyKESWith allocator (SignKeySingleKES v) = forgetSignKeyDSIGNMWith allocator v -instance (KESSignAlgorithm (SingleKES d), UnsoundDSIGNMAlgorithm d) - => UnsoundKESSignAlgorithm (SingleKES d) where +instance (KESAlgorithm (SingleKES d), UnsoundDSIGNMAlgorithm d) + => UnsoundKESAlgorithm (SingleKES d) where rawSerialiseSignKeyKES (SignKeySingleKES sk) = rawSerialiseSignKeyDSIGNM sk @@ -152,39 +152,39 @@ instance (KESSignAlgorithm (SingleKES d), UnsoundDSIGNMAlgorithm d) -- VerKey instances -- -deriving instance DSIGNMAlgorithmBase d => Show (VerKeyKES (SingleKES d)) -deriving instance DSIGNMAlgorithmBase d => Eq (VerKeyKES (SingleKES d)) +deriving instance DSIGNAlgorithm d => Show (VerKeyKES (SingleKES d)) +deriving instance DSIGNAlgorithm d => Eq (VerKeyKES (SingleKES d)) -instance DSIGNMAlgorithmBase d => ToCBOR (VerKeyKES (SingleKES d)) where +instance DSIGNMAlgorithm d => ToCBOR (VerKeyKES (SingleKES d)) where toCBOR = encodeVerKeyKES encodedSizeExpr _size = encodedVerKeyKESSizeExpr -instance DSIGNMAlgorithmBase d => FromCBOR (VerKeyKES (SingleKES d)) where +instance DSIGNMAlgorithm d => FromCBOR (VerKeyKES (SingleKES d)) where fromCBOR = decodeVerKeyKES {-# INLINE fromCBOR #-} -instance DSIGNMAlgorithmBase d => NoThunks (VerKeyKES (SingleKES d)) +instance DSIGNMAlgorithm d => NoThunks (VerKeyKES (SingleKES d)) -- -- SignKey instances -- -deriving via (SignKeyDSIGNM d) instance DSIGNMAlgorithmBase d => NoThunks (SignKeyKES (SingleKES d)) +deriving via (SignKeyDSIGNM d) instance DSIGNMAlgorithm d => NoThunks (SignKeyKES (SingleKES d)) -- -- Sig instances -- -deriving instance DSIGNMAlgorithmBase d => Show (SigKES (SingleKES d)) -deriving instance DSIGNMAlgorithmBase d => Eq (SigKES (SingleKES d)) +deriving instance DSIGNAlgorithm d => Show (SigKES (SingleKES d)) +deriving instance DSIGNAlgorithm d => Eq (SigKES (SingleKES d)) -instance DSIGNMAlgorithmBase d => NoThunks (SigKES (SingleKES d)) +instance DSIGNAlgorithm d => NoThunks (SigKES (SingleKES d)) -instance DSIGNMAlgorithmBase d => ToCBOR (SigKES (SingleKES d)) where +instance DSIGNMAlgorithm d => ToCBOR (SigKES (SingleKES d)) where toCBOR = encodeSigKES encodedSizeExpr _size = encodedSigKESSizeExpr -instance DSIGNMAlgorithmBase d => FromCBOR (SigKES (SingleKES d)) where +instance DSIGNMAlgorithm d => FromCBOR (SigKES (SingleKES d)) where fromCBOR = decodeSigKES {-# INLINE fromCBOR #-} diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs index 23de3f54b..300962d11 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/Sum.hs @@ -120,6 +120,15 @@ instance ( KESAlgorithm d , KnownNat (SizeSigKES d + (SizeVerKeyKES d * 2)) ) => KESAlgorithm (SumKES h d) where + -- | From Figure 3: @(sk_0, r_1, vk_0, vk_1)@ + -- + data SignKeyKES (SumKES h d) = + SignKeySumKES !(SignKeyKES d) + !(MLockedSeed (SeedSizeKES d)) + !(VerKeyKES d) + !(VerKeyKES d) + + type SeedSizeKES (SumKES h d) = SeedSizeKES d @@ -220,22 +229,6 @@ instance ( KESAlgorithm d off_vk1 = off_vk0 + size_vk {-# INLINEABLE rawDeserialiseSigKES #-} -instance ( KESSignAlgorithm d - , SodiumHashAlgorithm h -- needed for secure forgetting - , SizeHash h ~ SeedSizeKES d -- can be relaxed - , KnownNat ((SizeSignKeyKES d + SeedSizeKES d) + (2 * SizeVerKeyKES d)) - , KnownNat (SizeSigKES d + (SizeVerKeyKES d * 2)) - ) - => KESSignAlgorithm (SumKES h d) where - -- | From Figure 3: @(sk_0, r_1, vk_0, vk_1)@ - -- - data SignKeyKES (SumKES h d) = - SignKeySumKES !(SignKeyKES d) - !(MLockedSeed (SeedSizeKES d)) - !(VerKeyKES d) - !(VerKeyKES d) - - deriveVerKeyKES (SignKeySumKES _ _ vk_0 vk_1) = return $! VerKeySumKES (hashPairOfVKeys (vk_0, vk_1)) @@ -292,9 +285,9 @@ instance ( KESSignAlgorithm d forgetSignKeyKESWith allocator sk_0 mlockedSeedFinalize r1 -instance ( KESSignAlgorithm (SumKES h d) - , UnsoundKESSignAlgorithm d - ) => UnsoundKESSignAlgorithm (SumKES h d) where +instance ( KESAlgorithm (SumKES h d) + , UnsoundKESAlgorithm d + ) => UnsoundKESAlgorithm (SumKES h d) where -- -- Raw serialise/deserialise - dangerous, do not use in production code. -- diff --git a/cardano-crypto-tests/src/Bench/Crypto/KES.hs b/cardano-crypto-tests/src/Bench/Crypto/KES.hs index 76ae4db53..38369ee55 100644 --- a/cardano-crypto-tests/src/Bench/Crypto/KES.hs +++ b/cardano-crypto-tests/src/Bench/Crypto/KES.hs @@ -15,7 +15,7 @@ import Data.Maybe (fromJust) import Control.DeepSeq -import Cardano.Crypto.DSIGN.Ed25519ML +import Cardano.Crypto.DSIGN.Ed25519 import Cardano.Crypto.Hash.Blake2b import Cardano.Crypto.KES.Class import Cardano.Crypto.KES.Sum @@ -41,17 +41,17 @@ testSeedML = MLockedSeed . unsafePerformIO $ NaCl.mlsbFromByteString testBytes benchmarks :: Benchmark benchmarks = bgroup "KES" - [ benchKES @Proxy @(Sum6KES Ed25519DSIGNM Blake2b_256) Proxy "Sum6KES" - , benchKES @Proxy @(Sum7KES Ed25519DSIGNM Blake2b_256) Proxy "Sum7KES" - , benchKES @Proxy @(CompactSum6KES Ed25519DSIGNM Blake2b_256) Proxy "CompactSum6KES" - , benchKES @Proxy @(CompactSum7KES Ed25519DSIGNM Blake2b_256) Proxy "CompactSum7KES" + [ benchKES @Proxy @(Sum6KES Ed25519DSIGN Blake2b_256) Proxy "Sum6KES" + , benchKES @Proxy @(Sum7KES Ed25519DSIGN Blake2b_256) Proxy "Sum7KES" + , benchKES @Proxy @(CompactSum6KES Ed25519DSIGN Blake2b_256) Proxy "CompactSum6KES" + , benchKES @Proxy @(CompactSum7KES Ed25519DSIGN Blake2b_256) Proxy "CompactSum7KES" ] {-# NOINLINE benchKES #-} benchKES :: forall (proxy :: forall k. k -> Type) v - . ( KESSignAlgorithm v + . ( KESAlgorithm v , ContextKES v ~ () , Signable v BS.ByteString , NFData (SignKeyKES v) diff --git a/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs b/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs index 85de68852..1c81dcd46 100644 --- a/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs +++ b/cardano-crypto-tests/src/Test/Crypto/DSIGN.hs @@ -51,9 +51,9 @@ import Control.Exception (evaluate, bracket) import Cardano.Crypto.DSIGN ( MockDSIGN, Ed25519DSIGN, - Ed25519DSIGNM, Ed448DSIGN, DSIGNAlgorithm ( + SeedSizeDSIGN, VerKeyDSIGN, SignKeyDSIGN, SigDSIGN, @@ -81,32 +81,12 @@ import Cardano.Crypto.DSIGN ( genKeyDSIGN, seedSizeDSIGN, - DSIGNMAlgorithmBase (VerKeyDSIGNM, - SignKeyDSIGNM, - SigDSIGNM, - ContextDSIGNM, - SignableM, - SeedSizeDSIGNM, - rawSerialiseVerKeyDSIGNM, - rawDeserialiseVerKeyDSIGNM, - rawSerialiseSigDSIGNM, - rawDeserialiseSigDSIGNM), - DSIGNMAlgorithm (), + DSIGNMAlgorithm (SignKeyDSIGNM, deriveVerKeyDSIGNM), UnsoundDSIGNMAlgorithm, rawSerialiseSignKeyDSIGNM, rawDeserialiseSignKeyDSIGNM, - sizeVerKeyDSIGNM, - sizeSignKeyDSIGNM, - sizeSigDSIGNM, - encodeVerKeyDSIGNM, - decodeVerKeyDSIGNM, - -- encodeSignKeyDSIGNM, - -- decodeSignKeyDSIGNM, - encodeSigDSIGNM, - decodeSigDSIGNM, signDSIGNM, - deriveVerKeyDSIGNM, - verifyDSIGNM, + deriveVerKeyDSIGN, genKeyDSIGNM, getSeedDSIGNM, @@ -209,20 +189,24 @@ defaultTestEnough = max 10_000 tests :: Lock -> TestTree tests lock = testGroup "Crypto.DSIGN" - [ testDSIGNAlgorithm mockSigGen (arbitrary @Message) "MockDSIGN" - , testDSIGNAlgorithm ed25519SigGen (arbitrary @Message) "Ed25519DSIGN" - , testDSIGNAlgorithm ed448SigGen (arbitrary @Message) "Ed448DSIGN" + [ testGroup "Pure" + [ testDSIGNAlgorithm mockSigGen (arbitrary @Message) "MockDSIGN" + , testDSIGNAlgorithm ed25519SigGen (arbitrary @Message) "Ed25519DSIGN" + , testDSIGNAlgorithm ed448SigGen (arbitrary @Message) "Ed448DSIGN" #ifdef SECP256K1_ENABLED - , testDSIGNAlgorithm ecdsaSigGen genEcdsaMsg "EcdsaSecp256k1DSIGN" - , testDSIGNAlgorithm schnorrSigGen (arbitrary @Message) "SchnorrSecp256k1DSIGN" - -- Specific tests related only to ecdsa - , testEcdsaInvalidMessageHash "EcdsaSecp256k1InvalidMessageHash" - , testEcdsaWithHashAlgorithm (Proxy @SHA3_256) "EcdsaSecp256k1WithSHA3_256" - , testEcdsaWithHashAlgorithm (Proxy @Blake2b_256) "EcdsaSecp256k1WithBlake2b_256" - , testEcdsaWithHashAlgorithm (Proxy @SHA256) "EcdsaSecp256k1WithSHA256" - , testEcdsaWithHashAlgorithm (Proxy @Keccak256) "EcdsaSecp256k1WithKeccak256" + , testDSIGNAlgorithm ecdsaSigGen genEcdsaMsg "EcdsaSecp256k1DSIGN" + , testDSIGNAlgorithm schnorrSigGen (arbitrary @Message) "SchnorrSecp256k1DSIGN" + -- Specific tests related only to ecdsa + , testEcdsaInvalidMessageHash "EcdsaSecp256k1InvalidMessageHash" + , testEcdsaWithHashAlgorithm (Proxy @SHA3_256) "EcdsaSecp256k1WithSHA3_256" + , testEcdsaWithHashAlgorithm (Proxy @Blake2b_256) "EcdsaSecp256k1WithBlake2b_256" + , testEcdsaWithHashAlgorithm (Proxy @SHA256) "EcdsaSecp256k1WithSHA256" + , testEcdsaWithHashAlgorithm (Proxy @Keccak256) "EcdsaSecp256k1WithKeccak256" #endif - , testDSIGNMAlgorithm lock (Proxy @Ed25519DSIGNM) "Ed25519DSIGNM" + ] + , testGroup "MLocked" + [ testDSIGNMAlgorithm lock (Proxy @Ed25519DSIGN) "Ed25519DSIGN" + ] ] testDSIGNAlgorithm :: forall (v :: Type) (a :: Type). @@ -365,8 +349,8 @@ testDSIGNAlgorithm genSig genMsg name = adjustOption testEnough . testGroup name testDSIGNMAlgorithm :: forall v. ( -- change back to DSIGNMAlgorithm when unsound API is phased out UnsoundDSIGNMAlgorithm v - , ToCBOR (VerKeyDSIGNM v) - , FromCBOR (VerKeyDSIGNM v) + , ToCBOR (VerKeyDSIGN v) + , FromCBOR (VerKeyDSIGN v) -- DSIGNM cannot satisfy To/FromCBOR (not even with -- UnsoundDSIGNMAlgorithm), because those typeclasses assume -- that a non-monadic encoding/decoding exists. Hence, we only @@ -374,10 +358,10 @@ testDSIGNMAlgorithm -- , ToCBOR (SignKeyDSIGNM v) -- , FromCBOR (SignKeyDSIGNM v) , EqST (SignKeyDSIGNM v) -- only monadic EqST for signing keys - , ToCBOR (SigDSIGNM v) - , FromCBOR (SigDSIGNM v) - , ContextDSIGNM v ~ () - , SignableM v Message + , ToCBOR (SigDSIGN v) + , FromCBOR (SigDSIGN v) + , ContextDSIGN v ~ () + , Signable v Message ) => Lock -> Proxy v @@ -390,7 +374,7 @@ testDSIGNMAlgorithm lock _ n = [ testProperty "VerKey" $ ioPropertyWithSK @v lock $ \sk -> do vk <- deriveVerKeyDSIGNM sk - return $ (rawDeserialiseVerKeyDSIGNM . rawSerialiseVerKeyDSIGNM $ vk) === Just vk + return $ (rawDeserialiseVerKeyDSIGN . rawSerialiseVerKeyDSIGN $ vk) === Just vk , testProperty "SignKey" $ ioPropertyWithSK @v lock $ \sk -> do serialized <- rawSerialiseSignKeyDSIGNM sk @@ -401,71 +385,71 @@ testDSIGNMAlgorithm lock _ n = , testProperty "Sig" $ \(msg :: Message) -> ioPropertyWithSK @v lock $ \sk -> do sig <- signDSIGNM () msg sk - return $ (rawDeserialiseSigDSIGNM . rawSerialiseSigDSIGNM $ sig) === Just sig + return $ (rawDeserialiseSigDSIGN . rawSerialiseSigDSIGN $ sig) === Just sig ] , testGroup "size" [ testProperty "VerKey" $ ioPropertyWithSK @v lock $ \sk -> do vk <- deriveVerKeyDSIGNM sk - return $ (fromIntegral . BS.length . rawSerialiseVerKeyDSIGNM $ vk) === sizeVerKeyDSIGNM (Proxy @v) + return $ (fromIntegral . BS.length . rawSerialiseVerKeyDSIGN $ vk) === sizeVerKeyDSIGN (Proxy @v) , testProperty "SignKey" $ ioPropertyWithSK @v lock $ \sk -> do serialized <- rawSerialiseSignKeyDSIGNM sk - evaluate ((fromIntegral . BS.length $ serialized) == sizeSignKeyDSIGNM (Proxy @v)) + evaluate ((fromIntegral . BS.length $ serialized) == sizeSignKeyDSIGN (Proxy @v)) , testProperty "Sig" $ \(msg :: Message) -> ioPropertyWithSK @v lock $ \sk -> do - sig :: SigDSIGNM v <- signDSIGNM () msg sk - return $ (fromIntegral . BS.length . rawSerialiseSigDSIGNM $ sig) === sizeSigDSIGNM (Proxy @v) + sig :: SigDSIGN v <- signDSIGNM () msg sk + return $ (fromIntegral . BS.length . rawSerialiseSigDSIGN $ sig) === sizeSigDSIGN (Proxy @v) ] , testGroup "direct CBOR" [ testProperty "VerKey" $ ioPropertyWithSK @v lock $ \sk -> do - vk :: VerKeyDSIGNM v <- deriveVerKeyDSIGNM sk - return $ prop_cbor_with encodeVerKeyDSIGNM decodeVerKeyDSIGNM vk + vk :: VerKeyDSIGN v <- deriveVerKeyDSIGNM sk + return $ prop_cbor_with encodeVerKeyDSIGN decodeVerKeyDSIGN vk -- No CBOR testing for SignKey: sign keys are stored in MLocked memory -- and require IO for access. , testProperty "Sig" $ \(msg :: Message) -> do ioPropertyWithSK @v lock $ \sk -> do - sig :: SigDSIGNM v <- signDSIGNM () msg sk - return $ prop_cbor_with encodeSigDSIGNM decodeSigDSIGNM sig + sig :: SigDSIGN v <- signDSIGNM () msg sk + return $ prop_cbor_with encodeSigDSIGN decodeSigDSIGN sig ] , testGroup "To/FromCBOR class" [ testProperty "VerKey" $ ioPropertyWithSK @v lock $ \sk -> do - vk :: VerKeyDSIGNM v <- deriveVerKeyDSIGNM sk + vk :: VerKeyDSIGN v <- deriveVerKeyDSIGNM sk return $ prop_cbor vk -- No To/FromCBOR for 'SignKeyDSIGNM', see above. , testProperty "Sig" $ \(msg :: Message) -> ioPropertyWithSK @v lock $ \sk -> do - sig :: SigDSIGNM v <- signDSIGNM () msg sk + sig :: SigDSIGN v <- signDSIGNM () msg sk return $ prop_cbor sig ] , testGroup "ToCBOR size" [ testProperty "VerKey" $ ioPropertyWithSK @v lock $ \sk -> do - vk :: VerKeyDSIGNM v <- deriveVerKeyDSIGNM sk + vk :: VerKeyDSIGN v <- deriveVerKeyDSIGNM sk return $ prop_cbor_size vk -- No To/FromCBOR for 'SignKeyDSIGNM', see above. , testProperty "Sig" $ \(msg :: Message) -> ioPropertyWithSK @v lock $ \sk -> do - sig :: SigDSIGNM v <- signDSIGNM () msg sk + sig :: SigDSIGN v <- signDSIGNM () msg sk return $ prop_cbor_size sig ] , testGroup "direct matches class" [ testProperty "VerKey" $ ioPropertyWithSK @v lock $ \sk -> do - vk :: VerKeyDSIGNM v <- deriveVerKeyDSIGNM sk - return $ prop_cbor_direct_vs_class encodeVerKeyDSIGNM vk + vk :: VerKeyDSIGN v <- deriveVerKeyDSIGNM sk + return $ prop_cbor_direct_vs_class encodeVerKeyDSIGN vk -- No CBOR testing for SignKey: sign keys are stored in MLocked memory -- and require IO for access. , testProperty "Sig" $ \(msg :: Message) -> ioPropertyWithSK @v lock $ \sk -> do - sig :: SigDSIGNM v <- signDSIGNM () msg sk - return $ prop_cbor_direct_vs_class encodeSigDSIGNM sig + sig :: SigDSIGN v <- signDSIGNM () msg sk + return $ prop_cbor_direct_vs_class encodeSigDSIGN sig ] ] @@ -501,7 +485,7 @@ testDSIGNMAlgorithm lock _ n = -- timely forgetting. Special care must be taken to not leak the key outside of -- the wrapped action (be particularly mindful of thunks and unsafe key access -- here). -withSK :: (DSIGNMAlgorithm v) => PinnedSizedBytes (SeedSizeDSIGNM v) -> (SignKeyDSIGNM v -> IO b) -> IO b +withSK :: (DSIGNMAlgorithm v) => PinnedSizedBytes (SeedSizeDSIGN v) -> (SignKeyDSIGNM v -> IO b) -> IO b withSK seedPSB action = withMLockedSeedFromPSB seedPSB $ \seed -> bracket @@ -519,7 +503,7 @@ withSK seedPSB action = ioPropertyWithSK :: forall v a. (Testable a, DSIGNMAlgorithm v) => Lock -> (SignKeyDSIGNM v -> IO a) - -> PinnedSizedBytes (SeedSizeDSIGNM v) + -> PinnedSizedBytes (SeedSizeDSIGN v) -> Property ioPropertyWithSK lock action seedPSB = ioProperty . withLock lock $ withSK seedPSB action @@ -529,7 +513,7 @@ prop_key_overwritten_after_forget (DSIGNMAlgorithm v ) => Proxy v - -> PinnedSizedBytes (SeedSizeDSIGNM v) + -> PinnedSizedBytes (SeedSizeDSIGN v) -> Property prop_key_overwritten_after_forget p seedPSB = ioProperty . withMLockedSeedFromPSB seedPSB $ \seed -> do @@ -553,7 +537,7 @@ prop_dsignm_seed_roundtrip ( DSIGNMAlgorithm v ) => Proxy v - -> PinnedSizedBytes (SeedSizeDSIGNM v) + -> PinnedSizedBytes (SeedSizeDSIGN v) -> Property prop_dsignm_seed_roundtrip p seedPSB = ioProperty . withMLockedSeedFromPSB seedPSB $ \seed -> do sk <- genKeyDSIGNM seed @@ -595,36 +579,36 @@ prop_dsign_verify_wrong_key (msg, sk, sk') = in verifyDSIGN () vk' msg signed =/= Right () prop_dsignm_verify_pos - :: forall v. (DSIGNMAlgorithm v, ContextDSIGNM v ~ (), SignableM v Message) + :: forall v. (DSIGNMAlgorithm v, ContextDSIGN v ~ (), Signable v Message) => Lock -> Proxy v -> Message - -> PinnedSizedBytes (SeedSizeDSIGNM v) + -> PinnedSizedBytes (SeedSizeDSIGN v) -> Property prop_dsignm_verify_pos lock _ msg = ioPropertyWithSK @v lock $ \sk -> do sig <- signDSIGNM () msg sk vk <- deriveVerKeyDSIGNM sk - return $ verifyDSIGNM () vk msg sig === Right () + return $ verifyDSIGN () vk msg sig === Right () -- | If we sign a message @a@ with one signing key, if we try to verify the -- signature (and message @a@) using a verification key corresponding to a -- different signing key, then the verification fails. -- prop_dsignm_verify_neg_key - :: forall v. (DSIGNMAlgorithm v, ContextDSIGNM v ~ (), SignableM v Message) + :: forall v. (DSIGNMAlgorithm v, ContextDSIGN v ~ (), Signable v Message) => Lock -> Proxy v -> Message - -> PinnedSizedBytes (SeedSizeDSIGNM v) - -> PinnedSizedBytes (SeedSizeDSIGNM v) + -> PinnedSizedBytes (SeedSizeDSIGN v) + -> PinnedSizedBytes (SeedSizeDSIGN v) -> Property prop_dsignm_verify_neg_key lock _ msg seedPSB seedPSB' = ioProperty . withLock lock $ do sig <- withSK @v seedPSB $ signDSIGNM () msg vk' <- withSK @v seedPSB' deriveVerKeyDSIGNM return $ - seedPSB /= seedPSB' ==> verifyDSIGNM () vk' msg sig =/= Right () + seedPSB /= seedPSB' ==> verifyDSIGN () vk' msg sig =/= Right () -- If we sign a message with a key, but then try to verify with a different -- message, then verification fails. @@ -682,18 +666,18 @@ testEcdsaWithHashAlgorithm _ name = adjustOption defaultTestEnough . testGroup n #endif prop_dsignm_verify_neg_msg - :: forall v. (DSIGNMAlgorithm v, ContextDSIGNM v ~ (), SignableM v Message) + :: forall v. (DSIGNMAlgorithm v, ContextDSIGN v ~ (), Signable v Message) => Lock -> Proxy v -> Message -> Message - -> PinnedSizedBytes (SeedSizeDSIGNM v) + -> PinnedSizedBytes (SeedSizeDSIGN v) -> Property prop_dsignm_verify_neg_msg lock _ a a' = ioPropertyWithSK @v lock $ \sk -> do sig <- signDSIGNM () a sk vk <- deriveVerKeyDSIGNM sk return $ - a /= a' ==> verifyDSIGNM () vk a' sig =/= Right () + a /= a' ==> verifyDSIGN () vk a' sig =/= Right () -- TODO: verify that DSIGN and DSIGNM implementations match (see #363) diff --git a/cardano-crypto-tests/src/Test/Crypto/EqST.hs b/cardano-crypto-tests/src/Test/Crypto/EqST.hs index 44fabcfdf..5dd4f2f85 100644 --- a/cardano-crypto-tests/src/Test/Crypto/EqST.hs +++ b/cardano-crypto-tests/src/Test/Crypto/EqST.hs @@ -12,8 +12,8 @@ import Control.Monad.Class.MonadST (MonadST) import Cardano.Crypto.Libsodium.MLockedBytes.Internal import Cardano.Crypto.Libsodium.MLockedSeed -import Cardano.Crypto.DSIGN.Ed25519ML -import Cardano.Crypto.DSIGNM.Class +import Cardano.Crypto.DSIGN.Ed25519 +import Cardano.Crypto.DSIGN.Class import Cardano.Crypto.KES.Simple -- | Monadic flavor of 'Eq', for things that can only be compared in a monadic @@ -76,8 +76,8 @@ deriving via instance KnownNat n => EqST (MLockedSeed n) -deriving via (MLockedSizedBytes (SizeSignKeyDSIGNM Ed25519DSIGNM)) - instance EqST (SignKeyDSIGNM Ed25519DSIGNM) +deriving via (MLockedSizedBytes (SizeSignKeyDSIGN Ed25519DSIGN)) + instance EqST (SignKeyDSIGNM Ed25519DSIGN) instance EqST (SignKeyDSIGNM d) => EqST (SignKeyKES (SimpleKES d t)) where equalsM (ThunkySignKeySimpleKES a) (ThunkySignKeySimpleKES b) = diff --git a/cardano-crypto-tests/src/Test/Crypto/KES.hs b/cardano-crypto-tests/src/Test/Crypto/KES.hs index 3b9b80780..fbe1612e7 100644 --- a/cardano-crypto-tests/src/Test/Crypto/KES.hs +++ b/cardano-crypto-tests/src/Test/Crypto/KES.hs @@ -81,25 +81,25 @@ import Test.Crypto.AllocLog tests :: Lock -> TestTree tests lock = testGroup "Crypto.KES" - [ testKESAlloc (Proxy @(SingleKES Ed25519DSIGNM)) "SingleKES" - , testKESAlloc (Proxy @(Sum1KES Ed25519DSIGNM Blake2b_256)) "Sum1KES" - , testKESAlloc (Proxy @(Sum2KES Ed25519DSIGNM Blake2b_256)) "Sum2KES" + [ testKESAlloc (Proxy @(SingleKES Ed25519DSIGN)) "SingleKES" + , testKESAlloc (Proxy @(Sum1KES Ed25519DSIGN Blake2b_256)) "Sum1KES" + , testKESAlloc (Proxy @(Sum2KES Ed25519DSIGN Blake2b_256)) "Sum2KES" , testKESAlgorithm @(MockKES 7) lock "MockKES" - , testKESAlgorithm @(SimpleKES Ed25519DSIGNM 7) lock "SimpleKES" - , testKESAlgorithm @(SingleKES Ed25519DSIGNM) lock "SingleKES" - , testKESAlgorithm @(Sum1KES Ed25519DSIGNM Blake2b_256) lock "Sum1KES" - , testKESAlgorithm @(Sum2KES Ed25519DSIGNM Blake2b_256) lock "Sum2KES" - , testKESAlgorithm @(Sum5KES Ed25519DSIGNM Blake2b_256) lock "Sum5KES" - , testKESAlgorithm @(CompactSum1KES Ed25519DSIGNM Blake2b_256) lock "CompactSum1KES" - , testKESAlgorithm @(CompactSum2KES Ed25519DSIGNM Blake2b_256) lock "CompactSum2KES" - , testKESAlgorithm @(CompactSum5KES Ed25519DSIGNM Blake2b_256) lock "CompactSum5KES" + , testKESAlgorithm @(SimpleKES Ed25519DSIGN 7) lock "SimpleKES" + , testKESAlgorithm @(SingleKES Ed25519DSIGN) lock "SingleKES" + , testKESAlgorithm @(Sum1KES Ed25519DSIGN Blake2b_256) lock "Sum1KES" + , testKESAlgorithm @(Sum2KES Ed25519DSIGN Blake2b_256) lock "Sum2KES" + , testKESAlgorithm @(Sum5KES Ed25519DSIGN Blake2b_256) lock "Sum5KES" + , testKESAlgorithm @(CompactSum1KES Ed25519DSIGN Blake2b_256) lock "CompactSum1KES" + , testKESAlgorithm @(CompactSum2KES Ed25519DSIGN Blake2b_256) lock "CompactSum2KES" + , testKESAlgorithm @(CompactSum5KES Ed25519DSIGN Blake2b_256) lock "CompactSum5KES" ] -- We normally ensure that we avoid naively comparing signing keys by not -- providing instances, but for tests it is fine, so we provide the orphan -- instances here. -instance Show (SignKeyKES (SingleKES Ed25519DSIGNM)) where +instance Show (SignKeyKES (SingleKES Ed25519DSIGN)) where show (SignKeySingleKES (SignKeyEd25519DSIGNM mlsb)) = let bytes = mlsbAsByteString mlsb hexstr = hexBS bytes @@ -108,7 +108,7 @@ instance Show (SignKeyKES (SingleKES Ed25519DSIGNM)) where instance Show (SignKeyKES (SumKES h d)) where show _ = "" -instance Show (SignKeyKES (CompactSingleKES Ed25519DSIGNM)) where +instance Show (SignKeyKES (CompactSingleKES Ed25519DSIGN)) where show (SignKeyCompactSingleKES (SignKeyEd25519DSIGNM mlsb)) = let bytes = mlsbAsByteString mlsb hexstr = hexBS bytes @@ -139,7 +139,7 @@ instance ( EqST (SignKeyKES d) testKESAlloc :: forall v. - ( KESSignAlgorithm v + ( KESAlgorithm v ) => Proxy v -> String @@ -164,7 +164,7 @@ matchAllocLog = foldl' (flip go) Set.empty testMLockGenKeyKES :: forall v. - KESSignAlgorithm v + KESAlgorithm v => Proxy v -> Assertion testMLockGenKeyKES _p = do @@ -197,7 +197,7 @@ testKESAlgorithm , FromCBOR (SigKES v) , Signable v ~ SignableRepresentation , ContextKES v ~ () - , UnsoundKESSignAlgorithm v + , UnsoundKESAlgorithm v ) => Lock -> String @@ -342,7 +342,7 @@ testKESAlgorithm lock n = -- timely forgetting. Special care must be taken to not leak the key outside of -- the wrapped action (be particularly mindful of thunks and unsafe key access -- here). -withSK :: KESSignAlgorithm v +withSK :: KESAlgorithm v => PinnedSizedBytes (SeedSizeKES v) -> (SignKeyKES v -> IO b) -> IO b withSK seedPSB = bracket @@ -356,7 +356,7 @@ withSK seedPSB = -- memory. Special care must be taken to not leak the key outside of the -- wrapped action (be particularly mindful of thunks and unsafe key access -- here). -ioPropertyWithSK :: forall v a. (Testable a, KESSignAlgorithm v) +ioPropertyWithSK :: forall v a. (Testable a, KESAlgorithm v) => Lock -> (SignKeyKES v -> IO a) -> PinnedSizedBytes (SeedSizeKES v) @@ -370,7 +370,7 @@ ioPropertyWithSK lock action seedPSB = -- forgetting won't actually erase the key -- prop_key_overwritten_after_forget -- :: forall v. --- (KESSignAlgorithm IO v +-- (KESAlgorithm IO v -- ) -- => Proxy v -- -> PinnedSizedBytes (SeedSizeKES v) @@ -389,14 +389,14 @@ ioPropertyWithSK lock action seedPSB = prop_onlyGenSignKeyKES :: forall v. - KESSignAlgorithm v + KESAlgorithm v => Lock -> PinnedSizedBytes (SeedSizeKES v) -> Property prop_onlyGenSignKeyKES lock = ioPropertyWithSK @v lock $ const noExceptionsThrown prop_onlyGenVerKeyKES :: forall v. - KESSignAlgorithm v + KESAlgorithm v => Lock -> PinnedSizedBytes (SeedSizeKES v) -> Property prop_onlyGenVerKeyKES lock = ioPropertyWithSK @v lock $ doesNotThrow . deriveVerKeyKES @@ -404,7 +404,7 @@ prop_onlyGenVerKeyKES lock = prop_oneUpdateSignKeyKES :: forall v. ( ContextKES v ~ () - , KESSignAlgorithm v + , KESAlgorithm v ) => Lock -> PinnedSizedBytes (SeedSizeKES v) -> Property prop_oneUpdateSignKeyKES lock seedPSB = @@ -418,7 +418,7 @@ prop_oneUpdateSignKeyKES lock seedPSB = prop_allUpdatesSignKeyKES :: forall v. ( ContextKES v ~ () - , KESSignAlgorithm v + , KESAlgorithm v ) => Lock -> PinnedSizedBytes (SeedSizeKES v) -> Property prop_allUpdatesSignKeyKES lock seedPSB = @@ -432,7 +432,7 @@ prop_allUpdatesSignKeyKES lock seedPSB = prop_totalPeriodsKES :: forall v. ( ContextKES v ~ () - , KESSignAlgorithm v + , KESAlgorithm v ) => Lock -> PinnedSizedBytes (SeedSizeKES v) -> Property prop_totalPeriodsKES lock seed = @@ -454,7 +454,7 @@ prop_totalPeriodsKES lock seed = prop_deriveVerKeyKES :: forall v. ( ContextKES v ~ () - , KESSignAlgorithm v + , KESAlgorithm v ) => PinnedSizedBytes (SeedSizeKES v) -> Property prop_deriveVerKeyKES seedPSB = @@ -479,7 +479,7 @@ prop_verifyKES_positive :: forall v. ( ContextKES v ~ () , Signable v ~ SignableRepresentation - , KESSignAlgorithm v + , KESAlgorithm v ) => PinnedSizedBytes (SeedSizeKES v) -> Gen Property prop_verifyKES_positive seedPSB = do @@ -511,7 +511,7 @@ prop_verifyKES_negative_key :: forall v. ( ContextKES v ~ () , Signable v ~ SignableRepresentation - , KESSignAlgorithm v + , KESAlgorithm v ) => PinnedSizedBytes (SeedSizeKES v) -> PinnedSizedBytes (SeedSizeKES v) @@ -537,7 +537,7 @@ prop_verifyKES_negative_message :: forall v. ( ContextKES v ~ () , Signable v ~ SignableRepresentation - , KESSignAlgorithm v + , KESAlgorithm v ) => PinnedSizedBytes (SeedSizeKES v) -> Message -> Message @@ -563,7 +563,7 @@ prop_verifyKES_negative_period :: forall v. ( ContextKES v ~ () , Signable v ~ SignableRepresentation - , KESSignAlgorithm v + , KESAlgorithm v ) => PinnedSizedBytes (SeedSizeKES v) -> Message @@ -592,7 +592,7 @@ prop_verifyKES_negative_period seedPSB x = prop_serialise_VerKeyKES :: forall v. ( ContextKES v ~ () - , KESSignAlgorithm v + , KESAlgorithm v ) => PinnedSizedBytes (SeedSizeKES v) -> Property @@ -618,7 +618,7 @@ prop_serialise_SigKES ( ContextKES v ~ () , Signable v ~ SignableRepresentation , Show (SignKeyKES v) - , KESSignAlgorithm v + , KESAlgorithm v ) => PinnedSizedBytes (SeedSizeKES v) -> Message @@ -643,7 +643,7 @@ prop_serialise_SigKES seedPSB x = -- withAllUpdatesKES_ :: forall v a. - ( KESSignAlgorithm v + ( KESAlgorithm v , ContextKES v ~ () ) => PinnedSizedBytes (SeedSizeKES v) @@ -653,7 +653,7 @@ withAllUpdatesKES_ seedPSB f = do withAllUpdatesKES seedPSB (const f) withAllUpdatesKES :: forall v a. - ( KESSignAlgorithm v + ( KESAlgorithm v , ContextKES v ~ () ) => PinnedSizedBytes (SeedSizeKES v) From 6552416e4257c5acffc0eb9579773e4802de0107 Mon Sep 17 00:00:00 2001 From: Tobias Dammers Date: Tue, 18 Apr 2023 13:58:35 +0200 Subject: [PATCH 41/75] SignKeyWithPeriod type --- .../src/Cardano/Crypto/KES/Class.hs | 29 +++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/cardano-crypto-class/src/Cardano/Crypto/KES/Class.hs b/cardano-crypto-class/src/Cardano/Crypto/KES/Class.hs index afeda1b76..81cb10aac 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/KES/Class.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/KES/Class.hs @@ -24,6 +24,10 @@ module Cardano.Crypto.KES.Class , OptimizedKESAlgorithm (..) , verifyOptimizedKES + -- * 'SignKeyWithPeriodKES' wrapper + , SignKeyWithPeriodKES (..) + , updateKESWithPeriod + -- * 'SignedKES' wrapper , SignedKES (..) , signedKES @@ -77,6 +81,7 @@ import GHC.TypeLits (Nat, KnownNat, natVal, TypeError, ErrorMessage (..)) import NoThunks.Class (NoThunks) import Control.Monad.Class.MonadST (MonadST) import Control.Monad.Class.MonadThrow (MonadThrow) +import Control.Monad.Trans.Maybe (MaybeT (..), runMaybeT) import Cardano.Binary (Decoder, decodeBytes, Encoding, encodeBytes, Size, withWordSize) @@ -437,6 +442,30 @@ decodeSignedKES :: KESAlgorithm v => Decoder s (SignedKES v a) decodeSignedKES = SignedKES <$> decodeSigKES {-# INLINE decodeSignedKES #-} +-- | A sign key bundled with its associated period. +data SignKeyWithPeriodKES v = + SignKeyWithPeriodKES + { skWithoutPeriodKES :: !(SignKeyKES v) + , periodKES :: !Period + } + deriving (Generic) + +deriving instance (KESAlgorithm v, Eq (SignKeyKES v)) => Eq (SignKeyWithPeriodKES v) + +deriving instance (KESAlgorithm v, Show (SignKeyKES v)) => Show (SignKeyWithPeriodKES v) + +instance KESAlgorithm v => NoThunks (SignKeyWithPeriodKES v) + -- use generic instance + +updateKESWithPeriod + :: (KESAlgorithm v, MonadST m, MonadThrow m) + => ContextKES v + -> SignKeyWithPeriodKES v + -> m (Maybe (SignKeyWithPeriodKES v)) +updateKESWithPeriod c (SignKeyWithPeriodKES sk t) = runMaybeT $ do + sk' <- MaybeT $ updateKES c sk t + return $ SignKeyWithPeriodKES sk' (succ t) + -- -- 'Size' expressions for 'ToCBOR' instances. -- From 49368f86e8c206ee30771ec2ed8b190586fea6bd Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Tue, 5 Sep 2023 20:11:57 +0400 Subject: [PATCH 42/75] Add `FromCBOR` instance for `TermToken` --- cardano-binary/CHANGELOG.md | 4 ++-- cardano-binary/cardano-binary.cabal | 2 +- cardano-binary/src/Cardano/Binary/FromCBOR.hs | 5 +++++ 3 files changed, 8 insertions(+), 3 deletions(-) diff --git a/cardano-binary/CHANGELOG.md b/cardano-binary/CHANGELOG.md index 1172532f2..29508b310 100644 --- a/cardano-binary/CHANGELOG.md +++ b/cardano-binary/CHANGELOG.md @@ -1,8 +1,8 @@ # Changelog for `cardano-binary` -## 1.7.0.2 +## 1.7.1.0 -* +* Add `FromCBOR` instance for `TermToken` ## 1.7.0.1 diff --git a/cardano-binary/cardano-binary.cabal b/cardano-binary/cardano-binary.cabal index 959cc093f..c96872666 100644 --- a/cardano-binary/cardano-binary.cabal +++ b/cardano-binary/cardano-binary.cabal @@ -1,7 +1,7 @@ cabal-version: 2.2 name: cardano-binary -version: 1.7.0.1 +version: 1.7.1.0 synopsis: Binary serialization for Cardano description: This package includes the binary serialization format for Cardano license: Apache-2.0 diff --git a/cardano-binary/src/Cardano/Binary/FromCBOR.hs b/cardano-binary/src/Cardano/Binary/FromCBOR.hs index bd089b0e7..e6ac5c951 100644 --- a/cardano-binary/src/Cardano/Binary/FromCBOR.hs +++ b/cardano-binary/src/Cardano/Binary/FromCBOR.hs @@ -33,6 +33,7 @@ import Prelude hiding ((.)) import Codec.CBOR.Decoding as D import Codec.CBOR.ByteArray as BA ( ByteArray(BA) ) import Codec.CBOR.Term +import Codec.CBOR.FlatTerm import Control.Category (Category((.))) import Control.Exception (Exception) import Control.Monad (when, replicateM) @@ -78,6 +79,10 @@ class Typeable a => FromCBOR a where instance FromCBOR Term where fromCBOR = decodeTerm +instance FromCBOR TermToken where + fromCBOR = decodeTermToken + + -------------------------------------------------------------------------------- -- DecoderError -------------------------------------------------------------------------------- From 897a8c5737fa27f28d018f27431e01cd98cb2409 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Fri, 26 May 2023 15:27:22 +0300 Subject: [PATCH 43/75] Increase lower bound on the `cborg` package There is an important bug fix that we'd like to ensure we avoid: https://github.com/well-typed/cborg/pull/301 --- cardano-binary/cardano-binary.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cardano-binary/cardano-binary.cabal b/cardano-binary/cardano-binary.cabal index c96872666..18585ce8a 100644 --- a/cardano-binary/cardano-binary.cabal +++ b/cardano-binary/cardano-binary.cabal @@ -41,7 +41,7 @@ library build-depends: base , bytestring - , cborg >= 0.2.2 && < 0.3 + , cborg >= 0.2.9 && < 0.3 , containers , data-fix , formatting From bb54acd9fad4a16a8e74b3107fc5d6636911a5c5 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Tue, 7 Nov 2023 11:48:49 +0100 Subject: [PATCH 44/75] strict-checked-vars: relaxed bounds io-sim-1.3.0.0 --- cabal.project | 2 +- flake.lock | 6 +++--- strict-checked-vars/strict-checked-vars.cabal | 6 +++--- 3 files changed, 7 insertions(+), 7 deletions(-) diff --git a/cabal.project b/cabal.project index c23617ad7..a04622a62 100644 --- a/cabal.project +++ b/cabal.project @@ -10,7 +10,7 @@ repository cardano-haskell-packages d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee -- The hackage index-state -index-state: 2023-10-05T21:19:55Z +index-state: 2023-11-08T09:44:54Z -- The CHaP index-state index-state: cardano-haskell-packages 2023-10-05T20:34:14Z diff --git a/flake.lock b/flake.lock index 8ef042851..102eae1f2 100644 --- a/flake.lock +++ b/flake.lock @@ -343,11 +343,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1690676776, - "narHash": "sha256-6z8zYs1b4ZZWSM58H41TtfM7bKEqjFW2xaCSCJUbBHk=", + "lastModified": 1699402991, + "narHash": "sha256-2nQBlA3ygBiIqVPh2J1JwP51rEO0xMjyoOaoJk5PboY=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "a21057809f37315eaba0188d8a737ababcaba7f5", + "rev": "9e963602a5b3259dac9cf5e994f0a338fb352b7e", "type": "github" }, "original": { diff --git a/strict-checked-vars/strict-checked-vars.cabal b/strict-checked-vars/strict-checked-vars.cabal index 8648d80e0..0514eb825 100644 --- a/strict-checked-vars/strict-checked-vars.cabal +++ b/strict-checked-vars/strict-checked-vars.cabal @@ -52,9 +52,9 @@ library default-language: Haskell2010 build-depends: , base >=4.9 && <5 - , io-classes ^>=1.2 - , strict-mvar ^>=1.2 - , strict-stm ^>=1.2 + , io-classes >=1.2 && <1.4 + , strict-mvar >=1.2 && <1.4 + , strict-stm >=1.2 && <1.4 ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns From 0dcf53b82b52bc4c92b18c6fdfd5c62596419b51 Mon Sep 17 00:00:00 2001 From: Marcin Szamotulski Date: Wed, 8 Nov 2023 16:04:17 +0100 Subject: [PATCH 45/75] Fixed nix --- flake.lock | 675 +++++++++++------------------------------------------ flake.nix | 2 +- 2 files changed, 140 insertions(+), 537 deletions(-) diff --git a/flake.lock b/flake.lock index 102eae1f2..04841c9ee 100644 --- a/flake.lock +++ b/flake.lock @@ -33,21 +33,6 @@ "type": "github" } }, - "blank": { - "locked": { - "lastModified": 1625557891, - "narHash": "sha256-O8/MWsPBGhhyPoPLHZAuoZiiHo9q6FLlEeIDEXuj6T4=", - "owner": "divnix", - "repo": "blank", - "rev": "5a5d2684073d9f563072ed07c871d577a6c614a8", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "blank", - "type": "github" - } - }, "blst": { "flake": false, "locked": { @@ -132,64 +117,6 @@ "type": "github" } }, - "devshell": { - "inputs": { - "flake-utils": [ - "haskellNix", - "tullia", - "std", - "flake-utils" - ], - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1663445644, - "narHash": "sha256-+xVlcK60x7VY1vRJbNUEAHi17ZuoQxAIH4S4iUFUGBA=", - "owner": "numtide", - "repo": "devshell", - "rev": "e3dc3e21594fe07bdb24bdf1c8657acaa4cb8f66", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "devshell", - "type": "github" - } - }, - "dmerge": { - "inputs": { - "nixlib": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ], - "yants": [ - "haskellNix", - "tullia", - "std", - "yants" - ] - }, - "locked": { - "lastModified": 1659548052, - "narHash": "sha256-fzI2gp1skGA8mQo/FBFrUAtY0GQkAIAaV/V127TJPyY=", - "owner": "divnix", - "repo": "data-merge", - "rev": "d160d18ce7b1a45b88344aa3f13ed1163954b497", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "data-merge", - "type": "github" - } - }, "flake-compat": { "flake": false, "locked": { @@ -223,22 +150,6 @@ "type": "github" } }, - "flake-compat_3": { - "flake": false, - "locked": { - "lastModified": 1650374568, - "narHash": "sha256-Z+s0J8/r907g149rllvwhb4pKi8Wam5ij0st8PwAh+E=", - "owner": "edolstra", - "repo": "flake-compat", - "rev": "b4a34015c698c7793d592d66adbab377907a2be8", - "type": "github" - }, - "original": { - "owner": "edolstra", - "repo": "flake-compat", - "type": "github" - } - }, "flake-utils": { "inputs": { "systems": "systems" @@ -258,52 +169,6 @@ "type": "github" } }, - "flake-utils_2": { - "locked": { - "lastModified": 1679360468, - "narHash": "sha256-LGnza3cfXF10Biw3ZTg0u9o9t7s680Ww200t5KkHTh8=", - "owner": "hamishmack", - "repo": "flake-utils", - "rev": "e1ea268ff47ad475443dbabcd54744b4e5b9d4f5", - "type": "github" - }, - "original": { - "owner": "hamishmack", - "ref": "hkm/nested-hydraJobs", - "repo": "flake-utils", - "type": "github" - } - }, - "flake-utils_3": { - "locked": { - "lastModified": 1653893745, - "narHash": "sha256-0jntwV3Z8//YwuOjzhV2sgJJPt+HY6KhU7VZUL0fKZQ=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "1ed9fb1935d260de5fe1c2f7ee0ebaae17ed2fa1", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "flake-utils_4": { - "locked": { - "lastModified": 1659877975, - "narHash": "sha256-zllb8aq3YO3h8B/U0/J1WBgAL8EX5yWf5pMj3G0NAmc=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "c0e246b9b83f637f4681389ecabcb2681b4f3af0", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, "ghc-8.6.5-iohk": { "flake": false, "locked": { @@ -321,23 +186,41 @@ "type": "github" } }, - "gomod2nix": { - "inputs": { - "nixpkgs": "nixpkgs_2", - "utils": "utils" + "ghc98X": { + "flake": false, + "locked": { + "lastModified": 1696643148, + "narHash": "sha256-E02DfgISH7EvvNAu0BHiPvl1E5FGMDi0pWdNZtIBC9I=", + "ref": "ghc-9.8", + "rev": "443e870d977b1ab6fc05f47a9a17bc49296adbd6", + "revCount": 61642, + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" }, + "original": { + "ref": "ghc-9.8", + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" + } + }, + "ghc99": { + "flake": false, "locked": { - "lastModified": 1655245309, - "narHash": "sha256-d/YPoQ/vFn1+GTmSdvbSBSTOai61FONxB4+Lt6w/IVI=", - "owner": "tweag", - "repo": "gomod2nix", - "rev": "40d32f82fc60d66402eb0972e6e368aeab3faf58", - "type": "github" + "lastModified": 1697054644, + "narHash": "sha256-kKarOuXUaAH3QWv7ASx+gGFMHaHKe0pK5Zu37ky2AL4=", + "ref": "refs/heads/master", + "rev": "f383a242c76f90bcca8a4d7ee001dcb49c172a9a", + "revCount": 62040, + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" }, "original": { - "owner": "tweag", - "repo": "gomod2nix", - "type": "github" + "submodules": true, + "type": "git", + "url": "https://gitlab.haskell.org/ghc/ghc" } }, "hackage": { @@ -364,10 +247,15 @@ "cabal-36": "cabal-36", "cardano-shell": "cardano-shell", "flake-compat": "flake-compat_2", - "flake-utils": "flake-utils_2", "ghc-8.6.5-iohk": "ghc-8.6.5-iohk", + "ghc98X": "ghc98X", + "ghc99": "ghc99", "hackage": "hackage", "hls-1.10": "hls-1.10", + "hls-2.0": "hls-2.0", + "hls-2.2": "hls-2.2", + "hls-2.3": "hls-2.3", + "hls-2.4": "hls-2.4", "hpc-coveralls": "hpc-coveralls", "hydra": "hydra", "iserv-proxy": "iserv-proxy", @@ -380,17 +268,17 @@ "nixpkgs-2111": "nixpkgs-2111", "nixpkgs-2205": "nixpkgs-2205", "nixpkgs-2211": "nixpkgs-2211", + "nixpkgs-2305": "nixpkgs-2305", "nixpkgs-unstable": "nixpkgs-unstable", "old-ghc-nix": "old-ghc-nix", - "stackage": "stackage", - "tullia": "tullia" + "stackage": "stackage" }, "locked": { - "lastModified": 1682124656, - "narHash": "sha256-GFZGXgxcSqHWQRnDZpW7rJY+/mhQf4d8DSywyej3rLY=", + "lastModified": 1699404571, + "narHash": "sha256-EwI7vKBxCHvIKPWbvGlOF9IZlSFqPODgT/BQy8Z2s/w=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "ac10620827a1d59ae28a8f4b3f42ee2319005222", + "rev": "cec253ca482301509e9e90cb5c15299dd3550cce", "type": "github" }, "original": { @@ -416,6 +304,74 @@ "type": "github" } }, + "hls-2.0": { + "flake": false, + "locked": { + "lastModified": 1687698105, + "narHash": "sha256-OHXlgRzs/kuJH8q7Sxh507H+0Rb8b7VOiPAjcY9sM1k=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "783905f211ac63edf982dd1889c671653327e441", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.0.0.1", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.2": { + "flake": false, + "locked": { + "lastModified": 1693064058, + "narHash": "sha256-8DGIyz5GjuCFmohY6Fa79hHA/p1iIqubfJUTGQElbNk=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "b30f4b6cf5822f3112c35d14a0cba51f3fe23b85", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.2.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.3": { + "flake": false, + "locked": { + "lastModified": 1695910642, + "narHash": "sha256-tR58doOs3DncFehHwCLczJgntyG/zlsSd7DgDgMPOkI=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "458ccdb55c9ea22cd5d13ec3051aaefb295321be", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.3.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, + "hls-2.4": { + "flake": false, + "locked": { + "lastModified": 1696939266, + "narHash": "sha256-VOMf5+kyOeOmfXTHlv4LNFJuDGa7G3pDnOxtzYR40IU=", + "owner": "haskell", + "repo": "haskell-language-server", + "rev": "362fdd1293efb4b82410b676ab1273479f6d17ee", + "type": "github" + }, + "original": { + "owner": "haskell", + "ref": "2.4.0.0", + "repo": "haskell-language-server", + "type": "github" + } + }, "hpc-coveralls": { "flake": false, "locked": { @@ -455,33 +411,10 @@ "type": "indirect" } }, - "incl": { - "inputs": { - "nixlib": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1669263024, - "narHash": "sha256-E/+23NKtxAqYG/0ydYgxlgarKnxmDbg6rCMWnOBqn9Q=", - "owner": "divnix", - "repo": "incl", - "rev": "ce7bebaee048e4cd7ebdb4cee7885e00c4e2abca", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "incl", - "type": "github" - } - }, "iohkNix": { "inputs": { "blst": "blst", - "nixpkgs": "nixpkgs_5", + "nixpkgs": "nixpkgs_2", "secp256k1": "secp256k1", "sodium": "sodium" }, @@ -502,11 +435,11 @@ "iserv-proxy": { "flake": false, "locked": { - "lastModified": 1670983692, - "narHash": "sha256-avLo34JnI9HNyOuauK5R69usJm+GfW3MlyGlYxZhTgY=", + "lastModified": 1691634696, + "narHash": "sha256-MZH2NznKC/gbgBu8NgIibtSUZeJ00HTLJ0PlWKCBHb0=", "ref": "hkm/remote-iserv", - "rev": "50d0abb3317ac439a4e7495b185a64af9b7b9300", - "revCount": 10, + "rev": "43a979272d9addc29fbffc2e8542c5d96e993d73", + "revCount": 14, "type": "git", "url": "https://gitlab.haskell.org/hamishmack/iserv-proxy.git" }, @@ -532,35 +465,6 @@ "type": "github" } }, - "n2c": { - "inputs": { - "flake-utils": [ - "haskellNix", - "tullia", - "std", - "flake-utils" - ], - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1677330646, - "narHash": "sha256-hUYCwJneMjnxTvj30Fjow6UMJUITqHlpUGpXMPXUJsU=", - "owner": "nlewo", - "repo": "nix2container", - "rev": "ebca8f58d450cae1a19c07701a5a8ae40afc9efc", - "type": "github" - }, - "original": { - "owner": "nlewo", - "repo": "nix2container", - "type": "github" - } - }, "nix": { "inputs": { "lowdown-src": "lowdown-src", @@ -582,95 +486,6 @@ "type": "github" } }, - "nix-nomad": { - "inputs": { - "flake-compat": "flake-compat_3", - "flake-utils": [ - "haskellNix", - "tullia", - "nix2container", - "flake-utils" - ], - "gomod2nix": "gomod2nix", - "nixpkgs": [ - "haskellNix", - "tullia", - "nixpkgs" - ], - "nixpkgs-lib": [ - "haskellNix", - "tullia", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1658277770, - "narHash": "sha256-T/PgG3wUn8Z2rnzfxf2VqlR1CBjInPE0l1yVzXxPnt0=", - "owner": "tristanpemble", - "repo": "nix-nomad", - "rev": "054adcbdd0a836ae1c20951b67ed549131fd2d70", - "type": "github" - }, - "original": { - "owner": "tristanpemble", - "repo": "nix-nomad", - "type": "github" - } - }, - "nix2container": { - "inputs": { - "flake-utils": "flake-utils_3", - "nixpkgs": "nixpkgs_3" - }, - "locked": { - "lastModified": 1658567952, - "narHash": "sha256-XZ4ETYAMU7XcpEeAFP3NOl9yDXNuZAen/aIJ84G+VgA=", - "owner": "nlewo", - "repo": "nix2container", - "rev": "60bb43d405991c1378baf15a40b5811a53e32ffa", - "type": "github" - }, - "original": { - "owner": "nlewo", - "repo": "nix2container", - "type": "github" - } - }, - "nixago": { - "inputs": { - "flake-utils": [ - "haskellNix", - "tullia", - "std", - "flake-utils" - ], - "nixago-exts": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1676075813, - "narHash": "sha256-X/aIT8Qc8UCqnxJvaZykx3CJ0ZnDFvO+dqp/7fglZWo=", - "owner": "nix-community", - "repo": "nixago", - "rev": "9cab4dde31ec2f2c05d702ea8648ce580664e906", - "type": "github" - }, - "original": { - "owner": "nix-community", - "repo": "nixago", - "type": "github" - } - }, "nixpkgs": { "locked": { "lastModified": 1657693803, @@ -737,11 +552,11 @@ }, "nixpkgs-2205": { "locked": { - "lastModified": 1672580127, - "narHash": "sha256-3lW3xZslREhJogoOkjeZtlBtvFMyxHku7I/9IVehhT8=", + "lastModified": 1685573264, + "narHash": "sha256-Zffu01pONhs/pqH07cjlF10NnMDLok8ix5Uk4rhOnZQ=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "0874168639713f547c05947c76124f78441ea46c", + "rev": "380be19fbd2d9079f677978361792cb25e8a3635", "type": "github" }, "original": { @@ -753,11 +568,11 @@ }, "nixpkgs-2211": { "locked": { - "lastModified": 1675730325, - "narHash": "sha256-uNvD7fzO5hNlltNQUAFBPlcEjNG5Gkbhl/ROiX+GZU4=", + "lastModified": 1688392541, + "narHash": "sha256-lHrKvEkCPTUO+7tPfjIcb7Trk6k31rz18vkyqmkeJfY=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "b7ce17b1ebf600a72178f6302c77b6382d09323f", + "rev": "ea4c80b39be4c09702b0cb3b42eab59e2ba4f24b", "type": "github" }, "original": { @@ -767,86 +582,55 @@ "type": "github" } }, - "nixpkgs-regression": { + "nixpkgs-2305": { "locked": { - "lastModified": 1643052045, - "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", + "lastModified": 1695416179, + "narHash": "sha256-610o1+pwbSu+QuF3GE0NU5xQdTHM3t9wyYhB9l94Cd8=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", + "rev": "715d72e967ec1dd5ecc71290ee072bcaf5181ed6", "type": "github" }, "original": { "owner": "NixOS", + "ref": "nixpkgs-23.05-darwin", "repo": "nixpkgs", - "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", "type": "github" } }, - "nixpkgs-unstable": { - "locked": { - "lastModified": 1675758091, - "narHash": "sha256-7gFSQbSVAFUHtGCNHPF7mPc5CcqDk9M2+inlVPZSneg=", - "owner": "NixOS", - "repo": "nixpkgs", - "rev": "747927516efcb5e31ba03b7ff32f61f6d47e7d87", - "type": "github" - }, - "original": { - "owner": "NixOS", - "ref": "nixpkgs-unstable", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs_2": { + "nixpkgs-regression": { "locked": { - "lastModified": 1653581809, - "narHash": "sha256-Uvka0V5MTGbeOfWte25+tfRL3moECDh1VwokWSZUdoY=", + "lastModified": 1643052045, + "narHash": "sha256-uGJ0VXIhWKGXxkeNnq4TvV3CIOkUJ3PAoLZ3HMzNVMw=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "83658b28fe638a170a19b8933aa008b30640fbd1", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", "type": "github" }, "original": { "owner": "NixOS", - "ref": "nixos-unstable", "repo": "nixpkgs", + "rev": "215d4d0fd80ca5163643b03a33fde804a29cc1e2", "type": "github" } }, - "nixpkgs_3": { + "nixpkgs-unstable": { "locked": { - "lastModified": 1654807842, - "narHash": "sha256-ADymZpr6LuTEBXcy6RtFHcUZdjKTBRTMYwu19WOx17E=", + "lastModified": 1695318763, + "narHash": "sha256-FHVPDRP2AfvsxAdc+AsgFJevMz5VBmnZglFUMlxBkcY=", "owner": "NixOS", "repo": "nixpkgs", - "rev": "fc909087cc3386955f21b4665731dbdaceefb1d8", + "rev": "e12483116b3b51a185a33a272bf351e357ba9a99", "type": "github" }, "original": { "owner": "NixOS", - "repo": "nixpkgs", - "type": "github" - } - }, - "nixpkgs_4": { - "locked": { - "lastModified": 1675940568, - "narHash": "sha256-epG6pOT9V0kS+FUqd7R6/CWkgnZx2DMT5Veqo+y6G3c=", - "owner": "nixos", - "repo": "nixpkgs", - "rev": "6ccc4a59c3f1b56d039d93da52696633e641bc71", - "type": "github" - }, - "original": { - "owner": "nixos", "ref": "nixpkgs-unstable", "repo": "nixpkgs", "type": "github" } }, - "nixpkgs_5": { + "nixpkgs_2": { "locked": { "lastModified": 1684171562, "narHash": "sha256-BMUWjVWAUdyMWKk0ATMC9H0Bv4qAV/TXwwPUvTiC5IQ=", @@ -862,21 +646,6 @@ "type": "github" } }, - "nosys": { - "locked": { - "lastModified": 1668010795, - "narHash": "sha256-JBDVBnos8g0toU7EhIIqQ1If5m/nyBqtHhL3sicdPwI=", - "owner": "divnix", - "repo": "nosys", - "rev": "feade0141487801c71ff55623b421ed535dbdefa", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "nosys", - "type": "github" - } - }, "old-ghc-nix": { "flake": false, "locked": { @@ -894,64 +663,6 @@ "type": "github" } }, - "paisano": { - "inputs": { - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ], - "nosys": "nosys", - "yants": [ - "haskellNix", - "tullia", - "std", - "yants" - ] - }, - "locked": { - "lastModified": 1677437285, - "narHash": "sha256-YGfMothgUq1T9wMJYEhOSvdIiD/8gLXO1YcZA6hyIWU=", - "owner": "paisano-nix", - "repo": "core", - "rev": "5f2fc05e98e001cb1cf9535ded09e05d90cec131", - "type": "github" - }, - "original": { - "owner": "paisano-nix", - "repo": "core", - "type": "github" - } - }, - "paisano-tui": { - "inputs": { - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "std": [ - "haskellNix", - "tullia", - "std" - ] - }, - "locked": { - "lastModified": 1677533603, - "narHash": "sha256-Nq1dH/qn7Wg/Tj1+id+ZM3o0fzqonW73jAgY3mCp35M=", - "owner": "paisano-nix", - "repo": "tui", - "rev": "802958d123b0a5437441be0cab1dee487b0ed3eb", - "type": "github" - }, - "original": { - "owner": "paisano-nix", - "repo": "tui", - "type": "github" - } - }, "root": { "inputs": { "CHaP": "CHaP", @@ -1002,11 +713,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1682122158, - "narHash": "sha256-ja3xcKc/KZmGw5bC0w/J51eJyzhmqIy1b7SMvku51tg=", + "lastModified": 1699402155, + "narHash": "sha256-fOywUFLuAuZAkIrv1JdjGzfY53uEiMRlu8UpdJtCjh0=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "ac8c5de753931eaf9a8cc1ef310cf8d8db0430fa", + "rev": "7c7bfe8cca23c96b850e16f3c0b159aca1850314", "type": "github" }, "original": { @@ -1015,52 +726,6 @@ "type": "github" } }, - "std": { - "inputs": { - "arion": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "blank": "blank", - "devshell": "devshell", - "dmerge": "dmerge", - "flake-utils": "flake-utils_4", - "incl": "incl", - "makes": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "microvm": [ - "haskellNix", - "tullia", - "std", - "blank" - ], - "n2c": "n2c", - "nixago": "nixago", - "nixpkgs": "nixpkgs_4", - "paisano": "paisano", - "paisano-tui": "paisano-tui", - "yants": "yants" - }, - "locked": { - "lastModified": 1677533652, - "narHash": "sha256-H37dcuWAGZs6Yl9mewMNVcmSaUXR90/bABYFLT/nwhk=", - "owner": "divnix", - "repo": "std", - "rev": "490542f624412662e0411d8cb5a9af988ef56633", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "std", - "type": "github" - } - }, "systems": { "locked": { "lastModified": 1681028828, @@ -1075,68 +740,6 @@ "repo": "default", "type": "github" } - }, - "tullia": { - "inputs": { - "nix-nomad": "nix-nomad", - "nix2container": "nix2container", - "nixpkgs": [ - "haskellNix", - "nixpkgs" - ], - "std": "std" - }, - "locked": { - "lastModified": 1684859161, - "narHash": "sha256-wOKutImA7CRL0rN+Ng80E72fD5FkVub7LLP2k9NICpg=", - "owner": "input-output-hk", - "repo": "tullia", - "rev": "2964cff1a16eefe301bdddb508c49d94d04603d6", - "type": "github" - }, - "original": { - "owner": "input-output-hk", - "repo": "tullia", - "type": "github" - } - }, - "utils": { - "locked": { - "lastModified": 1653893745, - "narHash": "sha256-0jntwV3Z8//YwuOjzhV2sgJJPt+HY6KhU7VZUL0fKZQ=", - "owner": "numtide", - "repo": "flake-utils", - "rev": "1ed9fb1935d260de5fe1c2f7ee0ebaae17ed2fa1", - "type": "github" - }, - "original": { - "owner": "numtide", - "repo": "flake-utils", - "type": "github" - } - }, - "yants": { - "inputs": { - "nixpkgs": [ - "haskellNix", - "tullia", - "std", - "nixpkgs" - ] - }, - "locked": { - "lastModified": 1667096281, - "narHash": "sha256-wRRec6ze0gJHmGn6m57/zhz/Kdvp9HS4Nl5fkQ+uIuA=", - "owner": "divnix", - "repo": "yants", - "rev": "d18f356ec25cb94dc9c275870c3a7927a10f8c3c", - "type": "github" - }, - "original": { - "owner": "divnix", - "repo": "yants", - "type": "github" - } } }, "root": "root", diff --git a/flake.nix b/flake.nix index 4f7bc99dd..ce67c19d5 100644 --- a/flake.nix +++ b/flake.nix @@ -38,7 +38,7 @@ flake = (nixpkgs.haskell-nix.cabalProject' rec { src = ./.; name = "cardano-base"; - compiler-nix-name = "ghc927"; + compiler-nix-name = "ghc928"; # CHaP input map, so we can find CHaP packages (needs to be more # recent than the index-state we set!). Can be updated with From 96079b15141710b5dd36baa0b4a5bb0e4a42a57e Mon Sep 17 00:00:00 2001 From: Javier Sagredo Date: Tue, 28 Nov 2023 15:56:58 +0100 Subject: [PATCH 46/75] Absorb cardano-ledger-binary ToExpr and Arbitrary instances --- cardano-binary/CHANGELOG.md | 5 + cardano-binary/cardano-binary.cabal | 19 ++- .../testlib/Test/Cardano/Binary/TreeDiff.hs | 114 ++++++++++++++++++ cardano-slotting/CHANGELOG.md | 6 +- cardano-slotting/cardano-slotting.cabal | 13 +- .../Test/Cardano/Slotting/Arbitrary.hs | 21 ++++ .../testlib/Test/Cardano/Slotting/TreeDiff.hs | 17 +++ 7 files changed, 188 insertions(+), 7 deletions(-) create mode 100644 cardano-binary/testlib/Test/Cardano/Binary/TreeDiff.hs create mode 100644 cardano-slotting/testlib/Test/Cardano/Slotting/Arbitrary.hs create mode 100644 cardano-slotting/testlib/Test/Cardano/Slotting/TreeDiff.hs diff --git a/cardano-binary/CHANGELOG.md b/cardano-binary/CHANGELOG.md index 29508b310..1fd690a7c 100644 --- a/cardano-binary/CHANGELOG.md +++ b/cardano-binary/CHANGELOG.md @@ -1,5 +1,10 @@ # Changelog for `cardano-binary` +## 1.7.2.0 + +* New `Test.Cardano.Binary.TreeDiff` module extracted from + `cardano-ledger-binary`. It lives in a new public sublibrary `testlib`. + ## 1.7.1.0 * Add `FromCBOR` instance for `TermToken` diff --git a/cardano-binary/cardano-binary.cabal b/cardano-binary/cardano-binary.cabal index 18585ce8a..115d3fc6b 100644 --- a/cardano-binary/cardano-binary.cabal +++ b/cardano-binary/cardano-binary.cabal @@ -1,7 +1,7 @@ -cabal-version: 2.2 +cabal-version: 3.0 name: cardano-binary -version: 1.7.1.0 +version: 1.7.2.0 synopsis: Binary serialization for Cardano description: This package includes the binary serialization format for Cardano license: Apache-2.0 @@ -53,6 +53,20 @@ library , time , vector +library testlib + import: base, project-config + visibility: public + hs-source-dirs: testlib + exposed-modules: Test.Cardano.Binary.TreeDiff + build-depends: base + , bytestring + , base16-bytestring + , cardano-binary + , cborg + , formatting + , tree-diff + + test-suite test import: base, project-config hs-source-dirs: test @@ -85,4 +99,3 @@ test-suite test ghc-options: -threaded -rtsopts - diff --git a/cardano-binary/testlib/Test/Cardano/Binary/TreeDiff.hs b/cardano-binary/testlib/Test/Cardano/Binary/TreeDiff.hs new file mode 100644 index 000000000..e7441ed69 --- /dev/null +++ b/cardano-binary/testlib/Test/Cardano/Binary/TreeDiff.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE LambdaCase #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Binary.TreeDiff where + +import qualified Cardano.Binary as Plain +import qualified Codec.CBOR.Read as CBOR +import qualified Codec.CBOR.Term as CBOR +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base16 as Base16 +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BSL +import Data.Bifunctor (bimap) +import Data.TreeDiff +import Formatting (build, formatToString) +import qualified Formatting.Buildable as B (Buildable (..)) + +showDecoderError :: B.Buildable e => e -> String +showDecoderError = formatToString build + +showExpr :: ToExpr a => a -> String +showExpr = show . ansiWlExpr . toExpr + +-- | Wraps regular ByteString, but shows and diffs it as hex +newtype HexBytes = HexBytes {unHexBytes :: BS.ByteString} + deriving (Eq) + +instance Show HexBytes where + show = showExpr + +instance ToExpr HexBytes where + toExpr = App "HexBytes" . hexByteStringExpr . unHexBytes + +newtype CBORBytes = CBORBytes {unCBORBytes :: BS.ByteString} + deriving (Eq) + +instance Show CBORBytes where + show = showExpr + +instance ToExpr CBORBytes where + toExpr (CBORBytes bytes) = + case CBOR.deserialiseFromBytes CBOR.decodeTerm (BSL.fromStrict bytes) of + Left err -> + App + "CBORBytesError" + [ toExpr @String "Error decoding CBOR, showing as Hex:" + , toExpr (HexBytes bytes) + , toExpr $ show err + ] + Right (leftOver, term) + | BSL.null leftOver -> App "CBORBytes" [toExpr term] + | otherwise -> + case Plain.decodeFullDecoder "Term" CBOR.decodeTerm leftOver of + Right leftOverTerm -> + App + "CBORBytesError" + [ toExpr @String "Error decoding CBOR fully:" + , toExpr term + , toExpr @String "Leftover:" + , toExpr (leftOverTerm :: CBOR.Term) + ] + Left err -> + App + "CBORBytesError" + [ toExpr @String "Error decoding CBOR fully:" + , toExpr term + , toExpr @String "Leftover as Hex, due to inabilty to decode as Term:" + , toExpr $ HexBytes $ BSL.toStrict leftOver + , toExpr $ showDecoderError err + ] + +instance ToExpr CBOR.Term where + toExpr = + \case + CBOR.TInt i -> App "TInt" [toExpr i] + CBOR.TInteger i -> App "TInteger" [toExpr i] + CBOR.TBytes bs -> App "TBytes" $ hexByteStringExpr bs + CBOR.TBytesI bs -> App "TBytesI" $ hexByteStringExpr $ BSL.toStrict bs + CBOR.TString s -> App "TString" [toExpr s] + CBOR.TStringI s -> App "TStringI" [toExpr s] + CBOR.TList xs -> App "TList" [Lst (map toExpr xs)] + CBOR.TListI xs -> App "TListI" [Lst (map toExpr xs)] + CBOR.TMap xs -> App "TMap" [Lst (map (toExpr . bimap toExpr toExpr) xs)] + CBOR.TMapI xs -> App "TMapI" [Lst (map (toExpr . bimap toExpr toExpr) xs)] + CBOR.TTagged 24 (CBOR.TBytes x) -> App "CBOR-in-CBOR" [toExpr (CBORBytes x)] + CBOR.TTagged t x -> App "TTagged" [toExpr t, toExpr x] + CBOR.TBool x -> App "TBool" [toExpr x] + CBOR.TNull -> App "TNull" [] + CBOR.TSimple x -> App "TSimple" [toExpr x] + CBOR.THalf x -> App "THalf" [toExpr x] + CBOR.TFloat x -> App "TFloat" [toExpr x] + CBOR.TDouble x -> App "TDouble" [toExpr x] + +hexByteStringExpr :: BS.ByteString -> [Expr] +hexByteStringExpr bs = + [ toExpr (BS.length bs) + , Lst (map toExpr $ showHexBytesGrouped bs) + ] + +-- | Show a ByteString as hex groups of 8bytes each. This is a slightly more +-- useful form for debugging, rather than bunch of escaped characters. +showHexBytesGrouped :: BS.ByteString -> [String] +showHexBytesGrouped bs + | BS.null bs = [] + | otherwise = + ("0x" <> BS8.unpack (BS.take 128 bs16)) + : [ " " <> BS8.unpack (BS.take 128 $ BS.drop i bs16) + | i <- [128, 256 .. BS.length bs16 - 1] + ] + where + bs16 = Base16.encode bs diff --git a/cardano-slotting/CHANGELOG.md b/cardano-slotting/CHANGELOG.md index c22087209..e0490142a 100644 --- a/cardano-slotting/CHANGELOG.md +++ b/cardano-slotting/CHANGELOG.md @@ -1,8 +1,9 @@ # Changelog for `cardano-slotting` -## 0.1.1.2 +## 0.1.2.0 -* +* New `Test.Cardano.Slotting.TreeDiff` module extracted from + `cardano-ledger-binary`. It lives in a new public sublibrary `testlib`. ## 0.1.1.1 @@ -20,4 +21,3 @@ ## 0.1.0.1 * Initial release - diff --git a/cardano-slotting/cardano-slotting.cabal b/cardano-slotting/cardano-slotting.cabal index e48157734..30ae396b6 100644 --- a/cardano-slotting/cardano-slotting.cabal +++ b/cardano-slotting/cardano-slotting.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: cardano-slotting -version: 0.1.1.1 +version: 0.1.2.0 synopsis: Key slotting types for cardano libraries license: Apache-2.0 license-files: @@ -47,6 +47,17 @@ library , serialise , time +library testlib + import: base, project-config + visibility: public + hs-source-dirs: testlib + exposed-modules: Test.Cardano.Slotting.Arbitrary + Test.Cardano.Slotting.TreeDiff + build-depends: base + , cardano-slotting + , QuickCheck + , tree-diff + test-suite tests import: base, project-config type: exitcode-stdio-1.0 diff --git a/cardano-slotting/testlib/Test/Cardano/Slotting/Arbitrary.hs b/cardano-slotting/testlib/Test/Cardano/Slotting/Arbitrary.hs new file mode 100644 index 000000000..81e8fff4f --- /dev/null +++ b/cardano-slotting/testlib/Test/Cardano/Slotting/Arbitrary.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} + +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Slotting.Arbitrary () where + +import Test.QuickCheck +import Cardano.Slotting.Slot + +instance Arbitrary SlotNo where + arbitrary = SlotNo <$> + ((getPositive <$> arbitrary) + `suchThat` + (\n -> n < maxBound - 2^(32 :: Int))) + -- need some room, we're assuming we'll never wrap around 64bits + + shrink (SlotNo n) = [ SlotNo n' | n' <- shrink n, n' > 0 ] + +deriving newtype instance Arbitrary EpochNo diff --git a/cardano-slotting/testlib/Test/Cardano/Slotting/TreeDiff.hs b/cardano-slotting/testlib/Test/Cardano/Slotting/TreeDiff.hs new file mode 100644 index 000000000..f8282ee6c --- /dev/null +++ b/cardano-slotting/testlib/Test/Cardano/Slotting/TreeDiff.hs @@ -0,0 +1,17 @@ +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Slotting.TreeDiff where + +import Cardano.Slotting.Slot +import Cardano.Slotting.Block +import Data.TreeDiff + +instance ToExpr x => ToExpr (WithOrigin x) + +instance ToExpr SlotNo + +instance ToExpr BlockNo + +instance ToExpr EpochNo + +instance ToExpr EpochSize From b7cade9dbe1fc696852cf568201ab4e2f10102a1 Mon Sep 17 00:00:00 2001 From: Alexey Kuleshevich Date: Wed, 29 Nov 2023 13:21:30 +0100 Subject: [PATCH 47/75] Fix cardano-binary version --- cardano-binary/CHANGELOG.md | 5 +---- cardano-binary/cardano-binary.cabal | 2 +- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/cardano-binary/CHANGELOG.md b/cardano-binary/CHANGELOG.md index 1fd690a7c..d4d7036e6 100644 --- a/cardano-binary/CHANGELOG.md +++ b/cardano-binary/CHANGELOG.md @@ -1,12 +1,9 @@ # Changelog for `cardano-binary` -## 1.7.2.0 +## 1.7.1.0 * New `Test.Cardano.Binary.TreeDiff` module extracted from `cardano-ledger-binary`. It lives in a new public sublibrary `testlib`. - -## 1.7.1.0 - * Add `FromCBOR` instance for `TermToken` ## 1.7.0.1 diff --git a/cardano-binary/cardano-binary.cabal b/cardano-binary/cardano-binary.cabal index 115d3fc6b..1f71cfa7b 100644 --- a/cardano-binary/cardano-binary.cabal +++ b/cardano-binary/cardano-binary.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: cardano-binary -version: 1.7.2.0 +version: 1.7.1.0 synopsis: Binary serialization for Cardano description: This package includes the binary serialization format for Cardano license: Apache-2.0 From c05e5ecc7dd3fb4f1aba4bdbd8d144d238294688 Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Mon, 11 Dec 2023 15:49:17 +0100 Subject: [PATCH 48/75] Remove `Switch` modules, release `strict-checked-vars-0.2.0.0` --- strict-checked-vars/CHANGELOG.md | 8 ++ .../Class/MonadMVar/Strict/Checked.hs | 62 ++++++--- .../Class/MonadMVar/Strict/Checked/Switch.hs | 119 ------------------ .../Class/MonadSTM/Strict/TVar/Checked.hs | 48 +++++-- .../MonadSTM/Strict/TVar/Checked/Switch.hs | 65 ---------- strict-checked-vars/strict-checked-vars.cabal | 4 +- 6 files changed, 89 insertions(+), 217 deletions(-) delete mode 100644 strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs delete mode 100644 strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/Switch.hs diff --git a/strict-checked-vars/CHANGELOG.md b/strict-checked-vars/CHANGELOG.md index a013dd5cc..0740b9aa3 100644 --- a/strict-checked-vars/CHANGELOG.md +++ b/strict-checked-vars/CHANGELOG.md @@ -1,5 +1,13 @@ # Revision history of strict-checked-vars +## 0.2.0.0 + +* Remove 'Switch' modules. From now on, instead of switching _imports_, this + package switches the _representations_ of checked variables depending on the + `checkmvarinvariants` and `checktvarinvariants` flags. This solves a problem + where compiling projects that depend on `strict-checked-vars` might succeed + with a flag turned on but fail when it is turned off (and vice versa). + ## 0.1.0.4 * Propagate HasCallStack constraints in the `Switch` module for checked strict diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs index 49929bf23..7e408f96a 100644 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TupleSections #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE StandaloneKindSignatures #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | This module corresponds to "Control.Concurrent.MVar" in the @base@ package. -- @@ -40,6 +43,7 @@ module Control.Concurrent.Class.MonadMVar.Strict.Checked ( import Control.Concurrent.Class.MonadMVar.Strict (LazyMVar, MonadMVar) import qualified Control.Concurrent.Class.MonadMVar.Strict as Strict +import Data.Kind (Type) import GHC.Stack (HasCallStack) {------------------------------------------------------------------------------- @@ -55,15 +59,22 @@ import GHC.Stack (HasCallStack) -- with a value that does not satisfy the invariant, an exception is thrown. The -- reason for this weaker guarantee is that leaving an 'MVar' empty can lead to -- very hard to debug "blocked indefinitely" problems. +type StrictMVar :: (Type -> Type) -> Type -> Type +#if CHECK_MVAR_INVARIANTS data StrictMVar m a = StrictMVar { -- | The invariant that is checked whenever the 'StrictMVar' is updated. invariant :: !(a -> Maybe String) , mvar :: !(Strict.StrictMVar m a) } +#else +newtype StrictMVar m a = StrictMVar { + mvar :: Strict.StrictMVar m a + } +#endif castStrictMVar :: LazyMVar m ~ LazyMVar n => StrictMVar m a -> StrictMVar n a -castStrictMVar v = StrictMVar (invariant v) (Strict.castStrictMVar $ mvar v) +castStrictMVar v = mkStrictMVar (getInvariant v) (Strict.castStrictMVar $ mvar v) -- | Get the underlying @MVar@ -- @@ -83,18 +94,18 @@ toLazyMVar = Strict.toLazyMVar . mvar -- -- The resulting 'StrictMVar' has a trivial invariant. fromLazyMVar :: LazyMVar m a -> StrictMVar m a -fromLazyMVar = StrictMVar (const Nothing) . Strict.fromLazyMVar +fromLazyMVar = mkStrictMVar (const Nothing) . Strict.fromLazyMVar newEmptyMVar :: MonadMVar m => m (StrictMVar m a) -newEmptyMVar = StrictMVar (const Nothing) <$> Strict.newEmptyMVar +newEmptyMVar = mkStrictMVar (const Nothing) <$> Strict.newEmptyMVar newEmptyMVarWithInvariant :: MonadMVar m => (a -> Maybe String) -> m (StrictMVar m a) -newEmptyMVarWithInvariant inv = StrictMVar inv <$> Strict.newEmptyMVar +newEmptyMVarWithInvariant inv = mkStrictMVar inv <$> Strict.newEmptyMVar newMVar :: MonadMVar m => a -> m (StrictMVar m a) -newMVar a = StrictMVar (const Nothing) <$> Strict.newMVar a +newMVar a = mkStrictMVar (const Nothing) <$> Strict.newMVar a -- | Create a 'StrictMVar' with an invariant. -- @@ -106,7 +117,7 @@ newMVarWithInvariant :: (HasCallStack, MonadMVar m) -> m (StrictMVar m a) newMVarWithInvariant inv !a = checkInvariant (inv a) $ - StrictMVar inv <$> Strict.newMVar a + mkStrictMVar inv <$> Strict.newMVar a takeMVar :: MonadMVar m => StrictMVar m a -> m a takeMVar = Strict.takeMVar . mvar @@ -114,7 +125,7 @@ takeMVar = Strict.takeMVar . mvar putMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m () putMVar v a = do Strict.putMVar (mvar v) a - checkInvariant (invariant v a) $ pure () + checkInvariant (getInvariant v a) $ pure () readMVar :: MonadMVar m => StrictMVar m a -> m a readMVar v = Strict.readMVar (mvar v) @@ -122,7 +133,7 @@ readMVar v = Strict.readMVar (mvar v) swapMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m a swapMVar v a = do oldValue <- Strict.swapMVar (mvar v) a - checkInvariant (invariant v a) $ pure oldValue + checkInvariant (getInvariant v a) $ pure oldValue tryTakeMVar :: MonadMVar m => StrictMVar m a -> m (Maybe a) tryTakeMVar v = Strict.tryTakeMVar (mvar v) @@ -130,7 +141,7 @@ tryTakeMVar v = Strict.tryTakeMVar (mvar v) tryPutMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m Bool tryPutMVar v a = do didPut <- Strict.tryPutMVar (mvar v) a - checkInvariant (invariant v a) $ pure didPut + checkInvariant (getInvariant v a) $ pure didPut isEmptyMVar :: MonadMVar m => StrictMVar m a -> m Bool isEmptyMVar v = Strict.isEmptyMVar (mvar v) @@ -155,7 +166,7 @@ modifyMVar :: (HasCallStack, MonadMVar m) -> m b modifyMVar v io = do (a', b) <- Strict.modifyMVar (mvar v) io' - checkInvariant (invariant v a') $ pure b + checkInvariant (getInvariant v a') $ pure b where io' a = do (a', b) <- io a @@ -177,7 +188,7 @@ modifyMVarMasked :: (HasCallStack, MonadMVar m) -> m b modifyMVarMasked v io = do (a', b) <- Strict.modifyMVarMasked (mvar v) io' - checkInvariant (invariant v a') $ pure b + checkInvariant (getInvariant v a') $ pure b where io' a = do (a', b) <- io a @@ -192,10 +203,25 @@ tryReadMVar v = Strict.tryReadMVar (mvar v) -- Dealing with invariants -- --- | Check invariant +-- | Check invariant (if enabled) before continuing +-- +-- @checkInvariant mErr x@ is equal to @x@ if @mErr == Nothing@, and throws +-- an error @err@ if @mErr == Just err@. -- --- @checkInvariant mErr x@ is equal to @x@ if @mErr == Nothing@, and throws an --- error @err@ if @mErr == Just err@. +-- This is exported so that other code that wants to conditionally check +-- invariants can reuse the same logic, rather than having to introduce new +-- per-package flags. checkInvariant :: HasCallStack => Maybe String -> a -> a +getInvariant :: StrictMVar m a -> a -> Maybe String +mkStrictMVar :: (a -> Maybe String) -> Strict.StrictMVar m a -> StrictMVar m a + +#if CHECK_MVAR_INVARIANTS checkInvariant Nothing k = k checkInvariant (Just err) _ = error $ "StrictMVar invariant violation: " ++ err +getInvariant StrictMVar {invariant} = invariant +mkStrictMVar invariant mvar = StrictMVar {invariant, mvar} +#else +checkInvariant _err k = k +getInvariant _ = const Nothing +mkStrictMVar _invariant mvar = StrictMVar {mvar} +#endif diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs deleted file mode 100644 index 69a8abd90..000000000 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked/Switch.hs +++ /dev/null @@ -1,119 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Control.Concurrent.Class.MonadMVar.Strict.Checked.Switch ( - -- * StrictMVar - LazyMVar - , StrictMVar - , castStrictMVar - , fromLazyMVar - , isEmptyMVar - , modifyMVar - , modifyMVarMasked - , modifyMVarMasked_ - , modifyMVar_ - , newEmptyMVar - , newEmptyMVarWithInvariant - , newMVar - , newMVarWithInvariant - , putMVar - , readMVar - , swapMVar - , takeMVar - , toLazyMVar - , tryPutMVar - , tryReadMVar - , tryTakeMVar - , withMVar - , withMVarMasked - -- * Invariant - , checkInvariant - -- * Re-exports - , MonadMVar - ) where - -#if CHECK_MVAR_INVARIANTS -import Control.Concurrent.Class.MonadMVar.Strict.Checked hiding - (checkInvariant, - modifyMVar, - modifyMVarMasked, - modifyMVarMasked_, - modifyMVar_, - newEmptyMVarWithInvariant, - newMVarWithInvariant, - putMVar, - swapMVar, - tryPutMVar) -import qualified Control.Concurrent.Class.MonadMVar.Strict.Checked as StrictMVar.Checked -#else -import Control.Concurrent.Class.MonadMVar.Strict hiding - (modifyMVar, - modifyMVarMasked, - modifyMVarMasked_, - modifyMVar_, - putMVar, - swapMVar, - tryPutMVar) -import qualified Control.Concurrent.Class.MonadMVar.Strict as StrictMVar -#endif -import GHC.Stack (HasCallStack) - -newEmptyMVarWithInvariant :: MonadMVar m - => (a -> Maybe String) - -> m (StrictMVar m a) - -newMVarWithInvariant :: (HasCallStack, MonadMVar m) - => (a -> Maybe String) - -> a - -> m (StrictMVar m a) - -putMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m () - -swapMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m a - -tryPutMVar :: (HasCallStack, MonadMVar m) => StrictMVar m a -> a -> m Bool - -modifyMVar_ :: (HasCallStack, MonadMVar m) - => StrictMVar m a - -> (a -> m a) - -> m () - -modifyMVar :: (HasCallStack, MonadMVar m) - => StrictMVar m a - -> (a -> m (a,b)) - -> m b - -modifyMVarMasked_ :: (HasCallStack, MonadMVar m) - => StrictMVar m a - -> (a -> m a) - -> m () - -modifyMVarMasked :: (HasCallStack, MonadMVar m) - => StrictMVar m a - -> (a -> m (a,b)) - -> m b - -checkInvariant :: HasCallStack => Maybe String -> a -> a - -#if CHECK_MVAR_INVARIANTS -newEmptyMVarWithInvariant = StrictMVar.Checked.newEmptyMVarWithInvariant -newMVarWithInvariant = StrictMVar.Checked.newMVarWithInvariant -putMVar = StrictMVar.Checked.putMVar -swapMVar = StrictMVar.Checked.swapMVar -tryPutMVar = StrictMVar.Checked.tryPutMVar -modifyMVar_ = StrictMVar.Checked.modifyMVar_ -modifyMVar = StrictMVar.Checked.modifyMVar -modifyMVarMasked_ = StrictMVar.Checked.modifyMVarMasked_ -modifyMVarMasked = StrictMVar.Checked.modifyMVarMasked -checkInvariant = StrictMVar.Checked.checkInvariant -#else -newEmptyMVarWithInvariant _ = StrictMVar.newEmptyMVar -newMVarWithInvariant _ = StrictMVar.newMVar -putMVar = StrictMVar.putMVar -swapMVar = StrictMVar.swapMVar -tryPutMVar = StrictMVar.tryPutMVar -modifyMVar_ = StrictMVar.modifyMVar_ -modifyMVar = StrictMVar.modifyMVar -modifyMVarMasked_ = StrictMVar.modifyMVarMasked_ -modifyMVarMasked = StrictMVar.modifyMVarMasked -checkInvariant = \_ a -> a -#endif diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs index 4ff3f9bd3..31b7e6e9a 100644 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs @@ -1,6 +1,8 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE TypeFamilies #-} -{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} -- | This module corresponds to "Control.Concurrent.STM.TVar" in the @stm@ package. -- @@ -46,15 +48,21 @@ import GHC.Stack (HasCallStack) type LazyTVar m = Strict.LazyTVar m +#if CHECK_TVAR_INVARIANTS data StrictTVar m a = StrictTVar { -- | Invariant checked whenever updating the 'StrictTVar'. invariant :: !(a -> Maybe String) , tvar :: !(Strict.StrictTVar m a) } +#else +newtype StrictTVar m a = StrictTVar { + tvar :: Strict.StrictTVar m a + } +#endif castStrictTVar :: LazyTVar m ~ LazyTVar n => StrictTVar m a -> StrictTVar n a -castStrictTVar v = StrictTVar (invariant v) (Strict.castStrictTVar $ tvar v) +castStrictTVar v = mkStrictTVar (getInvariant v) (Strict.castStrictTVar $ tvar v) -- | Get the underlying @TVar@ -- @@ -74,10 +82,10 @@ toLazyTVar = Strict.toLazyTVar . tvar -- -- The resulting 'StrictTVar' has a trivial invariant. fromLazyTVar :: LazyTVar m a -> StrictTVar m a -fromLazyTVar = StrictTVar (const Nothing) . Strict.fromLazyTVar +fromLazyTVar = mkStrictTVar (const Nothing) . Strict.fromLazyTVar newTVar :: MonadSTM m => a -> STM m (StrictTVar m a) -newTVar a = StrictTVar (const Nothing) <$> Strict.newTVar a +newTVar a = mkStrictTVar (const Nothing) <$> Strict.newTVar a newTVarIO :: MonadSTM m => a -> m (StrictTVar m a) newTVarIO = newTVarWithInvariantIO (const Nothing) @@ -88,7 +96,7 @@ newTVarWithInvariant :: (MonadSTM m, HasCallStack) -> STM m (StrictTVar m a) newTVarWithInvariant inv !a = checkInvariant (inv a) $ - StrictTVar inv <$> Strict.newTVar a + mkStrictTVar inv <$> Strict.newTVar a newTVarWithInvariantIO :: (MonadSTM m, HasCallStack) => (a -> Maybe String) @@ -96,7 +104,7 @@ newTVarWithInvariantIO :: (MonadSTM m, HasCallStack) -> m (StrictTVar m a) newTVarWithInvariantIO inv !a = checkInvariant (inv a) $ - StrictTVar inv <$> Strict.newTVarIO a + mkStrictTVar inv <$> Strict.newTVarIO a readTVar :: MonadSTM m => StrictTVar m a -> STM m a readTVar = Strict.readTVar . tvar @@ -106,7 +114,7 @@ readTVarIO = Strict.readTVarIO . tvar writeTVar :: (MonadSTM m, HasCallStack) => StrictTVar m a -> a -> STM m () writeTVar v !a = - checkInvariant (invariant v a) $ + checkInvariant (getInvariant v a) $ Strict.writeTVar (tvar v) a modifyTVar :: MonadSTM m => StrictTVar m a -> (a -> a) -> STM m () @@ -129,13 +137,29 @@ swapTVar v a' = do -- Dealing with invariants -- --- | Check invariant + +-- | Check invariant (if enabled) before continuing -- --- @checkInvariant mErr x@ is equal to @x@ if @mErr == Nothing@, and throws an --- error @err@ if @mErr == Just err@. +-- @checkInvariant mErr x@ is equal to @x@ if @mErr == Nothing@, and throws +-- an error @err@ if @mErr == Just err@. +-- +-- This is exported so that other code that wants to conditionally check +-- invariants can reuse the same logic, rather than having to introduce new +-- per-package flags. checkInvariant :: HasCallStack => Maybe String -> a -> a +getInvariant :: StrictTVar m a -> a -> Maybe String +mkStrictTVar :: (a -> Maybe String) -> Strict.StrictTVar m a -> StrictTVar m a + +#if CHECK_TVAR_INVARIANTS checkInvariant Nothing k = k checkInvariant (Just err) _ = error $ "StrictTVar invariant violation: " ++ err +getInvariant StrictTVar {invariant} = invariant +mkStrictTVar invariant tvar = StrictTVar {invariant, tvar} +#else +checkInvariant _err k = k +getInvariant _ = const Nothing +mkStrictTVar _invariant tvar = StrictTVar {tvar} +#endif {------------------------------------------------------------------------------- MonadLabelledSTM diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/Switch.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/Switch.hs deleted file mode 100644 index 11150490a..000000000 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked/Switch.hs +++ /dev/null @@ -1,65 +0,0 @@ -{-# LANGUAGE CPP #-} - -module Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.Switch ( - -- * StrictTVar - LazyTVar - , StrictTVar - , castStrictTVar - , fromLazyTVar - , modifyTVar - , newTVar - , newTVarIO - , newTVarWithInvariant - , newTVarWithInvariantIO - , readTVar - , readTVarIO - , stateTVar - , swapTVar - , toLazyTVar - , writeTVar - -- * MonadLabelSTM - , labelTVar - , labelTVarIO - -- * MonadTraceSTM - , traceTVar - , traceTVarIO - -- * invariant - , checkInvariant - ) where - -import Control.Concurrent.Class.MonadSTM (MonadSTM, STM) -#if CHECK_TVAR_INVARIANTS -import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked as StrictTVar.Checked -import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked hiding (checkInvariant, newTVarWithInvariant, newTVarWithInvariantIO) -#else -import qualified Control.Concurrent.Class.MonadSTM.Strict.TVar as StrictTVar -import Control.Concurrent.Class.MonadSTM.Strict.TVar -#endif -import GHC.Stack (HasCallStack) - -newTVarWithInvariant :: (MonadSTM m, HasCallStack) - => (a -> Maybe String) - -> a - -> STM m (StrictTVar m a) -#if CHECK_TVAR_INVARIANTS -newTVarWithInvariant = StrictTVar.Checked.newTVarWithInvariant -#else -newTVarWithInvariant _ = StrictTVar.newTVar -#endif - -newTVarWithInvariantIO :: (MonadSTM m, HasCallStack) - => (a -> Maybe String) - -> a - -> m (StrictTVar m a) -#if CHECK_TVAR_INVARIANTS -newTVarWithInvariantIO = StrictTVar.Checked.newTVarWithInvariantIO -#else -newTVarWithInvariantIO _ = StrictTVar.newTVarIO -#endif - -checkInvariant :: HasCallStack => Maybe String -> a -> a -#if CHECK_TVAR_INVARIANTS -checkInvariant = StrictTVar.Checked.checkInvariant -#else -checkInvariant = \_ a -> a -#endif \ No newline at end of file diff --git a/strict-checked-vars/strict-checked-vars.cabal b/strict-checked-vars/strict-checked-vars.cabal index 0514eb825..b7f08c7f2 100644 --- a/strict-checked-vars/strict-checked-vars.cabal +++ b/strict-checked-vars/strict-checked-vars.cabal @@ -1,6 +1,6 @@ cabal-version: 3.0 name: strict-checked-vars -version: 0.1.0.4 +version: 0.2.0.0 synopsis: Strict MVars and TVars with invariant checking for IO and IOSim @@ -45,9 +45,7 @@ library hs-source-dirs: src exposed-modules: Control.Concurrent.Class.MonadMVar.Strict.Checked - Control.Concurrent.Class.MonadMVar.Strict.Checked.Switch Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked - Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.Switch default-language: Haskell2010 build-depends: From 1211fb2c99068df83225f539d031dc7cce69b6ae Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Mon, 11 Dec 2023 16:26:11 +0100 Subject: [PATCH 49/75] Add conversion functions from checked to unchecked vars --- strict-checked-vars/CHANGELOG.md | 3 +++ .../Control/Concurrent/Class/MonadMVar/Strict/Checked.hs | 8 ++++++++ .../Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs | 8 ++++++++ 3 files changed, 19 insertions(+) diff --git a/strict-checked-vars/CHANGELOG.md b/strict-checked-vars/CHANGELOG.md index 0740b9aa3..22fe84250 100644 --- a/strict-checked-vars/CHANGELOG.md +++ b/strict-checked-vars/CHANGELOG.md @@ -8,6 +8,9 @@ where compiling projects that depend on `strict-checked-vars` might succeed with a flag turned on but fail when it is turned off (and vice versa). +* Add new `unsafeToUncheckedStrictMVar` and `unsafeToUncheckedStrictTVar` + functions. + ## 0.1.0.4 * Propagate HasCallStack constraints in the `Switch` module for checked strict diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs index 7e408f96a..5e137b56e 100644 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs @@ -33,6 +33,7 @@ module Control.Concurrent.Class.MonadMVar.Strict.Checked ( , tryPutMVar , tryReadMVar , tryTakeMVar + , unsafeToUncheckedStrictMVar , withMVar , withMVarMasked -- * Invariant @@ -96,6 +97,13 @@ toLazyMVar = Strict.toLazyMVar . mvar fromLazyMVar :: LazyMVar m a -> StrictMVar m a fromLazyMVar = mkStrictMVar (const Nothing) . Strict.fromLazyMVar +-- | Create an unchecked reference to the given checked 'StrictMVar'. +-- +-- Note that the invariant is only guaranteed when modifying the checked MVar. +-- Any modification to the unchecked reference might break the invariants. +unsafeToUncheckedStrictMVar :: StrictMVar m a -> Strict.StrictMVar m a +unsafeToUncheckedStrictMVar = mvar + newEmptyMVar :: MonadMVar m => m (StrictMVar m a) newEmptyMVar = mkStrictMVar (const Nothing) <$> Strict.newEmptyMVar diff --git a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs index 31b7e6e9a..c5be04228 100644 --- a/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs +++ b/strict-checked-vars/src/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs @@ -25,6 +25,7 @@ module Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked ( , stateTVar , swapTVar , toLazyTVar + , unsafeToUncheckedStrictTVar , writeTVar -- * MonadLabelSTM , labelTVar @@ -84,6 +85,13 @@ toLazyTVar = Strict.toLazyTVar . tvar fromLazyTVar :: LazyTVar m a -> StrictTVar m a fromLazyTVar = mkStrictTVar (const Nothing) . Strict.fromLazyTVar +-- | Create an unchecked reference to the given checked 'StrictTVar'. +-- +-- Note that the invariant is only guaranteed when modifying the checked TVar. +-- Any modification to the unchecked reference might break the invariants. +unsafeToUncheckedStrictTVar :: StrictTVar m a -> Strict.StrictTVar m a +unsafeToUncheckedStrictTVar = tvar + newTVar :: MonadSTM m => a -> STM m (StrictTVar m a) newTVar a = mkStrictTVar (const Nothing) <$> Strict.newTVar a From 75e357611ebd429fa7ba52e3a45be868ffbd163c Mon Sep 17 00:00:00 2001 From: Joris Dral Date: Mon, 11 Dec 2023 18:30:37 +0100 Subject: [PATCH 50/75] Fix tests --- strict-checked-vars/strict-checked-vars.cabal | 9 +++- strict-checked-vars/test/Main.hs | 12 +++-- .../Class/MonadMVar/Strict/Checked.hs | 18 ++++--- .../Class/MonadSTM/Strict/TVar/Checked.hs | 52 +++++++++++++++++++ 4 files changed, 80 insertions(+), 11 deletions(-) create mode 100644 strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs diff --git a/strict-checked-vars/strict-checked-vars.cabal b/strict-checked-vars/strict-checked-vars.cabal index b7f08c7f2..2265d119e 100644 --- a/strict-checked-vars/strict-checked-vars.cabal +++ b/strict-checked-vars/strict-checked-vars.cabal @@ -49,7 +49,7 @@ library default-language: Haskell2010 build-depends: - , base >=4.9 && <5 + , base >=4.9 && <5 , io-classes >=1.2 && <1.4 , strict-mvar >=1.2 && <1.4 , strict-stm >=1.2 && <1.4 @@ -72,6 +72,7 @@ test-suite test other-modules: Test.Control.Concurrent.Class.MonadMVar.Strict.Checked Test.Control.Concurrent.Class.MonadMVar.Strict.Checked.WHNF + Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.WHNF Test.Utils @@ -90,3 +91,9 @@ test-suite test -Wall -Wcompat -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -Widentities -Wunused-packages -fno-ignore-asserts + + if flag(checkmvarinvariants) + cpp-options: -DCHECK_MVAR_INVARIANTS + + if flag(checktvarinvariants) + cpp-options: -DCHECK_TVAR_INVARIANTS diff --git a/strict-checked-vars/test/Main.hs b/strict-checked-vars/test/Main.hs index cc170dd78..088f768fb 100644 --- a/strict-checked-vars/test/Main.hs +++ b/strict-checked-vars/test/Main.hs @@ -1,11 +1,15 @@ module Main where -import qualified Test.Control.Concurrent.Class.MonadMVar.Strict.Checked as Test.StrictMVar.Checked -import qualified Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.WHNF as Test.StrictTVar.Checked +import qualified Test.Control.Concurrent.Class.MonadMVar.Strict.Checked +import qualified Test.Control.Concurrent.Class.MonadMVar.Strict.Checked.WHNF +import qualified Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked +import qualified Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.WHNF import Test.Tasty (defaultMain, testGroup) main :: IO () main = defaultMain $ testGroup "strict-checked-vars" [ - Test.StrictMVar.Checked.tests - , Test.StrictTVar.Checked.tests + Test.Control.Concurrent.Class.MonadMVar.Strict.Checked.tests + , Test.Control.Concurrent.Class.MonadMVar.Strict.Checked.WHNF.tests + , Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.tests + , Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked.WHNF.tests ] diff --git a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs index 039746e62..b23a89775 100644 --- a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs +++ b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadMVar/Strict/Checked.hs @@ -1,9 +1,9 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE RankNTypes #-} module Test.Control.Concurrent.Class.MonadMVar.Strict.Checked where import Control.Concurrent.Class.MonadMVar.Strict.Checked -import qualified Test.Control.Concurrent.Class.MonadMVar.Strict.Checked.WHNF as Test.WHNF import Test.QuickCheck.Monadic import Test.Tasty import Test.Tasty.QuickCheck @@ -14,17 +14,16 @@ tests = testGroup "Test.Control.Concurrent.Class.MonadMVar.Strict" [ testGroup "Checked" [ testGroup "IO" [ testProperty "prop_invariantShouldFail" $ - once $ expectFailure $ monadicIO prop_invariantShouldFail + once $ cppToggle $ monadicIO prop_invariantShouldFail , testProperty "prop_invariantShouldNotFail" $ - once $ monadicIO prop_invariantShouldNotFail + once $ monadicIO prop_invariantShouldNotFail ] , testGroup "IOSim" [ testProperty "prop_invariantShouldFail" $ - once $ expectFailure $ monadicSim prop_invariantShouldFail + once $ cppToggle $ monadicSim prop_invariantShouldFail , testProperty "prop_invariantShouldNotFail" $ - once $ monadicSim prop_invariantShouldNotFail + once $ monadicSim prop_invariantShouldNotFail ] - , Test.WHNF.tests ] ] @@ -43,3 +42,10 @@ prop_invariantShouldFail :: MonadMVar m => PropertyM m () prop_invariantShouldFail = run $ do v <- newMVarWithInvariant invPositiveInt 0 modifyMVar_ v (\x -> pure $ x - 1) + +cppToggle :: Property -> Property +#if CHECK_TVAR_INVARIANTS +cppToggle = expectFailure +#else +cppToggle = id +#endif diff --git a/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs new file mode 100644 index 000000000..fb1c18411 --- /dev/null +++ b/strict-checked-vars/test/Test/Control/Concurrent/Class/MonadSTM/Strict/TVar/Checked.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE RankNTypes #-} + +module Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked where + +import Control.Concurrent.Class.MonadSTM (MonadSTM, atomically) +import Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked +import Test.QuickCheck.Monadic +import Test.Tasty +import Test.Tasty.QuickCheck +import Test.Utils + +tests :: TestTree +tests = testGroup "Test.Control.Concurrent.Class.MonadSTM.Strict.TVar.Checked" [ + testGroup "Checked" [ + testGroup "IO" [ + testProperty "prop_invariantShouldFail" $ + once $ cppToggle $ monadicIO prop_invariantShouldFail + , testProperty "prop_invariantShouldNotFail" $ + once $ monadicIO prop_invariantShouldNotFail + ] + , testGroup "IOSim" [ + testProperty "prop_invariantShouldFail" $ + once $ cppToggle $ monadicSim prop_invariantShouldFail + , testProperty "prop_invariantShouldNotFail" $ + once $ monadicSim prop_invariantShouldNotFail + ] + ] + ] + +-- | Invariant that checks whether an @Int@ is positive. +invPositiveInt :: Int -> Maybe String +invPositiveInt x + | x >= 0 = Nothing + | otherwise = Just $ "x<0 for x=" <> show x + +prop_invariantShouldNotFail :: MonadSTM m => PropertyM m () +prop_invariantShouldNotFail = run $ atomically $ do + v <- newTVarWithInvariant invPositiveInt 0 + modifyTVar v (+ 1) + +prop_invariantShouldFail :: MonadSTM m => PropertyM m () +prop_invariantShouldFail = run $ atomically $ do + v <- newTVarWithInvariant invPositiveInt 0 + modifyTVar v (subtract 1) + +cppToggle :: Property -> Property +#if CHECK_TVAR_INVARIANTS +cppToggle = expectFailure +#else +cppToggle = id +#endif From fdb6845d4bd003f9a9766fd44385030edd079244 Mon Sep 17 00:00:00 2001 From: Samuel Leathers Date: Sat, 16 Dec 2023 12:05:14 -0500 Subject: [PATCH 51/75] chap: migrate to chap.intersectmbo.org --- README.md | 4 ++-- cabal.project | 2 +- flake.lock | 10 +++++----- flake.nix | 4 ++-- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/README.md b/README.md index 718744826..2a4744597 100644 --- a/README.md +++ b/README.md @@ -9,10 +9,10 @@ A collection of miscellaneous packages used by Cardano that cover: Each sub-project has its own README. Haddock for all packages from master branch can be found here: -[https://input-output-hk.github.io/cardano-base](https://input-output-hk.github.io/cardano-base/) +[https://cardano-base.cardano.intersectmbo.org](https://cardano-base.cardano.intersectmbo.org/) All releases for packages found in this repository are recorded in [Cardano Haskell -package repository](https://github.com/input-output-hk/cardano-haskell-packages) +package repository](https://github.com/intersectmbo/cardano-haskell-packages) ## Building diff --git a/cabal.project b/cabal.project index a04622a62..f4e7ccad2 100644 --- a/cabal.project +++ b/cabal.project @@ -1,5 +1,5 @@ repository cardano-haskell-packages - url: https://input-output-hk.github.io/cardano-haskell-packages + url: https://chap.intersectmbo.org/ secure: True root-keys: 3e0cce471cf09815f930210f7827266fd09045445d65923e6d0238a6cd15126f diff --git a/flake.lock b/flake.lock index 04841c9ee..1db623947 100644 --- a/flake.lock +++ b/flake.lock @@ -3,15 +3,15 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1696538731, - "narHash": "sha256-oTsPiABmN7mw9hctagxzNcIDtvmyK4EuBzvMD2iXeeQ=", - "owner": "input-output-hk", + "lastModified": 1702742788, + "narHash": "sha256-lSU0M27LC0d60cJ2C2Kdo6gBwTCCYRiALbD528CoTtc=", + "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "4276a203ed968d067b6c31c943b5bae5fc2ec4a2", + "rev": "4a236a8ad9e3c6d20235de27eacbe3d4de72479c", "type": "github" }, "original": { - "owner": "input-output-hk", + "owner": "intersectmbo", "ref": "repo", "repo": "cardano-haskell-packages", "type": "github" diff --git a/flake.nix b/flake.nix index ce67c19d5..644dd428c 100644 --- a/flake.nix +++ b/flake.nix @@ -5,7 +5,7 @@ iohkNix.url = "github:input-output-hk/iohk-nix"; flake-utils.url = "github:hamishmack/flake-utils/hkm/nested-hydraJobs"; - CHaP.url = "github:input-output-hk/cardano-haskell-packages?ref=repo"; + CHaP.url = "github:intersectmbo/cardano-haskell-packages?ref=repo"; CHaP.flake = false; # non-flake nix compatibility @@ -46,7 +46,7 @@ # nix flake lock --update-input CHaP # inputMap = { - "https://input-output-hk.github.io/cardano-haskell-packages" = inputs.CHaP; + "https://chap.intersectmbo.org/" = inputs.CHaP; }; # tools we want in our shell From c7912fbf3b670e0cb5d6a439788c6c1410283f9a Mon Sep 17 00:00:00 2001 From: Lucsanszky Date: Tue, 13 Feb 2024 01:09:02 +0100 Subject: [PATCH 52/75] Move numeric instances of `EpochNo`, `EpochSize` * Move `Num, Real, Integral` instances of `EpochNo` and `EpochSize` to `testlib` * Also add convenience function `binOpEpochNo` --- cardano-slotting/CHANGELOG.md | 12 +++++++++++- cardano-slotting/cardano-slotting.cabal | 3 ++- .../src/Cardano/Slotting/EpochInfo/Extend.hs | 11 ++++++++--- cardano-slotting/src/Cardano/Slotting/Slot.hs | 9 +++++++-- .../testlib/Test/Cardano/Slotting/Numeric.hs | 19 +++++++++++++++++++ 5 files changed, 47 insertions(+), 7 deletions(-) create mode 100644 cardano-slotting/testlib/Test/Cardano/Slotting/Numeric.hs diff --git a/cardano-slotting/CHANGELOG.md b/cardano-slotting/CHANGELOG.md index e0490142a..0760c37a3 100644 --- a/cardano-slotting/CHANGELOG.md +++ b/cardano-slotting/CHANGELOG.md @@ -1,10 +1,20 @@ # Changelog for `cardano-slotting` -## 0.1.2.0 +## 0.2.0.0 +* Add `binOpEpochNo` helper function to facilitate binary operations on + `EpochNo`. +* Remove numeric instances (`Num`, `Integral`, `Real`) of `EpochNo` and + `EpochSize` for safety. + They are still available for testing from the `testlib` as orphans. * New `Test.Cardano.Slotting.TreeDiff` module extracted from `cardano-ledger-binary`. It lives in a new public sublibrary `testlib`. +### `testlib` + +* Add numeric instances (`Num`, `Integral`, `Real`) of `EpochNo` and + `EpochSize` as orphans. + ## 0.1.1.1 * GHC-9.6 compatibility diff --git a/cardano-slotting/cardano-slotting.cabal b/cardano-slotting/cardano-slotting.cabal index 30ae396b6..51d41ce86 100644 --- a/cardano-slotting/cardano-slotting.cabal +++ b/cardano-slotting/cardano-slotting.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: cardano-slotting -version: 0.1.2.0 +version: 0.2.0.0 synopsis: Key slotting types for cardano libraries license: Apache-2.0 license-files: @@ -52,6 +52,7 @@ library testlib visibility: public hs-source-dirs: testlib exposed-modules: Test.Cardano.Slotting.Arbitrary + Test.Cardano.Slotting.Numeric Test.Cardano.Slotting.TreeDiff build-depends: base , cardano-slotting diff --git a/cardano-slotting/src/Cardano/Slotting/EpochInfo/Extend.hs b/cardano-slotting/src/Cardano/Slotting/EpochInfo/Extend.hs index 7baeb0355..7b18559aa 100644 --- a/cardano-slotting/src/Cardano/Slotting/EpochInfo/Extend.hs +++ b/cardano-slotting/src/Cardano/Slotting/EpochInfo/Extend.hs @@ -1,7 +1,12 @@ module Cardano.Slotting.EpochInfo.Extend where import Cardano.Slotting.EpochInfo.API (EpochInfo (..)) -import Cardano.Slotting.Slot (EpochNo (EpochNo), EpochSize (EpochSize), SlotNo (SlotNo)) +import Cardano.Slotting.Slot + ( EpochNo (EpochNo), + EpochSize (EpochSize), + SlotNo (SlotNo), + binOpEpochNo + ) import Cardano.Slotting.Time ( SlotLength (getSlotLength), addRelativeTime, @@ -35,7 +40,7 @@ unsafeLinearExtendEpochInfo basisSlot underlyingEI = else do SlotNo lkeStart <- epochInfoFirst_ underlyingEI lke EpochSize sz <- epochInfoSize_ underlyingEI en - let EpochNo numEpochs = en - lke + let EpochNo numEpochs = binOpEpochNo (-) en lke pure . SlotNo $ lkeStart + (numEpochs * sz) goEpoch = \sn -> if sn <= basisSlot @@ -45,7 +50,7 @@ unsafeLinearExtendEpochInfo basisSlot underlyingEI = lkeStart <- epochInfoFirst_ underlyingEI lke EpochSize sz <- epochInfoSize_ underlyingEI lke let SlotNo slotsForward = sn - lkeStart - pure . (lke +) . EpochNo $ slotsForward `div` sz + pure . binOpEpochNo (+) lke . EpochNo $ slotsForward `div` sz goTime = \sn -> if sn <= basisSlot then epochInfoSlotToRelativeTime_ underlyingEI sn diff --git a/cardano-slotting/src/Cardano/Slotting/Slot.hs b/cardano-slotting/src/Cardano/Slotting/Slot.hs index b5ee4f6ad..1770fff55 100644 --- a/cardano-slotting/src/Cardano/Slotting/Slot.hs +++ b/cardano-slotting/src/Cardano/Slotting/Slot.hs @@ -17,6 +17,7 @@ module Cardano.Slotting.Slot withOriginFromMaybe, EpochNo (..), EpochSize (..), + binOpEpochNo, ) where @@ -114,9 +115,13 @@ withOriginFromMaybe (Just t) = At t newtype EpochNo = EpochNo {unEpochNo :: Word64} deriving stock (Eq, Ord, Generic) deriving Show via Quiet EpochNo - deriving newtype (Enum, Num, Serialise, ToCBOR, FromCBOR, NoThunks, ToJSON, FromJSON, NFData) + deriving newtype (Enum, Serialise, ToCBOR, FromCBOR, NoThunks, ToJSON, FromJSON, NFData) newtype EpochSize = EpochSize {unEpochSize :: Word64} deriving stock (Eq, Ord, Generic) deriving Show via Quiet EpochSize - deriving newtype (Enum, Num, Real, Integral, ToCBOR, FromCBOR, NoThunks, ToJSON, FromJSON, NFData) + deriving newtype (Enum, ToCBOR, FromCBOR, NoThunks, ToJSON, FromJSON, NFData) + +-- | Convenience function for doing binary operations on two `EpochNo`s +binOpEpochNo :: (Word64 -> Word64 -> Word64) -> EpochNo -> EpochNo -> EpochNo +binOpEpochNo op en1 en2 = EpochNo $ op (unEpochNo en1) (unEpochNo en2) diff --git a/cardano-slotting/testlib/Test/Cardano/Slotting/Numeric.hs b/cardano-slotting/testlib/Test/Cardano/Slotting/Numeric.hs new file mode 100644 index 000000000..96d3c2494 --- /dev/null +++ b/cardano-slotting/testlib/Test/Cardano/Slotting/Numeric.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE DerivingStrategies #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# OPTIONS_GHC -Wno-orphans #-} + +module Test.Cardano.Slotting.Numeric () where + +import Cardano.Slotting.Slot + ( EpochSize (EpochSize), + EpochNo (EpochNo), + ) + +deriving newtype instance Num EpochNo + +deriving newtype instance Num EpochSize + +deriving newtype instance Real EpochSize + +deriving newtype instance Integral EpochSize From 90ed90d4a53d748cd372914d12912dd7e085ba59 Mon Sep 17 00:00:00 2001 From: Lucsanszky Date: Tue, 13 Feb 2024 01:37:47 +0100 Subject: [PATCH 53/75] Add `EpochInterval` from `cardano-ledger` * Also add `addEpochInterval` --- cardano-slotting/CHANGELOG.md | 1 + cardano-slotting/src/Cardano/Slotting/Slot.hs | 15 ++++++++++++++- 2 files changed, 15 insertions(+), 1 deletion(-) diff --git a/cardano-slotting/CHANGELOG.md b/cardano-slotting/CHANGELOG.md index 0760c37a3..16ad1fd32 100644 --- a/cardano-slotting/CHANGELOG.md +++ b/cardano-slotting/CHANGELOG.md @@ -2,6 +2,7 @@ ## 0.2.0.0 +* Add `EpochInterval` and `addEpochInterval` from `cardano-ledger`. * Add `binOpEpochNo` helper function to facilitate binary operations on `EpochNo`. * Remove numeric instances (`Num`, `Integral`, `Real`) of `EpochNo` and diff --git a/cardano-slotting/src/Cardano/Slotting/Slot.hs b/cardano-slotting/src/Cardano/Slotting/Slot.hs index 1770fff55..0f4a34552 100644 --- a/cardano-slotting/src/Cardano/Slotting/Slot.hs +++ b/cardano-slotting/src/Cardano/Slotting/Slot.hs @@ -17,7 +17,9 @@ module Cardano.Slotting.Slot withOriginFromMaybe, EpochNo (..), EpochSize (..), + EpochInterval (..), binOpEpochNo, + addEpochInterval, ) where @@ -26,7 +28,7 @@ import Codec.Serialise (Serialise (..)) import Control.DeepSeq (NFData (rnf)) import Data.Aeson (FromJSON (..), ToJSON (..), Value (String)) import Data.Typeable (Typeable) -import Data.Word (Word64) +import Data.Word (Word64, Word32) import GHC.Generics (Generic) import Quiet (Quiet (..)) import NoThunks.Class (NoThunks) @@ -122,6 +124,17 @@ newtype EpochSize = EpochSize {unEpochSize :: Word64} deriving Show via Quiet EpochSize deriving newtype (Enum, ToCBOR, FromCBOR, NoThunks, ToJSON, FromJSON, NFData) +newtype EpochInterval = EpochInterval + { unEpochInterval :: Word32 + } + deriving (Eq, Ord, Generic) + deriving (Show) via Quiet EpochInterval + deriving newtype (NoThunks, NFData, ToJSON, FromJSON, ToCBOR, FromCBOR) + -- | Convenience function for doing binary operations on two `EpochNo`s binOpEpochNo :: (Word64 -> Word64 -> Word64) -> EpochNo -> EpochNo -> EpochNo binOpEpochNo op en1 en2 = EpochNo $ op (unEpochNo en1) (unEpochNo en2) + +-- | Add a EpochInterval (a positive change) to an EpochNo to get a new EpochNo +addEpochInterval :: EpochNo -> EpochInterval -> EpochNo +addEpochInterval (EpochNo n) (EpochInterval m) = EpochNo (n + fromIntegral m) From a1a1f8819adf8513ed42db01e3ac6e9a9c9dec40 Mon Sep 17 00:00:00 2001 From: Lucsanszky Date: Tue, 13 Feb 2024 19:09:16 +0100 Subject: [PATCH 54/75] Add `IsList` instance for `StrictSeq` --- cardano-strict-containers/CHANGELOG.md | 4 ++-- cardano-strict-containers/cardano-strict-containers.cabal | 2 +- cardano-strict-containers/src/Data/Sequence/Strict.hs | 7 +++++++ 3 files changed, 10 insertions(+), 3 deletions(-) diff --git a/cardano-strict-containers/CHANGELOG.md b/cardano-strict-containers/CHANGELOG.md index 0299db000..da27090b5 100644 --- a/cardano-strict-containers/CHANGELOG.md +++ b/cardano-strict-containers/CHANGELOG.md @@ -1,8 +1,8 @@ # Changelog for `cardano-strict-containers` -# 0.1.2.2 +# 0.1.3.0 -* +* Added `IsList` instance for `StrictSeq` # 0.1.2.1 diff --git a/cardano-strict-containers/cardano-strict-containers.cabal b/cardano-strict-containers/cardano-strict-containers.cabal index 35f0759ac..4b215b2ac 100644 --- a/cardano-strict-containers/cardano-strict-containers.cabal +++ b/cardano-strict-containers/cardano-strict-containers.cabal @@ -1,7 +1,7 @@ cabal-version: >=1.10 name: cardano-strict-containers -version: 0.1.2.1 +version: 0.1.3.0 synopsis: Various strict container types license: Apache-2.0 license-files: diff --git a/cardano-strict-containers/src/Data/Sequence/Strict.hs b/cardano-strict-containers/src/Data/Sequence/Strict.hs index f4c271bb4..874a3ea0f 100644 --- a/cardano-strict-containers/src/Data/Sequence/Strict.hs +++ b/cardano-strict-containers/src/Data/Sequence/Strict.hs @@ -2,6 +2,7 @@ {-# LANGUAGE DerivingStrategies #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE ViewPatterns #-} -- | Strict variants of 'Seq' operations. @@ -71,6 +72,7 @@ import Data.Foldable (foldl', toList) import Data.Sequence (Seq) import qualified Data.Sequence as Seq import Data.Unit.Strict (forceElemsToWHNF) +import qualified GHC.Exts as GHC (IsList (..)) import NoThunks.Class (NoThunks (..), noThunksInValues) import Prelude hiding ( drop, @@ -137,6 +139,11 @@ instance ToJSON a => ToJSON (StrictSeq a) where toJSON = toJSON . toList toEncoding = toEncoding . toList +instance GHC.IsList (StrictSeq a) where + type Item (StrictSeq a) = a + fromList = fromList + toList = toList . fromStrict + -- | A helper function for the ':<|' pattern. viewFront :: StrictSeq a -> Maybe (a, StrictSeq a) viewFront (StrictSeq xs) = case Seq.viewl xs of From 518453c1f1c5d1995bbce70eca15ce59a77ace07 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Thu, 15 Feb 2024 12:27:39 +1100 Subject: [PATCH 55/75] cabal.project: Bump index-states (#458) * cabal.project: Bump index-states * Nix updates --- cabal.project | 4 ++-- flake.lock | 18 +++++++++--------- flake.nix | 4 ++-- 3 files changed, 13 insertions(+), 13 deletions(-) diff --git a/cabal.project b/cabal.project index f4e7ccad2..3d4fc9eb6 100644 --- a/cabal.project +++ b/cabal.project @@ -10,9 +10,9 @@ repository cardano-haskell-packages d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee -- The hackage index-state -index-state: 2023-11-08T09:44:54Z +index-state: 2024-02-14T22:42:30Z -- The CHaP index-state -index-state: cardano-haskell-packages 2023-10-05T20:34:14Z +index-state: cardano-haskell-packages 2024-02-14T10:17:08Z packages: base-deriving-via diff --git a/flake.lock b/flake.lock index 1db623947..fc1adcfc9 100644 --- a/flake.lock +++ b/flake.lock @@ -3,11 +3,11 @@ "CHaP": { "flake": false, "locked": { - "lastModified": 1702742788, - "narHash": "sha256-lSU0M27LC0d60cJ2C2Kdo6gBwTCCYRiALbD528CoTtc=", + "lastModified": 1707917276, + "narHash": "sha256-Y4l/aeyOAsOGVypAabuxzXbKoOd1xM+JNCYG//jnh3A=", "owner": "intersectmbo", "repo": "cardano-haskell-packages", - "rev": "4a236a8ad9e3c6d20235de27eacbe3d4de72479c", + "rev": "bb334e5a25a872fc0c879d01afc0e1b7990483a3", "type": "github" }, "original": { @@ -226,11 +226,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1699402991, - "narHash": "sha256-2nQBlA3ygBiIqVPh2J1JwP51rEO0xMjyoOaoJk5PboY=", + "lastModified": 1707870123, + "narHash": "sha256-pOvz6uuPYw3CiPgi63QhNYumoKeyzDh9JOkLDngGWsE=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "9e963602a5b3259dac9cf5e994f0a338fb352b7e", + "rev": "75345eba5d4159e6f54cbdc38785d1e0d0e655e0", "type": "github" }, "original": { @@ -419,11 +419,11 @@ "sodium": "sodium" }, "locked": { - "lastModified": 1696471795, - "narHash": "sha256-aNNvjUtCGXaXSp5M/HSj1SOeLjqLyTRWYbIHqAEeUp0=", + "lastModified": 1707581561, + "narHash": "sha256-A9MT8D7M2We0HCBQbClrA91ZquGf7GU+T6tvjMeUUEA=", "owner": "input-output-hk", "repo": "iohk-nix", - "rev": "91f16fa8acb58b312f94977715c630d8bf77e33e", + "rev": "51469c3fc2c74e24b529f63615670259ba1fee38", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index 644dd428c..6256a8694 100644 --- a/flake.nix +++ b/flake.nix @@ -54,8 +54,8 @@ cabal = "3.10.1.0"; ghcid = "0.8.8"; haskell-language-server = "latest"; - hlint = {}; - weeder = "2.4.1"; + hlint = "3.8"; + weeder = "2.7.0"; }; # Now we use pkgsBuildBuild, to make sure that even in the cross # compilation setting, we don't run into issues where we pick tools From 3554eb6f47968099f9e165a8f1526926ade5b077 Mon Sep 17 00:00:00 2001 From: Moritz Angermann Date: Thu, 15 Feb 2024 16:16:23 +0700 Subject: [PATCH 56/75] Unbreak nix eval (#459) * Unbreak nix eval We need to match shell tools to the compiler. More recent hlint (3.8) is incompatible with ghc928. * Also set weeder to a compatible version. --- flake.nix | 7 +++++-- 1 file changed, 5 insertions(+), 2 deletions(-) diff --git a/flake.nix b/flake.nix index 6256a8694..de4f801ad 100644 --- a/flake.nix +++ b/flake.nix @@ -54,8 +54,11 @@ cabal = "3.10.1.0"; ghcid = "0.8.8"; haskell-language-server = "latest"; - hlint = "3.8"; - weeder = "2.7.0"; + # ghc 9.2.8 comes with base 4.16. + # this disqualifies weeder > 2.4.1 + # and hlint > 3.6.1 + hlint = "3.6.1"; + weeder = "2.4.1"; }; # Now we use pkgsBuildBuild, to make sure that even in the cross # compilation setting, we don't run into issues where we pick tools From 8dd5c654585712016dd1cddd17979a3f8215ec41 Mon Sep 17 00:00:00 2001 From: Lucsanszky Date: Thu, 15 Feb 2024 21:21:59 +0100 Subject: [PATCH 57/75] Update `cardano-slotting` CHANGELOG --- cardano-slotting/CHANGELOG.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/cardano-slotting/CHANGELOG.md b/cardano-slotting/CHANGELOG.md index 16ad1fd32..231636b47 100644 --- a/cardano-slotting/CHANGELOG.md +++ b/cardano-slotting/CHANGELOG.md @@ -1,5 +1,9 @@ # Changelog for `cardano-slotting` +## 0.2.0.1 + +* + ## 0.2.0.0 * Add `EpochInterval` and `addEpochInterval` from `cardano-ledger`. From 7c72a669f657bf94d9cd57c84b9e4cb74ae1ebea Mon Sep 17 00:00:00 2001 From: Lucsanszky Date: Thu, 15 Feb 2024 21:22:33 +0100 Subject: [PATCH 58/75] Update `cardano-strict-containers` CHANGELOG --- cardano-strict-containers/CHANGELOG.md | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/cardano-strict-containers/CHANGELOG.md b/cardano-strict-containers/CHANGELOG.md index da27090b5..30c861cb7 100644 --- a/cardano-strict-containers/CHANGELOG.md +++ b/cardano-strict-containers/CHANGELOG.md @@ -1,5 +1,9 @@ # Changelog for `cardano-strict-containers` +# 0.1.3.1 + +* + # 0.1.3.0 * Added `IsList` instance for `StrictSeq` From 5a093eb5b3a9506244bf9060985ac29507b183c9 Mon Sep 17 00:00:00 2001 From: Lucsanszky Date: Thu, 15 Feb 2024 21:29:51 +0100 Subject: [PATCH 59/75] Update `RELEASING.md` * Update organisation names where needed * Fix the order of the args for `add-from-gtihub.sh` script example --- RELEASING.md | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/RELEASING.md b/RELEASING.md index c9cdecbf8..48bfeb0b8 100644 --- a/RELEASING.md +++ b/RELEASING.md @@ -148,19 +148,19 @@ CHaP. (TODO: implement a script that lists all of the package that fit the above #### Release to CHaP 1. Follow the [CHaP release - instructions](https://github.com/input-output-hk/cardano-haskell-packages#-from-github) + instructions](https://github.com/intersectmbo/cardano-haskell-packages#-from-github) For example: ```shell - $ ./scripts/add-from-github.sh https://github.com/input-output-hk/cardano-base libs/cardano-crypto-class deadbeef... + $ ./scripts/add-from-github.sh https://github.com/intersectmbo/cardano-base deadbeef libs/cardano-crypto-class ... ``` It is important to supply a commit SHA instead of a branch name. -2. Create and merge a PR to https://github.com/input-output-hk/cardano-haskell-packages +2. Create and merge a PR to https://github.com/intersectmbo/cardano-haskell-packages with the release(s). In case that a current release causes breakage on some downstream package due to that package lacking upper bounds, you will require to [add a revision - for that package](https://github.com/input-output-hk/cardano-haskell-packages#how-to-add-a-new-package-metadata-revision) that fixes the bounds in the same PR as the release. Also it is + for that package](https://github.com/intersectmbo/cardano-haskell-packages#how-to-add-a-new-package-metadata-revision) that fixes the bounds in the same PR as the release. Also it is necessary to notify the maintainers of the package via a bug report or a PR with a fix. 3. Once the PR is merged then create a git tag with the same version for the same git SHA @@ -241,7 +241,7 @@ Currently there are no such packages that fit the criteria below, but this could the future. We release all of the packages in this repo to [CHaP (Cardano Haskell -Packages)](https://github.com/input-output-hk/cardano-haskell-packages). However, packages +Packages)](https://github.com/intersectmbo/cardano-haskell-packages). However, packages can be added to the repo that are either used for testing, debugging or benchmarking and do not deserve to be released into the World. They will neither be released nor versioned. Bounds on the local dependencies do not need to be updated for such packages, From c038feba1b5d942080d7ddbd93eaaf57726ed715 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Mon, 26 Feb 2024 10:50:11 +1100 Subject: [PATCH 60/75] Improve Github Actions Mainly take fixes and changes from other packages to normalize GHAs across repos. --- .github/workflows/haskell.yml | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 109706ec1..100f223b5 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -66,15 +66,20 @@ jobs: echo "# cabal.project.local" cat cabal.project.local + - name: Build dry run + run: cabal build all --enable-tests --dry-run --minimize-conflict-set + - name: Record dependencies id: record-deps run: | # The tests call out to msys2 commands. We generally do not want to mix toolchains, so # we are very deliberate about only adding msys64 to the path where absolutely necessary. ${{ (runner.os == 'Windows' && '$env:PATH=("C:\msys64\mingw64\bin;{0}" -f $env:PATH)') || '' }} - cabal build all --dry-run cat dist-newstyle/cache/plan.json | jq -r '."install-plan"[].id' | sort | uniq > dependencies.txt + - name: Install dependencies + run: cabal build all --enable-tests --only-dependencies -j --ghc-option=-j4 + - name: Cache Cabal store uses: actions/cache@v3 with: @@ -83,9 +88,6 @@ jobs: dist-newstyle key: cache-${{ env.CABAL_CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dependencies.txt') }} - - name: Install dependencies - run: cabal build all --enable-tests --only-dependencies -j --ghc-option=-j4 - - name: Build [testing] run: cabal build all --enable-tests -j --ghc-option=-j4 @@ -99,7 +101,8 @@ jobs: - name: Build strict-checked-vars with invariants run: cabal build -f+checktvarinvariants -f+checkmvarinvariants strict-checked-vars - - uses: actions/upload-artifact@v3 + - name: Save Artifact + uses: actions/upload-artifact@v3 with: name: Build & test logs path: | From bda48042a3cac81145f7e1ac2a728f4fb300b003 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Wed, 28 Feb 2024 10:45:25 +1100 Subject: [PATCH 61/75] CI: Actually use the cache dependencies Previously the GHAs would store the cache after building the dependencies but never restore them. Did a thorough investigation of the issue and added proper comments about how it works and why. --- .github/workflows/haskell.yml | 23 ++++++++++++++++++++++- 1 file changed, 22 insertions(+), 1 deletion(-) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 100f223b5..0157fe92a 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -66,9 +66,12 @@ jobs: echo "# cabal.project.local" cat cabal.project.local + # A dry run `build all` operation does *NOT* downlaod anything, it just looks at the package + # indices to generate an install plan. - name: Build dry run run: cabal build all --enable-tests --dry-run --minimize-conflict-set + # From the install plan we generate a dependency list. - name: Record dependencies id: record-deps run: | @@ -77,17 +80,35 @@ jobs: ${{ (runner.os == 'Windows' && '$env:PATH=("C:\msys64\mingw64\bin;{0}" -f $env:PATH)') || '' }} cat dist-newstyle/cache/plan.json | jq -r '."install-plan"[].id' | sort | uniq > dependencies.txt + # From the dependency list we restore the cached dependencies. + # We use the hash of `dependencies.txt` as part of the cache key because that will be stable + # until the `index-state` values in the `cabal.project` file changes. + - name: Restore cached dependencies + uses: actions/cache/restore@v4 + id: cache + with: + path: | + ${{ steps.setup-haskell.outputs.cabal-store }} + dist-newstyle + key: cache-${{ env.CABAL_CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dependencies.txt') }} + + # Now we install the dependencies. If the cache was found and restored in the previous step, + # this should be a no-op, but if the cache key was not found we need to build stuff so we can + # cache it for the next step. - name: Install dependencies run: cabal build all --enable-tests --only-dependencies -j --ghc-option=-j4 + # Always store the cabal cache. + # This may fail (benign failure) if the cache key is already populated. - name: Cache Cabal store - uses: actions/cache@v3 + uses: actions/cache/save@v4 with: path: | ${{ steps.setup-haskell.outputs.cabal-store }} dist-newstyle key: cache-${{ env.CABAL_CACHE_VERSION }}-${{ runner.os }}-${{ matrix.ghc }}-${{ hashFiles('dependencies.txt') }} + # Now we build. - name: Build [testing] run: cabal build all --enable-tests -j --ghc-option=-j4 From bac5a475d662356203a9e1331a366998b374bbf9 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Mon, 11 Mar 2024 15:35:51 +1100 Subject: [PATCH 62/75] Add cardano-git-rev package The `gitRev` function is now a TH splce which will always be run at the call site. --- cabal.project | 5 +- cardano-git-rev/LICENSE | 177 ++++++++++++++++++ cardano-git-rev/NOTICE | 14 ++ cardano-git-rev/README.md | 11 ++ cardano-git-rev/Setup.hs | 2 + cardano-git-rev/cardano-git-rev.cabal | 41 ++++ cardano-git-rev/cbits/rev.c | 11 ++ cardano-git-rev/src/Cardano/Git/Rev.hs | 52 +++++ cardano-git-rev/src/Cardano/Git/RevFromGit.hs | 33 ++++ 9 files changed, 344 insertions(+), 2 deletions(-) create mode 100644 cardano-git-rev/LICENSE create mode 100644 cardano-git-rev/NOTICE create mode 100644 cardano-git-rev/README.md create mode 100644 cardano-git-rev/Setup.hs create mode 100644 cardano-git-rev/cardano-git-rev.cabal create mode 100644 cardano-git-rev/cbits/rev.c create mode 100644 cardano-git-rev/src/Cardano/Git/Rev.hs create mode 100644 cardano-git-rev/src/Cardano/Git/RevFromGit.hs diff --git a/cabal.project b/cabal.project index 3d4fc9eb6..557c32f31 100644 --- a/cabal.project +++ b/cabal.project @@ -10,9 +10,9 @@ repository cardano-haskell-packages d4a35cd3121aa00d18544bb0ac01c3e1691d618f462c46129271bccf39f7e8ee -- The hackage index-state -index-state: 2024-02-14T22:42:30Z +index-state: 2024-03-11T03:33:05Z -- The CHaP index-state -index-state: cardano-haskell-packages 2024-02-14T10:17:08Z +index-state: cardano-haskell-packages 2024-03-08T10:14:14Z packages: base-deriving-via @@ -21,6 +21,7 @@ packages: cardano-crypto-class cardano-crypto-praos cardano-crypto-tests + cardano-git-rev cardano-slotting cardano-strict-containers cardano-mempool diff --git a/cardano-git-rev/LICENSE b/cardano-git-rev/LICENSE new file mode 100644 index 000000000..f433b1a53 --- /dev/null +++ b/cardano-git-rev/LICENSE @@ -0,0 +1,177 @@ + + 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 diff --git a/cardano-git-rev/NOTICE b/cardano-git-rev/NOTICE new file mode 100644 index 000000000..3444d4dd1 --- /dev/null +++ b/cardano-git-rev/NOTICE @@ -0,0 +1,14 @@ +Copyright 2022-2023 Input Output Global Inc (IOG). + +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/cardano-git-rev/README.md b/cardano-git-rev/README.md new file mode 100644 index 000000000..fc6548dfc --- /dev/null +++ b/cardano-git-rev/README.md @@ -0,0 +1,11 @@ +# Cardano Git Rev + +This package exposes functions to provide git information for `cardano-node`. + +`cardano-node` support building via `nix` and `cabal` + +When building with `nix` the git executable and git metadata isn't available so the +git revision is embedded as a series of 40 zeros during the build. After the nix build +is finished the executable is patched with the correct git sha. See [set-git-rev.hs][set-git-rev.hs] + +[set-git-rev.hs]: https://github.com/input-output-hk/iohk-nix/blob/master/overlays/haskell-nix-extra/utils/set-git-rev.hs diff --git a/cardano-git-rev/Setup.hs b/cardano-git-rev/Setup.hs new file mode 100644 index 000000000..44671092b --- /dev/null +++ b/cardano-git-rev/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cardano-git-rev/cardano-git-rev.cabal b/cardano-git-rev/cardano-git-rev.cabal new file mode 100644 index 000000000..5f96a7e31 --- /dev/null +++ b/cardano-git-rev/cardano-git-rev.cabal @@ -0,0 +1,41 @@ +cabal-version: 3.0 + +name: cardano-git-rev +version: 0.2.0.0 +synopsis: Git revisioning +description: Embeds git revision into Haskell packages. +category: Cardano, + Versioning, +copyright: 2022-2023 Input Output Global Inc (IOG). +author: IOHK +maintainer: operations@iohk.io +license: Apache-2.0 +license-files: LICENSE + NOTICE +build-type: Simple +extra-source-files: README.md + +common project-config + default-language: Haskell2010 + build-depends: base >= 4.14 && < 5 + + ghc-options: -Wall + -Wcompat + -Wincomplete-record-updates + -Wincomplete-uni-patterns + -Wpartial-fields + -Wredundant-constraints + -Wunused-packages + +library + import: project-config + + hs-source-dirs: src + c-sources: cbits/rev.c + + exposed-modules: Cardano.Git.Rev + Cardano.Git.RevFromGit + + build-depends: process + , template-haskell + , text diff --git a/cardano-git-rev/cbits/rev.c b/cardano-git-rev/cbits/rev.c new file mode 100644 index 000000000..927898388 --- /dev/null +++ b/cardano-git-rev/cbits/rev.c @@ -0,0 +1,11 @@ +// +char _cardano_git_rev[68] + = "fe" + "gitrev" + "0000000000" + "0000000040" + "0000000000" + "0000000000" + "0000000000" + "0000000000" + ; \ No newline at end of file diff --git a/cardano-git-rev/src/Cardano/Git/Rev.hs b/cardano-git-rev/src/Cardano/Git/Rev.hs new file mode 100644 index 000000000..3e55c159e --- /dev/null +++ b/cardano-git-rev/src/Cardano/Git/Rev.hs @@ -0,0 +1,52 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +module Cardano.Git.Rev + ( gitRev + ) where + +import Data.Text (Text) +import qualified Data.Text as T + +#if !defined(arm_HOST_ARCH) +import Cardano.Git.RevFromGit (gitRevFromGit) +#endif +import Foreign.C.String (CString) +import GHC.Foreign (peekCStringLen) +import Language.Haskell.TH (Exp, Q) +import System.IO (utf8) +import System.IO.Unsafe (unsafeDupablePerformIO) + +foreign import ccall "&_cardano_git_rev" c_gitrev :: CString + +-- This must be a TH splice to ensure the git commit is captured at build time. +-- ie called as `$(gitRev)`. +gitRev :: Q Exp +gitRev = + [| if + | gitRevEmbed /= zeroRev -> gitRevEmbed + | T.null fromGit -> zeroRev + | otherwise -> fromGit + |] + +-- Git revision embedded after compilation using +-- Data.FileEmbed.injectWith. If nothing has been injected, +-- this will be filled with 0 characters. +gitRevEmbed :: Text +gitRevEmbed = T.pack $ drop 28 $ unsafeDupablePerformIO (peekCStringLen utf8 (c_gitrev, 68)) + +-- Git revision found during compilation by running git. If +-- git could not be run, then this will be empty. +fromGit :: Text +#if defined(arm_HOST_ARCH) + -- cross compiling to arm fails; due to a linker bug +fromGit = "" +#else +fromGit = T.strip (T.pack $(gitRevFromGit)) +#endif + +zeroRev :: Text +zeroRev = "0000000000000000000000000000000000000000" diff --git a/cardano-git-rev/src/Cardano/Git/RevFromGit.hs b/cardano-git-rev/src/Cardano/Git/RevFromGit.hs new file mode 100644 index 000000000..b60314ff2 --- /dev/null +++ b/cardano-git-rev/src/Cardano/Git/RevFromGit.hs @@ -0,0 +1,33 @@ +module Cardano.Git.RevFromGit + ( gitRevFromGit + ) where + +import Control.Exception (catch) +import System.Exit (ExitCode (..)) +import qualified System.IO as IO +import System.IO.Error (isDoesNotExistError) +import System.Process (readProcessWithExitCode) + +import qualified Language.Haskell.TH as TH + +-- | Git revision found by running git rev-parse. If git could not be +-- executed, then this will be an empty string. +gitRevFromGit :: TH.Q TH.Exp +gitRevFromGit = + TH.LitE . TH.StringL <$> TH.runIO runGitRevParse + where + runGitRevParse :: IO String + runGitRevParse = do + (exitCode, output, errorMessage) <- readProcessWithExitCode_ "git" ["rev-parse", "--verify", "HEAD"] "" + case exitCode of + ExitSuccess -> pure output + ExitFailure _ -> do + IO.hPutStrLn IO.stderr $ "WARNING: " ++ errorMessage + pure "" + + readProcessWithExitCode_ :: FilePath -> [String] -> String -> IO (ExitCode, String, String) + readProcessWithExitCode_ cmd args input = + catch (readProcessWithExitCode cmd args input) $ \e -> + if isDoesNotExistError e + then return (ExitFailure 127, "", show e) + else return (ExitFailure 999, "", show e) From d171615ebab4454929920d2c782ba659384d19a5 Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Fri, 15 Mar 2024 09:11:15 +1100 Subject: [PATCH 63/75] Fix gitRev TH splice Previously we had a TH quotation calling a TH splce, but that meant that the TH splice was, under certain curcumstances, being cached in the object file in `~/.cabal/store`. Solution is to only use one level of TH, so the splice is only evaluated once. --- cardano-git-rev/cardano-git-rev.cabal | 1 - cardano-git-rev/src/Cardano/Git/Rev.hs | 59 +++++++++++++------ cardano-git-rev/src/Cardano/Git/RevFromGit.hs | 33 ----------- 3 files changed, 40 insertions(+), 53 deletions(-) delete mode 100644 cardano-git-rev/src/Cardano/Git/RevFromGit.hs diff --git a/cardano-git-rev/cardano-git-rev.cabal b/cardano-git-rev/cardano-git-rev.cabal index 5f96a7e31..273402fbb 100644 --- a/cardano-git-rev/cardano-git-rev.cabal +++ b/cardano-git-rev/cardano-git-rev.cabal @@ -34,7 +34,6 @@ library c-sources: cbits/rev.c exposed-modules: Cardano.Git.Rev - Cardano.Git.RevFromGit build-depends: process , template-haskell diff --git a/cardano-git-rev/src/Cardano/Git/Rev.hs b/cardano-git-rev/src/Cardano/Git/Rev.hs index 3e55c159e..2e69c1501 100644 --- a/cardano-git-rev/src/Cardano/Git/Rev.hs +++ b/cardano-git-rev/src/Cardano/Git/Rev.hs @@ -9,44 +9,65 @@ module Cardano.Git.Rev ) where import Data.Text (Text) -import qualified Data.Text as T +import qualified Data.Text as Text -#if !defined(arm_HOST_ARCH) -import Cardano.Git.RevFromGit (gitRevFromGit) -#endif import Foreign.C.String (CString) import GHC.Foreign (peekCStringLen) import Language.Haskell.TH (Exp, Q) +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Syntax as TH import System.IO (utf8) import System.IO.Unsafe (unsafeDupablePerformIO) +#if !defined(arm_HOST_ARCH) +import Control.Exception (catch) +import System.Exit (ExitCode (..)) +import qualified System.IO as IO +import System.IO.Error (isDoesNotExistError) +import System.Process (readProcessWithExitCode) +#endif + foreign import ccall "&_cardano_git_rev" c_gitrev :: CString -- This must be a TH splice to ensure the git commit is captured at build time. -- ie called as `$(gitRev)`. gitRev :: Q Exp -gitRev = - [| if - | gitRevEmbed /= zeroRev -> gitRevEmbed - | T.null fromGit -> zeroRev - | otherwise -> fromGit - |] +gitRev + | gitRevEmbed /= zeroRev = textE gitRevEmbed + | otherwise = +#if defined(arm_HOST_ARCH) + -- cross compiling to arm fails; due to a linker bug + textE zeroRev +#else + textE =<< TH.runIO runGitRevParse +#endif -- Git revision embedded after compilation using -- Data.FileEmbed.injectWith. If nothing has been injected, -- this will be filled with 0 characters. gitRevEmbed :: Text -gitRevEmbed = T.pack $ drop 28 $ unsafeDupablePerformIO (peekCStringLen utf8 (c_gitrev, 68)) +gitRevEmbed = Text.pack $ drop 28 $ unsafeDupablePerformIO (peekCStringLen utf8 (c_gitrev, 68)) --- Git revision found during compilation by running git. If --- git could not be run, then this will be empty. -fromGit :: Text -#if defined(arm_HOST_ARCH) - -- cross compiling to arm fails; due to a linker bug -fromGit = "" -#else -fromGit = T.strip (T.pack $(gitRevFromGit)) +#if !defined(arm_HOST_ARCH) +runGitRevParse :: IO Text +runGitRevParse = do + (exitCode, output, errorMessage) <- readProcessWithExitCode_ "git" ["rev-parse", "--verify", "HEAD"] "" + case exitCode of + ExitSuccess -> pure $ Text.strip (Text.pack output) + ExitFailure _ -> do + IO.hPutStrLn IO.stderr $ "WARNING: " ++ errorMessage + pure zeroRev + where + readProcessWithExitCode_ :: FilePath -> [String] -> String -> IO (ExitCode, String, String) + readProcessWithExitCode_ cmd args input = + catch (readProcessWithExitCode cmd args input) $ \e -> + if isDoesNotExistError e + then pure (ExitFailure 127, "", show e) + else pure (ExitFailure 999, "", show e) #endif +textE :: Text -> Q Exp +textE = TH.lift + zeroRev :: Text zeroRev = "0000000000000000000000000000000000000000" diff --git a/cardano-git-rev/src/Cardano/Git/RevFromGit.hs b/cardano-git-rev/src/Cardano/Git/RevFromGit.hs deleted file mode 100644 index b60314ff2..000000000 --- a/cardano-git-rev/src/Cardano/Git/RevFromGit.hs +++ /dev/null @@ -1,33 +0,0 @@ -module Cardano.Git.RevFromGit - ( gitRevFromGit - ) where - -import Control.Exception (catch) -import System.Exit (ExitCode (..)) -import qualified System.IO as IO -import System.IO.Error (isDoesNotExistError) -import System.Process (readProcessWithExitCode) - -import qualified Language.Haskell.TH as TH - --- | Git revision found by running git rev-parse. If git could not be --- executed, then this will be an empty string. -gitRevFromGit :: TH.Q TH.Exp -gitRevFromGit = - TH.LitE . TH.StringL <$> TH.runIO runGitRevParse - where - runGitRevParse :: IO String - runGitRevParse = do - (exitCode, output, errorMessage) <- readProcessWithExitCode_ "git" ["rev-parse", "--verify", "HEAD"] "" - case exitCode of - ExitSuccess -> pure output - ExitFailure _ -> do - IO.hPutStrLn IO.stderr $ "WARNING: " ++ errorMessage - pure "" - - readProcessWithExitCode_ :: FilePath -> [String] -> String -> IO (ExitCode, String, String) - readProcessWithExitCode_ cmd args input = - catch (readProcessWithExitCode cmd args input) $ \e -> - if isDoesNotExistError e - then return (ExitFailure 127, "", show e) - else return (ExitFailure 999, "", show e) From 206982a5e5753f81e02699366cedceaa1891db2d Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Fri, 15 Mar 2024 09:11:20 +1100 Subject: [PATCH 64/75] cardano-git-rev.cabal: Bump version for upload to CHaP --- cardano-git-rev/cardano-git-rev.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cardano-git-rev/cardano-git-rev.cabal b/cardano-git-rev/cardano-git-rev.cabal index 273402fbb..c220f9b0a 100644 --- a/cardano-git-rev/cardano-git-rev.cabal +++ b/cardano-git-rev/cardano-git-rev.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: cardano-git-rev -version: 0.2.0.0 +version: 0.2.1.0 synopsis: Git revisioning description: Embeds git revision into Haskell packages. category: Cardano, From 28b8fa6277defccb5ba7a3d754fcf2832a72a7a6 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Fri, 15 Mar 2024 11:01:55 +0100 Subject: [PATCH 65/75] cardano-git-rev: use just one CPP clause This helps in a follow-up commit. --- cardano-git-rev/src/Cardano/Git/Rev.hs | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/cardano-git-rev/src/Cardano/Git/Rev.hs b/cardano-git-rev/src/Cardano/Git/Rev.hs index 2e69c1501..5b73e163d 100644 --- a/cardano-git-rev/src/Cardano/Git/Rev.hs +++ b/cardano-git-rev/src/Cardano/Git/Rev.hs @@ -35,12 +35,7 @@ gitRev :: Q Exp gitRev | gitRevEmbed /= zeroRev = textE gitRevEmbed | otherwise = -#if defined(arm_HOST_ARCH) - -- cross compiling to arm fails; due to a linker bug - textE zeroRev -#else textE =<< TH.runIO runGitRevParse -#endif -- Git revision embedded after compilation using -- Data.FileEmbed.injectWith. If nothing has been injected, @@ -48,8 +43,11 @@ gitRev gitRevEmbed :: Text gitRevEmbed = Text.pack $ drop 28 $ unsafeDupablePerformIO (peekCStringLen utf8 (c_gitrev, 68)) -#if !defined(arm_HOST_ARCH) runGitRevParse :: IO Text +#if defined(arm_HOST_ARCH) +-- cross compiling to arm fails; due to a linker bug +runGitRevParse = pure zeroRev +#else runGitRevParse = do (exitCode, output, errorMessage) <- readProcessWithExitCode_ "git" ["rev-parse", "--verify", "HEAD"] "" case exitCode of From 314f6182c721ba5cc518396b2603d317d6ffb23c Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Fri, 15 Mar 2024 11:03:50 +0100 Subject: [PATCH 66/75] Perform check for embedded git rev at run time Previously, it was performed at compile time, where it will always be false as no rev has been embedded yet. --- cardano-git-rev/src/Cardano/Git/Rev.hs | 9 +++++---- 1 file changed, 5 insertions(+), 4 deletions(-) diff --git a/cardano-git-rev/src/Cardano/Git/Rev.hs b/cardano-git-rev/src/Cardano/Git/Rev.hs index 5b73e163d..51b065c57 100644 --- a/cardano-git-rev/src/Cardano/Git/Rev.hs +++ b/cardano-git-rev/src/Cardano/Git/Rev.hs @@ -32,10 +32,11 @@ foreign import ccall "&_cardano_git_rev" c_gitrev :: CString -- This must be a TH splice to ensure the git commit is captured at build time. -- ie called as `$(gitRev)`. gitRev :: Q Exp -gitRev - | gitRevEmbed /= zeroRev = textE gitRevEmbed - | otherwise = - textE =<< TH.runIO runGitRevParse +gitRev = + [| if + | gitRevEmbed /= zeroRev -> gitRevEmbed + | otherwise -> $(textE =<< TH.runIO runGitRevParse) + |] -- Git revision embedded after compilation using -- Data.FileEmbed.injectWith. If nothing has been injected, From 792ff3d96b892617ab29ec46152d36c470be2f7a Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Mon, 18 Mar 2024 11:25:47 +0100 Subject: [PATCH 67/75] cardano-git-rev: only use `TemplateHaskellQuotes` We don't want to splice something at the top-level in cardano-git-rev, but rather just provide expressions such users can do that in their projects. --- cardano-git-rev/src/Cardano/Git/Rev.hs | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/cardano-git-rev/src/Cardano/Git/Rev.hs b/cardano-git-rev/src/Cardano/Git/Rev.hs index 51b065c57..f87a24110 100644 --- a/cardano-git-rev/src/Cardano/Git/Rev.hs +++ b/cardano-git-rev/src/Cardano/Git/Rev.hs @@ -1,9 +1,15 @@ {-# LANGUAGE CPP #-} {-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE ForeignFunctionInterface #-} +#if __GLASGOW_HASKELL__ >= 900 +{-# LANGUAGE TemplateHaskellQuotes #-} +#else +-- https://gitlab.haskell.org/ghc/ghc/-/merge_requests/2288 +{-# LANGUAGE TemplateHaskell #-} +#endif + module Cardano.Git.Rev ( gitRev ) where From 604d0434984d04a75341104783c45fceb0a0d6df Mon Sep 17 00:00:00 2001 From: Erik de Castro Lopo Date: Mon, 25 Mar 2024 09:01:52 +1100 Subject: [PATCH 68/75] Bump cardano-git-rev version for upload to CHaP --- cardano-git-rev/cardano-git-rev.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/cardano-git-rev/cardano-git-rev.cabal b/cardano-git-rev/cardano-git-rev.cabal index c220f9b0a..51758223f 100644 --- a/cardano-git-rev/cardano-git-rev.cabal +++ b/cardano-git-rev/cardano-git-rev.cabal @@ -1,7 +1,7 @@ cabal-version: 3.0 name: cardano-git-rev -version: 0.2.1.0 +version: 0.2.2.0 synopsis: Git revisioning description: Embeds git revision into Haskell packages. category: Cardano, From c1c476e179def688080976db6aa55e0a750eb44f Mon Sep 17 00:00:00 2001 From: Yvan Sraka Date: Thu, 7 Mar 2024 11:59:41 +0100 Subject: [PATCH 69/75] Cache `dist-newstyle` build artifacts This is used to speed up GitHub Codespace first-launch time --- .devcontainer/Dockerfile | 3 +++ .devcontainer/devcontainer.json | 2 +- .github/workflows/haskell.yml | 8 +++++++- 3 files changed, 11 insertions(+), 2 deletions(-) create mode 100644 .devcontainer/Dockerfile diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile new file mode 100644 index 000000000..42621a137 --- /dev/null +++ b/.devcontainer/Dockerfile @@ -0,0 +1,3 @@ +FROM ghcr.io/input-output-hk/devx-devcontainer:x86_64-linux.ghc96-iog +COPY .. /workspaces/cardano-base +RUN bash -ic "post-create-command" \ No newline at end of file diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json index 89fdf0805..102b8f553 100644 --- a/.devcontainer/devcontainer.json +++ b/.devcontainer/devcontainer.json @@ -1,5 +1,5 @@ { - "image":"ghcr.io/input-output-hk/devx-devcontainer:ghc962-iog", + "dockerFile":"./Dockerfile", "customizations":{ "vscode":{ "extensions":[ diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 0157fe92a..3a07097eb 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -34,7 +34,7 @@ jobs: strategy: fail-fast: false matrix: - ghc: ["8.10.7", "9.2.7", "9.6.2", "9.8.1"] + ghc: ["8.10.7", "9.2.7", "9.6.4", "9.8.1"] os: [ubuntu-latest, macos-latest, windows-latest] env: @@ -148,3 +148,9 @@ jobs: # uses: mxschmitt/action-tmate@v3 # with: # limit-access-to-actor: true + + - name: Cache HLS artifacts (used to speed up GitHub Codespaces bootstrapping) + if: runner.os == 'Linux' && (matrix.ghc == '8.10.7' || matrix.ghc == '9.6.4') + uses: input-output-hk/actions/cache@latest + with: + ghc_version: ${{ matrix.ghc == '8.10.7' && 'ghc810' || matrix.ghc == '9.6.4' && 'ghc96' }} From fb263c0d046bc88f3131565bee4b9cd93a847722 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 22 Feb 2024 12:26:34 +0100 Subject: [PATCH 70/75] strict-checked-vars: allow `io-classes-1.4` and friends --- flake.lock | 6 +++--- strict-checked-vars/strict-checked-vars.cabal | 6 +++--- 2 files changed, 6 insertions(+), 6 deletions(-) diff --git a/flake.lock b/flake.lock index fc1adcfc9..65ef77b4c 100644 --- a/flake.lock +++ b/flake.lock @@ -226,11 +226,11 @@ "hackage": { "flake": false, "locked": { - "lastModified": 1707870123, - "narHash": "sha256-pOvz6uuPYw3CiPgi63QhNYumoKeyzDh9JOkLDngGWsE=", + "lastModified": 1708561382, + "narHash": "sha256-IDr2G3komoctjHALk8wGvDKOF39BaqrdEmjvAOsob5I=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "75345eba5d4159e6f54cbdc38785d1e0d0e655e0", + "rev": "4b07be837c34475fdde3c9bb9903a850b5692bac", "type": "github" }, "original": { diff --git a/strict-checked-vars/strict-checked-vars.cabal b/strict-checked-vars/strict-checked-vars.cabal index 2265d119e..c09ba0ecf 100644 --- a/strict-checked-vars/strict-checked-vars.cabal +++ b/strict-checked-vars/strict-checked-vars.cabal @@ -50,9 +50,9 @@ library default-language: Haskell2010 build-depends: , base >=4.9 && <5 - , io-classes >=1.2 && <1.4 - , strict-mvar >=1.2 && <1.4 - , strict-stm >=1.2 && <1.4 + , io-classes >=1.2 && <1.5 + , strict-mvar >=1.2 && <1.5 + , strict-stm >=1.2 && <1.5 ghc-options: -Wall -Wcompat -Wincomplete-uni-patterns From d5772da0c0b6479dc56816cb7bb9ef2747033e70 Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Thu, 22 Feb 2024 13:51:48 +0100 Subject: [PATCH 71/75] Update `cardano-crypto-class` to `io-classes-1.4.1` --- .../cardano-crypto-class.cabal | 2 +- .../src/Cardano/Crypto/DSIGN/Ed25519.hs | 31 +++++++++---------- .../src/Cardano/Crypto/Libsodium/Hash.hs | 4 +-- .../Crypto/Libsodium/MLockedBytes/Internal.hs | 11 +++---- .../Crypto/Libsodium/Memory/Internal.hs | 24 +++++++------- .../src/Cardano/Crypto/PinnedSizedBytes.hs | 14 ++++----- 6 files changed, 41 insertions(+), 45 deletions(-) diff --git a/cardano-crypto-class/cardano-crypto-class.cabal b/cardano-crypto-class/cardano-crypto-class.cabal index 048b420a5..208e000f6 100644 --- a/cardano-crypto-class/cardano-crypto-class.cabal +++ b/cardano-crypto-class/cardano-crypto-class.cabal @@ -101,7 +101,7 @@ library , cryptonite , deepseq , heapwords - , io-classes + , io-classes >= 1.4.1 , memory , mtl , nothunks diff --git a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519.hs b/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519.hs index f80079276..01aa4a4db 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/DSIGN/Ed25519.hs @@ -36,7 +36,7 @@ import Control.DeepSeq (NFData (..), rwhnf) import Control.Monad ((<$!>), unless, guard) import Control.Monad.Class.MonadST (MonadST (..)) import Control.Monad.Class.MonadThrow (MonadThrow (..), throwIO) -import Control.Monad.ST (ST, stToIO) +import Control.Monad.ST (ST) import Control.Monad.ST.Unsafe (unsafeIOToST) import qualified Data.ByteString as BS import Data.Proxy @@ -109,13 +109,12 @@ cOrThrowError contextDesc cFunName action = do -- result code; if the result code returned is nonzero, fetch the errno, and -- return it. cOrError :: MonadST m => (forall s. ST s Int) -> m (Maybe Errno) -cOrError action = do - withLiftST $ \fromST -> fromST $ do - res <- action - if res == 0 then - return Nothing - else - Just <$> unsafeIOToST getErrno +cOrError action = stToIO $ do + res <- action + if res == 0 then + return Nothing + else + Just <$> unsafeIOToST getErrno -- | Throws an error when 'Just' an 'Errno' is given. throwOnErrno :: MonadThrow m => String -> String -> Maybe Errno -> m () @@ -259,7 +258,7 @@ instance DSIGNMAlgorithm Ed25519DSIGN where mlsbUseAsSizedPtr sk $ \skPtr -> do (psb, maybeErrno) <- psbCreateSizedResult $ \pkPtr -> - withLiftST $ \fromST -> fromST $ do + stToIO $ do cOrError $ unsafeIOToST $ c_crypto_sign_ed25519_sk_to_pk pkPtr skPtr throwOnErrno "deriveVerKeyDSIGNM @Ed25519DSIGN" "c_crypto_sign_ed25519_sk_to_pk" maybeErrno @@ -271,8 +270,8 @@ instance DSIGNMAlgorithm Ed25519DSIGN where in SigEd25519DSIGN <$!> do mlsbUseAsSizedPtr sk $ \skPtr -> do (psb, maybeErrno) <- - psbCreateSizedResult $ \sigPtr -> do - withLiftST $ \fromST -> fromST $ do + psbCreateSizedResult $ \sigPtr -> + stToIO $ do cOrError $ unsafeIOToST $ do BS.useAsCStringLen bs $ \(ptr, len) -> c_crypto_sign_ed25519_detached sigPtr nullPtr (castPtr ptr) (fromIntegral len) skPtr @@ -287,8 +286,7 @@ instance DSIGNMAlgorithm Ed25519DSIGN where sk <- mlsbNewWith allocator mlsbUseAsSizedPtr sk $ \skPtr -> mlockedSeedUseAsCPtr seed $ \seedPtr -> do - maybeErrno <- withLiftST $ \fromST -> - fromST $ allocaSizedST $ \pkPtr -> do + maybeErrno <- stToIO $ allocaSizedST $ \pkPtr -> do cOrError $ unsafeIOToST $ c_crypto_sign_ed25519_seed_keypair pkPtr skPtr (SizedPtr . castPtr $ seedPtr) throwOnErrno "genKeyDSIGNM @Ed25519DSIGN" "c_crypto_sign_ed25519_seed_keypair" maybeErrno @@ -304,10 +302,9 @@ instance DSIGNMAlgorithm Ed25519DSIGN where seed <- mlockedSeedNewWith allocator mlsbUseAsSizedPtr sk $ \skPtr -> mlockedSeedUseAsSizedPtr seed $ \seedPtr -> do - maybeErrno <- withLiftST $ \fromST -> - fromST $ - cOrError $ unsafeIOToST $ - c_crypto_sign_ed25519_sk_to_seed seedPtr skPtr + maybeErrno <- + stToIO $ cOrError $ unsafeIOToST $ + c_crypto_sign_ed25519_sk_to_seed seedPtr skPtr throwOnErrno "genKeyDSIGNM @Ed25519DSIGN" "c_crypto_sign_ed25519_seed_keypair" maybeErrno return seed diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Hash.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Hash.hs index 87d89cf50..4c579fd2d 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Hash.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Hash.hs @@ -49,13 +49,13 @@ expandHashWith expandHashWith allocator h (MLSB sfptr) = do withMLockedForeignPtr sfptr $ \ptr -> do l <- mlockedAllocaWith allocator size1 $ \ptr' -> do - withLiftST $ \liftST -> liftST . unsafeIOToST $ do + stToIO . unsafeIOToST $ do poke ptr' (1 :: Word8) copyMem (castPtr (plusPtr ptr' 1)) ptr size naclDigestPtr h ptr' (fromIntegral size1) r <- mlockedAllocaWith allocator size1 $ \ptr' -> do - withLiftST $ \liftST -> liftST . unsafeIOToST $ do + stToIO . unsafeIOToST $ do poke ptr' (2 :: Word8) copyMem (castPtr (plusPtr ptr' 1)) ptr size naclDigestPtr h ptr' (fromIntegral size1) diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes/Internal.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes/Internal.hs index 3c7ca290a..dcdef2d43 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes/Internal.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/MLockedBytes/Internal.hs @@ -112,8 +112,8 @@ withMLSBChunk mlsb offset action = error $ "Overrun (" ++ show offset ++ " + " ++ show chunkSize ++ " > " ++ show parentSize ++ ")" | otherwise = withMLSB mlsb $ \ptr -> do - fptr <- withLiftST $ \lift -> do - lift $ unsafeIOToST (newForeignPtr_ . castPtr $ plusPtr ptr offset) + fptr <- + stToIO $ unsafeIOToST (newForeignPtr_ . castPtr $ plusPtr ptr offset) action (MLSB $! SFP $! fptr) where chunkSize = fromIntegral (natVal (Proxy @n')) @@ -185,8 +185,7 @@ mlsbFromByteStringWith :: forall n m. (KnownNat n, MonadST m) => MLockedAllocator m -> BS.ByteString -> m (MLockedSizedBytes n) mlsbFromByteStringWith allocator bs = do dst <- mlsbNewWith allocator - withMLSB dst $ \ptr -> do - withLiftST $ \liftST -> liftST . unsafeIOToST $ do + withMLSB dst $ \ptr -> stToIO . unsafeIOToST $ do BS.useAsCStringLen bs $ \(ptrBS, len) -> do copyMem (castPtr ptr) ptrBS (min (fromIntegral len) (mlsbSize dst)) return dst @@ -233,7 +232,7 @@ mlsbAsByteString mlsb@(MLSB (SFP fptr)) = BSI.PS (castForeignPtr fptr) 0 size mlsbToByteString :: forall n m. (KnownNat n, MonadST m) => MLockedSizedBytes n -> m BS.ByteString mlsbToByteString mlsb = withMLSB mlsb $ \ptr -> - withLiftST $ \liftST -> liftST . unsafeIOToST $ BS.packCStringLen (castPtr ptr, size) + stToIO . unsafeIOToST $ BS.packCStringLen (castPtr ptr, size) where size :: Int size = fromIntegral (mlsbSize mlsb) @@ -265,7 +264,7 @@ mlsbCompare :: forall n m. (MonadST m, KnownNat n) => MLockedSizedBytes n -> MLo mlsbCompare (MLSB x) (MLSB y) = withMLockedForeignPtr x $ \x' -> withMLockedForeignPtr y $ \y' -> do - res <- withLiftST $ \fromST -> fromST . unsafeIOToST $ c_sodium_compare x' y' size + res <- stToIO . unsafeIOToST $ c_sodium_compare x' y' size return $ compare res 0 where size = fromInteger $ natVal (Proxy @n) diff --git a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs index b32854db4..68b57392f 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/Libsodium/Memory/Internal.hs @@ -45,7 +45,7 @@ import Control.Exception (Exception, mask_) import Control.Monad (when, void) import Control.Monad.Class.MonadST import Control.Monad.Class.MonadThrow (MonadThrow (bracket)) -import Control.Monad.ST +import Control.Monad.ST (RealWorld, ST) import Control.Monad.ST.Unsafe (unsafeIOToST, unsafeSTToIO) import Data.ByteString (ByteString) import qualified Data.ByteString as BS @@ -84,8 +84,8 @@ withMLockedForeignPtr (SFP fptr) f = do r <$ unsafeIOToMonadST (touchForeignPtr fptr) finalizeMLockedForeignPtr :: MonadST m => MLockedForeignPtr a -> m () -finalizeMLockedForeignPtr (SFP fptr) = withLiftST $ \lift -> - (lift . unsafeIOToST) (finalizeForeignPtr fptr) +finalizeMLockedForeignPtr (SFP fptr) = + unsafeIOToMonadST $ finalizeForeignPtr fptr {-# WARNING traceMLockedForeignPtr "Do not use traceMLockedForeignPtr in production" #-} @@ -95,7 +95,7 @@ traceMLockedForeignPtr fptr = withMLockedForeignPtr fptr $ \ptr -> do traceShowM a unsafeIOToMonadST :: MonadST m => IO a -> m a -unsafeIOToMonadST action = withLiftST ($ unsafeIOToST action) +unsafeIOToMonadST = stToIO . unsafeIOToST makeMLockedPool :: forall n s. KnownNat n => ST s (Pool n s) makeMLockedPool = do @@ -141,21 +141,21 @@ instance Exception AllocatorException mlockedMalloc :: MonadST m => MLockedAllocator m mlockedMalloc = - MLockedAllocator { mlAllocate = \ size -> withLiftST ($ unsafeIOToST (mlockedMallocIO size)) } + MLockedAllocator { mlAllocate = unsafeIOToMonadST . mlockedMallocIO } mlockedMallocIO :: CSize -> IO (MLockedForeignPtr a) mlockedMallocIO size = SFP <$> do if | size <= 32 -> do - coerce $ stToIO $ grabNextBlock mlockedPool32 + fmap coerce $ stToIO $ grabNextBlock mlockedPool32 | size <= 64 -> do - coerce $ stToIO $ grabNextBlock mlockedPool64 + fmap coerce $ stToIO $ grabNextBlock mlockedPool64 | size <= 128 -> do - coerce $ stToIO $ grabNextBlock mlockedPool128 + fmap coerce $ stToIO $ grabNextBlock mlockedPool128 | size <= 256 -> do - coerce $ stToIO $ grabNextBlock mlockedPool256 + fmap coerce $ stToIO $ grabNextBlock mlockedPool256 | size <= 512 -> do - coerce $ stToIO $ grabNextBlock mlockedPool512 + fmap coerce $ stToIO $ grabNextBlock mlockedPool512 | otherwise -> do mask_ $ do ptr <- sodiumMalloc size @@ -193,8 +193,8 @@ allocaBytes size f = unsafeIOToST $ Foreign.allocaBytes size (unsafeSTToIO . f) packByteStringCStringLen :: MonadST m => CStringLen -> m ByteString -packByteStringCStringLen (ptr, len) = - withLiftST $ \lift -> lift . unsafeIOToST $ BS.packCStringLen (ptr, len) +packByteStringCStringLen = + unsafeIOToMonadST . BS.packCStringLen newtype MLockedAllocator m = MLockedAllocator diff --git a/cardano-crypto-class/src/Cardano/Crypto/PinnedSizedBytes.hs b/cardano-crypto-class/src/Cardano/Crypto/PinnedSizedBytes.hs index 1eaabe2cd..b8b13bb73 100644 --- a/cardano-crypto-class/src/Cardano/Crypto/PinnedSizedBytes.hs +++ b/cardano-crypto-class/src/Cardano/Crypto/PinnedSizedBytes.hs @@ -280,9 +280,9 @@ psbUseAsSizedPtr :: PinnedSizedBytes n -> (SizedPtr n -> m r) -> m r -psbUseAsSizedPtr (PSB ba) k = withLiftST $ \lift -> do +psbUseAsSizedPtr (PSB ba) k = do r <- k (SizedPtr $ castPtr $ byteArrayContents ba) - r <$ lift (touch ba) + r <$ stToIO (touch ba) -- | As 'psbCreateResult', but presumes that no useful value is produced: that -- is, the function argument is run only for its side effects. @@ -345,11 +345,11 @@ psbCreateResultLen :: (KnownNat n, MonadST m) => (Ptr Word8 -> CSize -> m r) -> m (PinnedSizedBytes n, r) -psbCreateResultLen f = withLiftST $ \lift -> do +psbCreateResultLen f = do let len :: Int = fromIntegral . natVal $ Proxy @n - mba <- lift (newPinnedByteArray len) + mba <- stToIO (newPinnedByteArray len) res <- f (mutableByteArrayContents mba) (fromIntegral len) - arr <- lift (unsafeFreezeByteArray mba) + arr <- stToIO (unsafeFreezeByteArray mba) pure (PSB arr, res) -- | As 'psbCreateSizedResult', but presumes that no useful value is produced: @@ -413,6 +413,6 @@ runAndTouch :: ByteArray -> (Ptr Word8 -> m a) -> m a -runAndTouch ba f = withLiftST $ \lift -> do +runAndTouch ba f = do r <- f (byteArrayContents ba) - r <$ lift (touch ba) + r <$ stToIO (touch ba) From 5b406a035dd501b64948600e7d4dbfcb803c5dbf Mon Sep 17 00:00:00 2001 From: Alexander Esgen Date: Fri, 23 Feb 2024 11:41:42 +0100 Subject: [PATCH 72/75] strict-checked-vars: add Joris as a maintainer --- strict-checked-vars/strict-checked-vars.cabal | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/strict-checked-vars/strict-checked-vars.cabal b/strict-checked-vars/strict-checked-vars.cabal index c09ba0ecf..c62ba82bb 100644 --- a/strict-checked-vars/strict-checked-vars.cabal +++ b/strict-checked-vars/strict-checked-vars.cabal @@ -16,7 +16,7 @@ license-files: copyright: 2019-2023 Input Output Global Inc (IOG). author: IOG Engineering Team -maintainer: operations@iohk.io +maintainer: operations@iohk.io, Joris Dral category: Concurrency build-type: Simple extra-doc-files: From 8320e40a51dbda49d1220720dd5df601bbb0a2e2 Mon Sep 17 00:00:00 2001 From: Yvan Sraka Date: Wed, 10 Apr 2024 15:38:57 +0200 Subject: [PATCH 73/75] Fix Codespace (no longer call `post-create-command` too early) --- .devcontainer/Dockerfile | 3 --- .devcontainer/devcontainer.json | 10 ++++------ 2 files changed, 4 insertions(+), 9 deletions(-) delete mode 100644 .devcontainer/Dockerfile diff --git a/.devcontainer/Dockerfile b/.devcontainer/Dockerfile deleted file mode 100644 index 42621a137..000000000 --- a/.devcontainer/Dockerfile +++ /dev/null @@ -1,3 +0,0 @@ -FROM ghcr.io/input-output-hk/devx-devcontainer:x86_64-linux.ghc96-iog -COPY .. /workspaces/cardano-base -RUN bash -ic "post-create-command" \ No newline at end of file diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json index 102b8f553..bf1306373 100644 --- a/.devcontainer/devcontainer.json +++ b/.devcontainer/devcontainer.json @@ -1,13 +1,11 @@ { - "dockerFile":"./Dockerfile", + "image":"ghcr.io/input-output-hk/devx-devcontainer:x86_64-linux.ghc96-iog", + "postCreateCommand": "post-create-command", "customizations":{ "vscode":{ "extensions":[ "haskell.haskell" - ], - "settings":{ - "haskell.manageHLS":"PATH" - } + ] } } -} +} \ No newline at end of file From aacea1b57038e8eccae198f3fb5af3b0d564cf5b Mon Sep 17 00:00:00 2001 From: Yvan Sraka Date: Wed, 10 Apr 2024 18:43:17 +0000 Subject: [PATCH 74/75] Update `haskell.yml` --- .github/workflows/haskell.yml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/.github/workflows/haskell.yml b/.github/workflows/haskell.yml index 3a07097eb..1b615b4d0 100644 --- a/.github/workflows/haskell.yml +++ b/.github/workflows/haskell.yml @@ -3,6 +3,8 @@ name: Haskell CI on: pull_request: branches: [ "**" ] + push: + branches: [ "master" ] jobs: whitespace: From 57d838fc196bfcab79d5be3c5a6c98342040ba6a Mon Sep 17 00:00:00 2001 From: Yvan Sraka Date: Fri, 12 Apr 2024 12:03:40 +0200 Subject: [PATCH 75/75] Fix Codespace (call onCreateCommand rather than postCreateCommand) --- .devcontainer/devcontainer.json | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/.devcontainer/devcontainer.json b/.devcontainer/devcontainer.json index bf1306373..267f596a5 100644 --- a/.devcontainer/devcontainer.json +++ b/.devcontainer/devcontainer.json @@ -1,11 +1,12 @@ { "image":"ghcr.io/input-output-hk/devx-devcontainer:x86_64-linux.ghc96-iog", - "postCreateCommand": "post-create-command", + "onCreateCommand": "on-create-command", "customizations":{ "vscode":{ "extensions":[ "haskell.haskell" ] } + // Do not set custom `settings` as they would override devx-container defaults... } } \ No newline at end of file