diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,20 @@ # Revision history for base64 +## 1.0.0.0 + +New epoch time! lots of changes to the API. Please see MIGRATION.md for more info: + +* Add support for GHC 9.x +* Bumped bounds to more modern dependency set +* Introduced `Base64` newtype, located in `Data.Base64.Types`, as well as ADT for associated alphabets. +* Signature for `encodeBase64` has changed so that it produces a `Base64` wrapped value. +* `decodeBase64` and its URLsafe variants now consume a value of type `Base64` and produces a decoded value of the underlying type. +* The *old* `decodeBase64` and its URLsafe variants is now renamed to `decodeBase64Untyped*`. +* Fix for 32-bit systems in which memory barriers were not respected in the encoe loop (see: #56) +* Optimize encode and decode loops to achieve *significant speedup* across the board. + +Thanks to everyone who contributed (especially @sofia-m-a!). + ## 0.4.2.4 * Support for GHC 9.2.x diff --git a/MIGRATION-1.0.md b/MIGRATION-1.0.md new file mode 100644 --- /dev/null +++ b/MIGRATION-1.0.md @@ -0,0 +1,385 @@ +Migration Guide for 1.0 +---- + +Between the last major version (0.4.2.4) and the current major epoch (1.0), many API-related constructs have changed, and I'd like to justify them here and now so that users may have an immortalized explanation for what is most likely a disruptive change to their code. + +## A faster loop + +First, I'd like to say that I don't *like* breaking people's code. As an author and maintainer, I try and make sure that any API breakages are justified either by a significant UX improvement, or by a measurable performance increase large enough to warrant such a breakage. As such, I believe both of these criteria are met by the 0.4.x -> 1.0 upgrade: not only is the API safer to use, but the use of type data to establish the provenance of values encoded by this library also allows the performance-sensitive loops to be much cleaner, eschewing error checking where type data suffices. To prove this point, I've benchmarked the library between these last two epochs. The benchmarks say it all (all benchmarks are done on a Thinkpad P15 Gen 2 Intel i9-11950H, 64GB DDR4, Ubuntu 22.04 with GHC 9.6.3 stock, -O2): + +In `base64-0.4.2.4`: + +``` +benchmarking encode/25/base64-bytestring +time 49.97 ns (49.87 ns .. 50.07 ns) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 49.96 ns (49.86 ns .. 50.14 ns) +std dev 440.1 ps (235.9 ps .. 806.9 ps) + +benchmarking encode/25/base64 +time 34.07 ns (33.62 ns .. 34.56 ns) + 0.999 R² (0.999 R² .. 1.000 R²) +mean 33.88 ns (33.77 ns .. 34.08 ns) +std dev 504.2 ps (268.7 ps .. 773.8 ps) +variance introduced by outliers: 18% (moderately inflated) + +benchmarking encode/100/base64-bytestring +time 111.4 ns (110.6 ns .. 112.4 ns) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 111.7 ns (111.3 ns .. 112.3 ns) +std dev 1.787 ns (1.421 ns .. 2.247 ns) +variance introduced by outliers: 19% (moderately inflated) + +benchmarking encode/100/base64 +time 53.39 ns (53.19 ns .. 53.72 ns) + 1.000 R² (0.999 R² .. 1.000 R²) +mean 54.17 ns (53.60 ns .. 56.40 ns) +std dev 3.163 ns (1.151 ns .. 6.269 ns) +variance introduced by outliers: 78% (severely inflated) + +benchmarking encode/1k/base64-bytestring +time 754.3 ns (750.8 ns .. 759.1 ns) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 766.1 ns (761.4 ns .. 771.5 ns) +std dev 17.44 ns (14.17 ns .. 21.34 ns) +variance introduced by outliers: 29% (moderately inflated) + +benchmarking encode/1k/base64 +time 274.6 ns (273.2 ns .. 275.9 ns) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 276.5 ns (275.4 ns .. 277.6 ns) +std dev 3.863 ns (3.413 ns .. 4.464 ns) +variance introduced by outliers: 14% (moderately inflated) + +benchmarking encode/10k/base64-bytestring +time 7.069 μs (7.054 μs .. 7.094 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 7.100 μs (7.088 μs .. 7.114 μs) +std dev 44.37 ns (37.56 ns .. 54.14 ns) + +benchmarking encode/10k/base64 +time 2.384 μs (2.364 μs .. 2.415 μs) + 0.999 R² (0.998 R² .. 1.000 R²) +mean 2.370 μs (2.363 μs .. 2.395 μs) +std dev 42.25 ns (12.58 ns .. 86.70 ns) +variance introduced by outliers: 18% (moderately inflated) + +benchmarking encode/100k/base64-bytestring +time 70.59 μs (70.26 μs .. 70.84 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 70.11 μs (69.95 μs .. 70.28 μs) +std dev 587.0 ns (508.0 ns .. 684.0 ns) + +benchmarking encode/100k/base64 +time 23.31 μs (23.22 μs .. 23.42 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 23.59 μs (23.49 μs .. 23.72 μs) +std dev 415.2 ns (343.8 ns .. 509.2 ns) +variance introduced by outliers: 14% (moderately inflated) + +benchmarking encode/1mm/base64-bytestring +time 703.6 μs (700.6 μs .. 708.7 μs) + 0.999 R² (0.997 R² .. 1.000 R²) +mean 703.1 μs (699.8 μs .. 720.0 μs) +std dev 18.82 μs (5.505 μs .. 43.88 μs) +variance introduced by outliers: 17% (moderately inflated) + +benchmarking encode/1mm/base64 +time 238.4 μs (235.5 μs .. 241.4 μs) + 0.999 R² (0.998 R² .. 1.000 R²) +mean 234.6 μs (233.4 μs .. 236.5 μs) +std dev 4.771 μs (3.256 μs .. 7.810 μs) +variance introduced by outliers: 13% (moderately inflated) + +benchmarking decode/25/base64-bytestring +time 54.36 ns (54.18 ns .. 54.55 ns) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 55.11 ns (54.74 ns .. 55.63 ns) +std dev 1.441 ns (1.090 ns .. 2.068 ns) +variance introduced by outliers: 41% (moderately inflated) + +benchmarking decode/25/base64 +time 53.04 ns (52.57 ns .. 53.80 ns) + 0.999 R² (0.999 R² .. 1.000 R²) +mean 53.42 ns (53.07 ns .. 53.93 ns) +std dev 1.378 ns (1.061 ns .. 1.774 ns) +variance introduced by outliers: 40% (moderately inflated) + +benchmarking decode/100/base64-bytestring +time 145.2 ns (143.8 ns .. 146.9 ns) + 0.999 R² (0.999 R² .. 1.000 R²) +mean 145.3 ns (144.6 ns .. 146.5 ns) +std dev 3.165 ns (2.441 ns .. 4.254 ns) +variance introduced by outliers: 30% (moderately inflated) + +benchmarking decode/100/base64 +time 140.6 ns (140.0 ns .. 141.2 ns) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 140.6 ns (140.2 ns .. 141.4 ns) +std dev 1.984 ns (1.243 ns .. 3.410 ns) +variance introduced by outliers: 16% (moderately inflated) + +benchmarking decode/1k/base64-bytestring +time 1.115 μs (1.112 μs .. 1.118 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 1.120 μs (1.118 μs .. 1.123 μs) +std dev 8.290 ns (6.907 ns .. 10.42 ns) + +benchmarking decode/1k/base64 +time 1.109 μs (1.102 μs .. 1.119 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 1.104 μs (1.102 μs .. 1.108 μs) +std dev 9.031 ns (4.358 ns .. 17.14 ns) + +benchmarking decode/10k/base64-bytestring +time 10.86 μs (10.84 μs .. 10.89 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 10.90 μs (10.88 μs .. 10.93 μs) +std dev 93.78 ns (71.73 ns .. 143.6 ns) + +benchmarking decode/10k/base64 +time 10.68 μs (10.65 μs .. 10.72 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 10.68 μs (10.66 μs .. 10.70 μs) +std dev 51.31 ns (36.41 ns .. 70.46 ns) + +benchmarking decode/100k/base64-bytestring +time 108.4 μs (108.0 μs .. 108.8 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 108.1 μs (108.0 μs .. 108.4 μs) +std dev 643.5 ns (450.9 ns .. 1.043 μs) + +benchmarking decode/100k/base64 +time 106.0 μs (105.9 μs .. 106.2 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 106.1 μs (106.0 μs .. 106.3 μs) +std dev 586.1 ns (405.8 ns .. 932.3 ns) + +benchmarking decode/1mm/base64-bytestring +time 1.076 ms (1.074 ms .. 1.079 ms) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 1.080 ms (1.078 ms .. 1.082 ms) +std dev 6.833 μs (5.938 μs .. 7.717 μs) + +benchmarking decode/1mm/base64 +time 1.054 ms (1.050 ms .. 1.056 ms) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 1.051 ms (1.049 ms .. 1.052 ms) +std dev 4.359 μs (3.498 μs .. 5.253 μs) + +``` + +vs in `base64-1.0.0.0`: + +``` +benchmarking encode/25/base64-bytestring +time 52.04 ns (51.77 ns .. 52.43 ns) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 52.23 ns (52.02 ns .. 52.50 ns) +std dev 790.3 ps (649.7 ps .. 981.1 ps) +variance introduced by outliers: 19% (moderately inflated) + +benchmarking encode/25/base64 +time 35.88 ns (35.50 ns .. 36.15 ns) + 1.000 R² (0.999 R² .. 1.000 R²) +mean 35.44 ns (35.28 ns .. 35.61 ns) +std dev 609.5 ps (466.8 ps .. 835.9 ps) +variance introduced by outliers: 23% (moderately inflated) + +benchmarking encode/100/base64-bytestring +time 116.5 ns (115.6 ns .. 117.5 ns) + 0.999 R² (0.999 R² .. 0.999 R²) +mean 119.1 ns (117.9 ns .. 120.9 ns) +std dev 4.946 ns (3.674 ns .. 6.871 ns) +variance introduced by outliers: 62% (severely inflated) + +benchmarking encode/100/base64 +time 54.59 ns (54.15 ns .. 54.97 ns) + 1.000 R² (0.999 R² .. 1.000 R²) +mean 54.84 ns (54.53 ns .. 55.11 ns) +std dev 967.4 ps (759.0 ps .. 1.233 ns) +variance introduced by outliers: 24% (moderately inflated) + +benchmarking encode/1k/base64-bytestring +time 792.6 ns (789.2 ns .. 796.2 ns) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 797.4 ns (794.2 ns .. 801.2 ns) +std dev 12.70 ns (10.10 ns .. 16.66 ns) +variance introduced by outliers: 17% (moderately inflated) + +benchmarking encode/1k/base64 +time 300.4 ns (296.8 ns .. 304.4 ns) + 0.998 R² (0.996 R² .. 1.000 R²) +mean 294.8 ns (291.3 ns .. 301.3 ns) +std dev 14.55 ns (9.522 ns .. 25.93 ns) +variance introduced by outliers: 68% (severely inflated) + +benchmarking encode/10k/base64-bytestring +time 7.852 μs (7.806 μs .. 7.917 μs) + 0.999 R² (0.999 R² .. 1.000 R²) +mean 7.849 μs (7.810 μs .. 7.923 μs) +std dev 172.2 ns (88.74 ns .. 277.8 ns) +variance introduced by outliers: 23% (moderately inflated) + +benchmarking encode/10k/base64 +time 2.748 μs (2.724 μs .. 2.773 μs) + 0.999 R² (0.998 R² .. 1.000 R²) +mean 2.737 μs (2.717 μs .. 2.802 μs) +std dev 108.8 ns (48.74 ns .. 219.4 ns) +variance introduced by outliers: 53% (severely inflated) + +benchmarking encode/100k/base64-bytestring +time 81.01 μs (80.45 μs .. 81.98 μs) + 0.999 R² (0.996 R² .. 1.000 R²) +mean 80.95 μs (80.48 μs .. 82.34 μs) +std dev 2.561 μs (1.019 μs .. 4.866 μs) +variance introduced by outliers: 31% (moderately inflated) + +benchmarking encode/100k/base64 +time 26.20 μs (26.13 μs .. 26.29 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 26.32 μs (26.25 μs .. 26.40 μs) +std dev 238.5 ns (190.6 ns .. 314.7 ns) + +benchmarking encode/1mm/base64-bytestring +time 793.2 μs (791.7 μs .. 794.8 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 795.1 μs (794.0 μs .. 796.2 μs) +std dev 3.646 μs (3.048 μs .. 4.402 μs) + +benchmarking encode/1mm/base64 +time 266.1 μs (260.7 μs .. 273.8 μs) + 0.997 R² (0.995 R² .. 1.000 R²) +mean 262.2 μs (260.6 μs .. 265.8 μs) +std dev 7.496 μs (1.432 μs .. 12.40 μs) +variance introduced by outliers: 23% (moderately inflated) + +benchmarking decode/25/base64-bytestring +time 59.26 ns (59.18 ns .. 59.35 ns) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 59.31 ns (59.22 ns .. 59.41 ns) +std dev 329.7 ps (270.9 ps .. 416.3 ps) + +benchmarking decode/25/base64-typed +time 45.90 ns (45.78 ns .. 46.04 ns) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 45.95 ns (45.88 ns .. 46.04 ns) +std dev 261.9 ps (218.3 ps .. 327.6 ps) + +benchmarking decode/25/base64-untyped +time 55.79 ns (55.63 ns .. 56.02 ns) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 55.90 ns (55.77 ns .. 56.06 ns) +std dev 470.0 ps (364.5 ps .. 692.0 ps) + +benchmarking decode/100/base64-bytestring +time 153.8 ns (153.4 ns .. 154.2 ns) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 153.6 ns (153.4 ns .. 153.9 ns) +std dev 931.2 ps (780.6 ps .. 1.139 ns) + +benchmarking decode/100/base64-typed +time 121.3 ns (120.6 ns .. 122.4 ns) + 0.999 R² (0.997 R² .. 1.000 R²) +mean 121.5 ns (120.6 ns .. 125.2 ns) +std dev 4.717 ns (1.474 ns .. 10.23 ns) +variance introduced by outliers: 59% (severely inflated) + +benchmarking decode/100/base64-untyped +time 153.2 ns (152.9 ns .. 153.5 ns) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 153.3 ns (153.1 ns .. 153.5 ns) +std dev 642.7 ps (538.6 ps .. 804.8 ps) + +benchmarking decode/1k/base64-bytestring +time 1.246 μs (1.244 μs .. 1.248 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 1.247 μs (1.245 μs .. 1.248 μs) +std dev 4.807 ns (3.911 ns .. 5.909 ns) + +benchmarking decode/1k/base64-typed +time 909.0 ns (902.6 ns .. 919.9 ns) + 0.999 R² (0.998 R² .. 1.000 R²) +mean 905.9 ns (902.1 ns .. 917.4 ns) +std dev 19.73 ns (7.516 ns .. 39.01 ns) +variance introduced by outliers: 27% (moderately inflated) + +benchmarking decode/1k/base64-untyped +time 1.210 μs (1.192 μs .. 1.226 μs) + 0.999 R² (0.999 R² .. 1.000 R²) +mean 1.222 μs (1.214 μs .. 1.226 μs) +std dev 19.44 ns (10.77 ns .. 29.88 ns) +variance introduced by outliers: 16% (moderately inflated) + +benchmarking decode/10k/base64-bytestring +time 11.56 μs (11.53 μs .. 11.59 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 11.49 μs (11.47 μs .. 11.52 μs) +std dev 91.19 ns (77.80 ns .. 110.9 ns) + +benchmarking decode/10k/base64-typed +time 8.140 μs (8.126 μs .. 8.157 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 8.141 μs (8.125 μs .. 8.169 μs) +std dev 70.34 ns (47.20 ns .. 119.2 ns) + +benchmarking decode/10k/base64-untyped +time 11.25 μs (11.24 μs .. 11.27 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 11.29 μs (11.27 μs .. 11.35 μs) +std dev 102.4 ns (52.23 ns .. 185.3 ns) + +benchmarking decode/100k/base64-bytestring +time 114.2 μs (113.9 μs .. 114.6 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 114.5 μs (114.3 μs .. 114.8 μs) +std dev 778.0 ns (644.2 ns .. 997.4 ns) + +benchmarking decode/100k/base64-typed +time 80.52 μs (80.37 μs .. 80.68 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 80.56 μs (80.44 μs .. 80.75 μs) +std dev 478.9 ns (347.2 ns .. 750.1 ns) + +benchmarking decode/100k/base64-untyped +time 111.0 μs (110.8 μs .. 111.2 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 111.4 μs (111.2 μs .. 111.8 μs) +std dev 836.7 ns (409.8 ns .. 1.471 μs) + +benchmarking decode/1mm/base64-bytestring +time 1.125 ms (1.122 ms .. 1.128 ms) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 1.123 ms (1.121 ms .. 1.124 ms) +std dev 5.065 μs (4.293 μs .. 6.589 μs) + +benchmarking decode/1mm/base64-typed +time 804.8 μs (802.3 μs .. 807.7 μs) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 802.7 μs (802.0 μs .. 803.8 μs) +std dev 2.940 μs (1.813 μs .. 4.985 μs) + +benchmarking decode/1mm/base64-untyped +time 1.108 ms (1.106 ms .. 1.110 ms) + 1.000 R² (1.000 R² .. 1.000 R²) +mean 1.108 ms (1.107 ms .. 1.110 ms) +std dev 5.673 μs (4.383 μs .. 7.451 μs) + +``` + +Benchmarks are included in this repo for you to reproduce these results on your own. You can see a parity in the `encode` step between the previous library iterations and the new epoch, with a *marked* improvement in decode speed (up to 25% faster on average between the old and new versions in the optimal case, and up to 40% in the suboptimal case) which justifies the performance aspect to me. Without deferring to pipelining instructions, hex encoding can only get so fast. In the future, this change also opens the library up to an optimal SIMD implementations. + +## A sounder api + +Second, I do not believe that these changes are unsound or overburdensome to the point that a migration to the new paradigm would be untenable. While it may be inconvenient to unwrap `Base64` types, in the `encode` case (all one must do is call `extractBase64` to extract the value from its wrapper, all caveats implied), and in the case of `decode`, an untyped variant is supplied, and is semantically consistent with the old behavior (the loop is the same). Hence, a migration is fairly easy to sketch out: + +``` +"encodeBase64'" -> "extractBase64 . encodeBase64'" +"encodeBase64" -> "extractBase64 . encodeBase64" +"decodebase64" -> "decodeBase64Untyped" +"decodeBase64Unpadded" -> "decodeBase64UnpaddedUntyped" +"decodeBase64Padded" -> "decodeBase64PaddedUntyped" +"decodeBase64W*With" -> "decodeBase64*WithUntyped" +``` + +And that is all. In order to make use of the new loops, one must only use one of the blessed encode functions to generate a wrapped `Base64` value, or call `assertBase64` and proceed with using `decodeBase64` as usual in order to decode. You'll note that an untyped `encodeBase64` is not supplied, and this is due to the fact that it's trivial to extract a `Base64` encoded value once you have it. However, I want to encourage people to use the new API, so I have only supplied a decode with error checking in the untyped case, because sometimes we deal with other people's data and cannot establish provenance. In the encode case, I would rather keep that provenance a part of the API, and the user may opt to strip that data upon sending to others or around their systems. It's not my problem at that point! diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,6 @@ # Base64 -![Build Status](https://github.com/emilypi/base64/workflows/Haskell-CI/badge.svg) +![Build Status](https://github.com/emilypi/base64/workflows/ci/badge.svg) [![Hackage](https://img.shields.io/hackage/v/base64.svg)](https://hackage.haskell.org/package/base64) Base64 encoding and decodings. diff --git a/base64.cabal b/base64.cabal --- a/base64.cabal +++ b/base64.cabal @@ -1,24 +1,26 @@ cabal-version: 2.0 name: base64 -version: 0.4.2.4 -synopsis: A modern RFC 4648-compliant Base64 library +version: 1.0 +synopsis: A modern Base64 library description: - RFC 4648-compliant Base64 with an eye towards performance and modernity (additional support for RFC 7049 standards) + A performant, featureful RFC 4648 and 7049-compliant Base64 implementation homepage: https://github.com/emilypi/base64 bug-reports: https://github.com/emilypi/base64/issues license: BSD3 license-file: LICENSE author: Emily Pillmore -maintainer: emilypi@cohomolo.gy -copyright: (c) 2019-2022 Emily Pillmore +maintainer: Emily Pillmore + , Sofia-m-a +copyright: (c) 2019-2023 Emily Pillmore category: Data build-type: Simple extra-doc-files: CHANGELOG.md README.md + MIGRATION-1.0.md -tested-with: GHC ==8.10.7 || ==9.0.2 || ==9.2.2 +tested-with: GHC ==8.10.7 || ==9.0.2 || ==9.2.5 || ==9.4.7 || ==9.6.3 || ==9.8.1 source-repository head type: git @@ -26,6 +28,7 @@ library exposed-modules: + Data.Base64.Types Data.ByteString.Base64 Data.ByteString.Base64.URL Data.ByteString.Lazy.Base64 @@ -41,43 +44,43 @@ Data.Text.Short.Encoding.Base64.URL other-modules: + Data.Base64.Types.Internal Data.ByteString.Base64.Internal Data.ByteString.Base64.Internal.Head Data.ByteString.Base64.Internal.Tables Data.ByteString.Base64.Internal.Tail Data.ByteString.Base64.Internal.Utils Data.ByteString.Base64.Internal.W16.Loop - Data.ByteString.Base64.Internal.W32.Loop Data.ByteString.Base64.Internal.W64.Loop build-depends: - base >=4.14 && <4.17 - , bytestring >=0.10 && <0.12 - , deepseq >=1.4.3.0 && <1.5 - , text ^>=1.2 + base >=4.14 && <4.20 + , bytestring >=0.11 && <0.13 + , deepseq >=1.4.4.0 && <1.6 + , text >=2.0 && <2.3 , text-short ^>=0.1 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -test-suite tasty +test-suite base64-tests default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test other-modules: Internal main-is: Main.hs build-depends: - base >=4.14 && <4.17 + base >=4.14 && <4.20 , base64 , base64-bytestring - , bytestring + , bytestring >=0.11 , QuickCheck , random-bytestring , tasty , tasty-hunit , tasty-quickcheck - , text + , text >=2.0 , text-short ghc-options: -Wall -threaded -with-rtsopts=-N @@ -88,13 +91,13 @@ hs-source-dirs: benchmarks main-is: Base64Bench.hs build-depends: - base >=4.14 && <4.17 + base >=4.14 && <4.20 , base64 , base64-bytestring - , bytestring + , bytestring >=0.11 , criterion , deepseq , random-bytestring - , text + , text >=2.0 ghc-options: -Wall -rtsopts diff --git a/benchmarks/Base64Bench.hs b/benchmarks/Base64Bench.hs --- a/benchmarks/Base64Bench.hs +++ b/benchmarks/Base64Bench.hs @@ -1,16 +1,12 @@ {-# LANGUAGE AllowAmbiguousTypes #-} -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE GADTs #-} -{-# LANGUAGE KindSignatures #-} -{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} module Main ( main @@ -22,6 +18,7 @@ import "base64-bytestring" Data.ByteString.Base64 as Bos import "base64" Data.ByteString.Base64 as B64 +import "base64" Data.Base64.Types as B64 import Data.ByteString.Random (random) @@ -58,28 +55,34 @@ , env bs' $ \ ~(bs25,bs100,bs1k,bs10k,bs100k,bs1mm) -> bgroup "decode" [ bgroup "25" - [ bench "base64-bytestring" $ whnf Bos.decode bs25 - , bench "base64" $ whnf B64.decodeBase64 bs25 + [ bench "base64-bytestring" $ whnf Bos.decode (B64.extractBase64 bs25) + , bench "base64-typed" $ whnf B64.decodeBase64 bs25 + , bench "base64-untyped" $ whnf B64.decodeBase64Untyped (B64.extractBase64 bs25) ] , bgroup "100" - [ bench "base64-bytestring" $ whnf Bos.decode bs100 - , bench "base64" $ whnf B64.decodeBase64 bs100 + [ bench "base64-bytestring" $ whnf Bos.decode (B64.extractBase64 bs100) + , bench "base64-typed" $ whnf B64.decodeBase64 bs100 + , bench "base64-untyped" $ whnf B64.decodeBase64Untyped (B64.extractBase64 bs100) ] , bgroup "1k" - [ bench "base64-bytestring" $ whnf Bos.decode bs1k - , bench "base64" $ whnf B64.decodeBase64 bs1k + [ bench "base64-bytestring" $ whnf Bos.decode (B64.extractBase64 bs1k) + , bench "base64-typed" $ whnf B64.decodeBase64 bs1k + , bench "base64-untyped" $ whnf B64.decodeBase64Untyped (B64.extractBase64 bs1k) ] , bgroup "10k" - [ bench "base64-bytestring" $ whnf Bos.decode bs10k - , bench "base64" $ whnf B64.decodeBase64 bs10k + [ bench "base64-bytestring" $ whnf Bos.decode (B64.extractBase64 bs10k) + , bench "base64-typed" $ whnf B64.decodeBase64 bs10k + , bench "base64-untyped" $ whnf B64.decodeBase64Untyped (B64.extractBase64 bs10k) ] , bgroup "100k" - [ bench "base64-bytestring" $ whnf Bos.decode bs100k - , bench "base64" $ whnf B64.decodeBase64 bs100k + [ bench "base64-bytestring" $ whnf Bos.decode (B64.extractBase64 bs100k) + , bench "base64-typed" $ whnf B64.decodeBase64 bs100k + , bench "base64-untyped" $ whnf B64.decodeBase64Untyped (B64.extractBase64 bs100k) ] , bgroup "1mm" - [ bench "base64-bytestring" $ whnf Bos.decode bs1mm - , bench "base64" $ whnf B64.decodeBase64 bs1mm + [ bench "base64-bytestring" $ whnf Bos.decode (B64.extractBase64 bs1mm) + , bench "base64-typed" $ whnf B64.decodeBase64 bs1mm + , bench "base64-untyped" $ whnf B64.decodeBase64Untyped (B64.extractBase64 bs1mm) ] ] ] diff --git a/src/Data/Base64/Types.hs b/src/Data/Base64/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Base64/Types.hs @@ -0,0 +1,111 @@ +{-# language DataKinds #-} +{-# language PolyKinds #-} +{-# language RankNTypes #-} +{-# language TypeFamilies #-} +{-# language UndecidableInstances #-} +-- | +-- Module : Data.ByteString.Base64.Types +-- Copyright : (c) 2019-2023 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore , +-- sofia-m-a +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains the 'Base64' type definition, 'Alphabet' +-- datatype, alphabet constraints, and various quality of life +-- combinators for working with 'Base64'-wrapped data. +-- +module Data.Base64.Types +( Alphabet(..) +, type Base64 +, assertBase64 +, extractBase64 +, coerceBase64 +, type UrlAlphabet +, type StdAlphabet +, type NonStandardAlphabet +) where + + +import Data.Base64.Types.Internal (Alphabet(..), Base64(..)) +import Data.Coerce (coerce) +import Data.Kind + +import GHC.TypeLits + + +-- | Assert the provenance of a value encoded in a particular +-- base64 alphabet. +-- +-- /Warning/: This is a blind assertion that a particular +-- value is base64 encoded in some alphabet. If you are not +-- sure of the provenance of the value, you may experience +-- odd behavior when attempting to decode. Use at your own +-- risk. If I see any issues logged on this project from +-- negligent use of this or 'coerceBase64', I will +-- smite you. +-- +assertBase64 :: forall k a. a -> Base64 k a +assertBase64 = Base64 + +-- | Forget the provenance of a base64-encoded value. +-- +extractBase64 :: Base64 k a -> a +extractBase64 (Base64 a) = a + +-- | Coerce the alphabet of a base64-encoded bytestring +-- +-- /Warning/: This is a blind assertion that a particular +-- value is base64 encoded in some alphabet. If you are not +-- sure of the provenance of the value, you may experience +-- odd behavior when attempting to decode. Use at your own +-- risk. If I see any issues logged on this project from +-- negligent use of this or 'assertBase64', I will +-- smite you. +-- +coerceBase64 :: forall j k a. Base64 k a -> Base64 j a +coerceBase64 = coerce + +-- | The type family of Url-safe alphabets +-- +-- This type family defines the union of compatible Url-safe base64 types. +-- To write a function that is parametric over such types, issue a +-- constraint like `forall k. UrlAlphabet k`. +-- +type family UrlAlphabet k :: Constraint where + UrlAlphabet 'UrlPadded = () + UrlAlphabet 'UrlUnpadded = () + UrlAlphabet _ = TypeError + ( 'Text "Cannot prove base64 value is encoded using the url-safe \ + \alphabet. Please re-encode using the url-safe encoders, or use \ + \a lenient decoder for the url-safe alphabet instead." + ) + +-- | The type family of standard alphabets +-- +-- This type family defines the union of compatible standard +-- alphabet base64 types +-- +type family StdAlphabet k :: Constraint where + StdAlphabet 'StdPadded = () + StdAlphabet _ = TypeError + ( 'Text "Cannot prove base64 value is encoded using the std \ + \alphabet. Please re-encode using the std encoders, or use \ + \a lenient decoder for the std alphabet instead." + ) + +-- | The type family of non-standard alphabets +-- +-- Only untyped variants of encodeBase64/decodeBase64 can interact with this +-- type family, in addition to assertion\/coercion\/extraction of +-- these types of values. +-- +type family NonStandardAlphabet k :: Constraint where + NonStandardAlphabet 'NonStandard = () + NonStandardAlphabet _ = TypeError + ( 'Text "Cannot prove base64 value is encoded using a non-standard \ + \alphabet. Please re-encode and assert/coerce the alphabet, \ + \and use a lenient decoder." + ) diff --git a/src/Data/Base64/Types/Internal.hs b/src/Data/Base64/Types/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/Base64/Types/Internal.hs @@ -0,0 +1,66 @@ +{-# language DataKinds #-} +{-# language RankNTypes #-} +{-# language TypeFamilies #-} +-- | +-- Module : Data.ByteString.Base64.Types.Internal +-- Copyright : (c) 2019-2023 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore , +-- sofia-m-a +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains the 'Base64' newtype, 'Alphabet' +-- datatype, and associated instances for 'Base64'. +-- +module Data.Base64.Types.Internal +( Alphabet(..) +, Base64(..) +) where + + +import Control.DeepSeq (NFData, rnf) + +-- | The different kinds of supported Base64 encodings +data Alphabet + = StdPadded + -- ^ Standard base64 according to [RFC 4648 §4](https://datatracker.ietf.org/doc/html/rfc4648#section-4) + -- Padding is always inserted when encoding, and required when decoding + | UrlPadded + -- ^ Standard base64 according to [RFC 4648 §4](https://datatracker.ietf.org/doc/html/rfc4648#section-4) + -- Padding is never inserted when encoding, and optional when decoding per + -- [RFC 7049](https://datatracker.ietf.org/doc/html/rfc7049#section-2.4.4.2). + | UrlUnpadded + -- ^ URL-safe base64 according to [RFC 4648 §5](https://datatracker.ietf.org/doc/html/rfc4648#section-5) aka base64url + -- Padding is never inserted when encoding, and optional when decoding + | NonStandard + -- ^ Any non-standard, non RFC 4648-compliant base64 encoding. + -- Can only be decoded using lenient decoders. + +-- | Wraps a value, asserting that it is or is intended to be +-- in a particular kind of Base64 encoding use 'extractBase64' +-- to extract the value, and 'assertBase64' to tag a value +-- as base64-encoded +-- +newtype Base64 (k :: Alphabet) a = Base64 a + +instance forall k. Functor (Base64 k) where + fmap f (Base64 a) = Base64 (f a) + +instance forall k a. (Eq a) => Eq (Base64 k a) where + Base64 a == Base64 b = a == b + +instance forall k. Applicative (Base64 k) where + pure = Base64 + Base64 f <*> Base64 a = Base64 (f a) + +instance forall k. Monad (Base64 k) where + return = pure + Base64 a >>= k = k a + +instance forall k a. (Show a) => Show (Base64 k a) where + show (Base64 a) = show a + +instance forall k a. NFData a => NFData (Base64 k a) where + rnf (Base64 a) = rnf a diff --git a/src/Data/ByteString/Base64.hs b/src/Data/ByteString/Base64.hs --- a/src/Data/ByteString/Base64.hs +++ b/src/Data/ByteString/Base64.hs @@ -1,9 +1,9 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Trustworthy #-} -- | -- Module : Data.ByteString.Base64 --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -21,12 +21,14 @@ , encodeBase64' -- * Decoding , decodeBase64 +, decodeBase64Untyped , decodeBase64Lenient -- * Validation , isBase64 , isValidBase64 ) where +import Data.Base64.Types import Data.ByteString.Internal (ByteString(..)) import Data.ByteString.Base64.Internal @@ -38,6 +40,13 @@ import System.IO.Unsafe +-- $setup +-- +-- >>> import Data.Base64.Types +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- -- | Encode a 'ByteString' value as Base64 'Text' with padding. -- @@ -48,8 +57,8 @@ -- >>> encodeBase64 "Sun" -- "U3Vu" -- -encodeBase64 :: ByteString -> Text -encodeBase64 = T.decodeUtf8 . encodeBase64' +encodeBase64 :: ByteString -> Base64 'StdPadded Text +encodeBase64 = fmap T.decodeUtf8 . encodeBase64' {-# inline encodeBase64 #-} -- | Encode a 'ByteString' value as a Base64 'ByteString' value with padding. @@ -61,8 +70,8 @@ -- >>> encodeBase64' "Sun" -- "U3Vu" -- -encodeBase64' :: ByteString -> ByteString -encodeBase64' = encodeBase64_ base64Table +encodeBase64' :: ByteString -> Base64 'StdPadded ByteString +encodeBase64' = assertBase64 . encodeBase64_ base64Table {-# inline encodeBase64' #-} -- | Decode a padded Base64-encoded 'ByteString' value. @@ -71,26 +80,39 @@ -- -- === __Examples__: -- --- >>> decodeBase64 "U3Vu" +-- >>> decodeBase64 $ assertBase64 @'StdPadded "U3Vu" +-- "Sun" +-- +decodeBase64 :: StdAlphabet k => Base64 k ByteString -> ByteString +decodeBase64 = decodeBase64Typed_ decodeB64Table +{-# inline decodeBase64 #-} + +-- | Decode a padded untyped Base64-encoded 'ByteString' value. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase64Untyped "U3Vu" -- Right "Sun" -- --- >>> decodeBase64 "U3V" +-- >>> decodeBase64Untyped "U3V" -- Left "Base64-encoded bytestring requires padding" -- --- >>> decodebase64 "U3V=" +-- >>> decodeBase64Untyped "U3V=" -- Left "non-canonical encoding detected at offset: 2" -- -decodeBase64 :: ByteString -> Either Text ByteString -decodeBase64 bs@(PS _ _ !l) - | l == 0 = Right bs +decodeBase64Untyped :: ByteString -> Either Text ByteString +decodeBase64Untyped bs@(PS _ _ !l) + | l == 0 = Right mempty | r == 1 = Left "Base64-encoded bytestring has invalid size" | r /= 0 = Left "Base64-encoded bytestring requires padding" | otherwise = unsafeDupablePerformIO $ decodeBase64_ decodeB64Table bs where !r = l `rem` 4 -{-# inline decodeBase64 #-} +{-# inline decodeBase64Untyped #-} --- | Leniently decode an unpadded Base64-encoded 'ByteString' value. This function +-- | Leniently decode an untyped Base64-encoded 'ByteString' value. This function -- will not generate parse errors. If input data contains padding chars, -- then the input will be parsed up until the first pad character. -- @@ -104,7 +126,7 @@ -- >>> decodeBase64Lenient "U3V" -- "Su" -- --- >>> decodebase64Lenient "U3V=" +-- >>> decodeBase64Lenient "U3V=" -- "Su" -- decodeBase64Lenient :: ByteString -> ByteString @@ -114,7 +136,7 @@ -- | Tell whether a 'ByteString' value is base64 encoded. -- -- This function will also detect non-canonical encodings such as @ZE==@, which are --- externally valid Base64url-encoded values, but are internally inconsistent "impossible" +-- externally valid Base64-encoded values, but are internally inconsistent "impossible" -- values. -- -- === __Examples__: @@ -129,12 +151,14 @@ -- False -- isBase64 :: ByteString -> Bool -isBase64 bs = isValidBase64 bs && isRight (decodeBase64 bs) +isBase64 bs + = isValidBase64 bs + && isRight (decodeBase64Untyped bs) {-# inline isBase64 #-} -- | Tell whether a 'ByteString' value is a valid Base64 format. -- --- This will not tell you whether or not this is a correct Base64url representation, +-- This will not tell you whether or not this is a correct Base64 representation, -- only that it conforms to the correct shape. To check whether it is a true -- Base64 encoded 'ByteString' value, use 'isBase64'. -- diff --git a/src/Data/ByteString/Base64/Internal.hs b/src/Data/ByteString/Base64/Internal.hs --- a/src/Data/ByteString/Base64/Internal.hs +++ b/src/Data/ByteString/Base64/Internal.hs @@ -1,12 +1,8 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE MagicHash #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -- | -- Module : Data.ByteString.Base64.Internal --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -106,7 +102,7 @@ :: ByteString -> IO (Either Text ByteString) -> Either Text ByteString -validateLastPad !bs io +validateLastPad bs io | BS.last bs == 0x3d = Left "Base64-encoded bytestring has invalid padding" | otherwise = unsafeDupablePerformIO io {-# INLINE validateLastPad #-} diff --git a/src/Data/ByteString/Base64/Internal/Head.hs b/src/Data/ByteString/Base64/Internal/Head.hs --- a/src/Data/ByteString/Base64/Internal/Head.hs +++ b/src/Data/ByteString/Base64/Internal/Head.hs @@ -1,10 +1,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TypeApplications #-} -- | -- Module : Data.ByteString.Base64.Internal.Head --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -17,20 +16,14 @@ ( encodeBase64_ , encodeBase64Nopad_ , decodeBase64_ +, decodeBase64Typed_ , decodeBase64Lenient_ ) where -#include "MachDeps.h" - +import Data.Base64.Types.Internal import Data.ByteString.Base64.Internal.Tail import Data.ByteString.Base64.Internal.Utils -#if WORD_SIZE_IN_BITS == 32 -import Data.ByteString.Base64.Internal.W32.Loop -#elif WORD_SIZE_IN_BITS >= 64 import Data.ByteString.Base64.Internal.W64.Loop -#else -import Data.ByteString.Base64.Internal.W16.Loop -#endif import Data.ByteString.Internal import Data.Text (Text) @@ -40,7 +33,7 @@ import GHC.ForeignPtr import GHC.Word -import System.IO.Unsafe +import System.IO.Unsafe ( unsafeDupablePerformIO ) encodeBase64_ :: EncodingTable -> ByteString -> ByteString @@ -56,7 +49,7 @@ (castPtr (plusPtr sptr soff)) (castPtr dptr) end - (loopTail dfp aptr dptr (castPtr end)) + (loopTail dfp dptr aptr (castPtr end)) where !dlen = 4 * ((slen + 2) `div` 3) @@ -103,6 +96,32 @@ where !dlen = (slen `quot` 4) * 3 {-# inline decodeBase64_ #-} + +-- | The main decode function for typed base64 values. +-- +-- This loop is separate from 'decodeBase64_' due to the fact that +-- when taking a 'Base64' value from this library, the existence +-- of the wrapper is a witness to the well-formedness of the underlying value, +-- and so we can eschew error checking in the decode loop. +-- +decodeBase64Typed_ + :: ForeignPtr Word8 + -> Base64 k ByteString + -> ByteString +decodeBase64Typed_ !dtfp (Base64 (PS sfp soff slen)) + | slen == 0 = mempty + | otherwise = unsafeDupablePerformIO $ + withForeignPtr dtfp $ \dtable -> + withForeignPtr sfp $ \sptr -> do + dfp <- mallocPlainForeignPtrBytes dlen + withForeignPtr dfp $ \dptr -> do + let !end = plusPtr sptr (soff + slen) + decodeLoopNoError dtable + (plusPtr sptr soff) + dptr end dfp + where + !dlen = (slen `quot` 4) * 3 +{-# inline decodeBase64Typed_ #-} decodeBase64Lenient_ :: ForeignPtr Word8 -> ByteString -> ByteString decodeBase64Lenient_ !dtfp (PS !sfp !soff !slen) = unsafeDupablePerformIO $ diff --git a/src/Data/ByteString/Base64/Internal/Tables.hs b/src/Data/ByteString/Base64/Internal/Tables.hs --- a/src/Data/ByteString/Base64/Internal/Tables.hs +++ b/src/Data/ByteString/Base64/Internal/Tables.hs @@ -1,9 +1,8 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.ByteString.Base64.Internal.Tables --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore diff --git a/src/Data/ByteString/Base64/Internal/Tail.hs b/src/Data/ByteString/Base64/Internal/Tail.hs --- a/src/Data/ByteString/Base64/Internal/Tail.hs +++ b/src/Data/ByteString/Base64/Internal/Tail.hs @@ -1,9 +1,8 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeApplications #-} -- | --- Module : Data.ByteString.Base64.Internal.W32.Loop --- Copyright : (c) 2019-2020 Emily Pillmore +-- Module : Data.ByteString.Base64.Internal.Tail +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -39,35 +38,36 @@ -> Ptr Word8 -> Ptr Word8 -> IO ByteString -loopTail !dfp (Ptr !alpha) !dptr !end !src !dst - | src == end = return (PS dfp 0 (minusPtr dst dptr)) - | plusPtr src 1 == end = do - !x <- peek @Word8 src +loopTail !dfp !dptr (Ptr !alpha) !end !sptr_ !dptr_ = go sptr_ dptr_ + where + go src dst + | src == end = + pure $ PS dfp 0 (dst `minusPtr` dptr) + | otherwise = do + !x <- peek @Word8 src + let !a = unsafeShiftR x 2 + !carry0 = unsafeShiftL (x .&. 0x03) 4 - let !a = unsafeShiftR (x .&. 0xfc) 2 - !b = unsafeShiftL (x .&. 0x03) 4 + -- poke first 6 bits + poke @Word8 dst $ aix a alpha - poke @Word8 dst (aix a alpha) - poke @Word8 (plusPtr dst 1) (aix b alpha) - poke @Word8 (plusPtr dst 2) 0x3d - poke @Word8 (plusPtr dst 3) 0x3d - return (PS dfp 0 (4 + minusPtr dst dptr)) + if src `plusPtr` 1 == end then do + -- if no other bytes, poke carry bits + poke @Word8 (dst `plusPtr` 1) $ aix carry0 alpha + poke @Word8 (dst `plusPtr` 2) 0x3d + poke @Word8 (dst `plusPtr` 3) 0x3d - | otherwise = do - !x <- peek @Word8 src - !y <- peek @Word8 (plusPtr src 1) + else do + !y <- peek @Word8 $ src `plusPtr` 1 - let !a = unsafeShiftR (x .&. 0xfc) 2 - !b = unsafeShiftL (x .&. 0x03) 4 + let !b = carry0 .|. unsafeShiftR (y .&. 0xf0) 4 + !carry1 = unsafeShiftL (y .&. 0x0f) 2 - let !c = unsafeShiftR (y .&. 0xf0) 4 .|. b - !d = unsafeShiftL (y .&. 0x0f) 2 + poke @Word8 (dst `plusPtr` 1) $ aix b alpha + poke @Word8 (dst `plusPtr` 2) $ aix carry1 alpha + poke @Word8 (dst `plusPtr` 3) 0x3d - poke @Word8 dst (aix a alpha) - poke @Word8 (plusPtr dst 1) (aix c alpha) - poke @Word8 (plusPtr dst 2) (aix d alpha) - poke @Word8 (plusPtr dst 3) 0x3d - return (PS dfp 0 (4 + minusPtr dst dptr)) + pure $ PS dfp 0 (4 + minusPtr dst dptr) {-# inline loopTail #-} -- | Finalize a bytestring by filling out the remaining bits @@ -91,7 +91,7 @@ poke @Word8 dst (aix a alpha) poke @Word8 (plusPtr dst 1) (aix b alpha) - return (PS dfp 0 (2 + (minusPtr dst dptr))) + return (PS dfp 0 (2 + minusPtr dst dptr)) | otherwise = do !x <- peek @Word8 src !y <- peek @Word8 (plusPtr src 1) @@ -105,5 +105,5 @@ poke @Word8 dst (aix a alpha) poke @Word8 (plusPtr dst 1) (aix c alpha) poke @Word8 (plusPtr dst 2) (aix d alpha) - return (PS dfp 0 (3 + (minusPtr dst dptr))) + return (PS dfp 0 (3 + minusPtr dst dptr)) {-# inline loopTailNoPad #-} diff --git a/src/Data/ByteString/Base64/Internal/Utils.hs b/src/Data/ByteString/Base64/Internal/Utils.hs --- a/src/Data/ByteString/Base64/Internal/Utils.hs +++ b/src/Data/ByteString/Base64/Internal/Utils.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MagicHash #-} -- | -- Module : Data.ByteString.Base64.Internal --- Copyright : (c) 2019-2022 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore diff --git a/src/Data/ByteString/Base64/Internal/W16/Loop.hs b/src/Data/ByteString/Base64/Internal/W16/Loop.hs --- a/src/Data/ByteString/Base64/Internal/W16/Loop.hs +++ b/src/Data/ByteString/Base64/Internal/W16/Loop.hs @@ -3,7 +3,7 @@ {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.ByteString.Base64.Internal.W16.Loop --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -15,10 +15,10 @@ module Data.ByteString.Base64.Internal.W16.Loop ( innerLoop , decodeLoop +, decodeLoopNoError , lenientLoop ) where - import Data.Bits import Data.ByteString.Internal import Data.ByteString.Base64.Internal.Utils @@ -53,7 +53,7 @@ !j <- w32 <$> peek (plusPtr src 1) !k <- w32 <$> peek (plusPtr src 2) - let !w = (unsafeShiftL i 16) .|. (unsafeShiftL j 8) .|. k + let !w = unsafeShiftL i 16 .|. unsafeShiftL j 8 .|. k !x <- peekElemOff etable (fromIntegral (unsafeShiftR w 12)) !y <- peekElemOff etable (fromIntegral (w .&. 0xfff)) @@ -78,12 +78,12 @@ where err :: Ptr Word8 -> IO (Either Text ByteString) err p = return . Left . T.pack - $ "invalid character at offset: " + $ "invalid base64 encoding near offset: " ++ show (p `minusPtr` sptr) padErr :: Ptr Word8 -> IO (Either Text ByteString) padErr p = return . Left . T.pack - $ "invalid padding at offset: " + $ "invalid padding near offset: " ++ show (p `minusPtr` sptr) canonErr :: Ptr Word8 -> IO (Either Text ByteString) @@ -127,9 +127,9 @@ | d == 0xff = err (plusPtr src 3) | otherwise = do - let !w = ((unsafeShiftL a 18) - .|. (unsafeShiftL b 12) - .|. (unsafeShiftL c 6) + let !w = (unsafeShiftL a 18 + .|. unsafeShiftL b 12 + .|. unsafeShiftL c 6 .|. d) :: Word32 poke @Word8 dst (fromIntegral (unsafeShiftR w 16)) @@ -150,9 +150,9 @@ | c == 0xff = err (plusPtr src 2) | d == 0xff = err (plusPtr src 3) | otherwise = do - let !w = ((unsafeShiftL a 18) - .|. (unsafeShiftL b 12) - .|. (unsafeShiftL c 6) + let !w = (unsafeShiftL a 18 + .|. unsafeShiftL b 12 + .|. unsafeShiftL c 6 .|. d) :: Word32 poke @Word8 dst (fromIntegral (unsafeShiftR w 16)) @@ -174,6 +174,66 @@ return $ Right $ PS dfp 0 (3 + (dst `minusPtr` dptr)) {-# inline decodeLoop #-} +decodeLoopNoError + :: Ptr Word8 + -- ^ decode lookup table + -> Ptr Word8 + -- ^ src pointer + -> Ptr Word8 + -- ^ dst pointer + -> Ptr Word8 + -> ForeignPtr Word8 + -> IO ByteString +decodeLoopNoError !dtable !sptr !dptr !end !dfp = go dptr sptr + where + look :: Ptr Word8 -> IO Word32 + look !p = do + !i <- peek p + !v <- peekByteOff @Word8 dtable (fromIntegral i) + pure $ fromIntegral v + + go !dst !src + | plusPtr src 4 >= end = do + a <- look src + b <- look (src `plusPtr` 1) + c <- look (src `plusPtr` 2) + d <- look (src `plusPtr` 3) + + let !w = (unsafeShiftL a 18 + .|. unsafeShiftL b 12 + .|. unsafeShiftL c 6 + .|. d) :: Word32 + + poke @Word8 dst (fromIntegral (unsafeShiftR w 16)) + + if c == 0x63 && d == 0x63 then + pure $ PS dfp 0 (1 + (dst `minusPtr` dptr)) + else if d == 0x63 then do + poke @Word8 (plusPtr dst 1) (fromIntegral (unsafeShiftR w 8)) + pure $ PS dfp 0 (2 + (dst `minusPtr` dptr)) + else do + poke @Word8 (plusPtr dst 1) (fromIntegral (unsafeShiftR w 8)) + poke @Word8 (plusPtr dst 2) (fromIntegral w) + pure $ PS dfp 0 (3 + (dst `minusPtr` dptr)) + + | otherwise = do + a <- look src + b <- look (src `plusPtr` 1) + c <- look (src `plusPtr` 2) + d <- look (src `plusPtr` 3) + + let !w = (unsafeShiftL a 18 + .|. unsafeShiftL b 12 + .|. unsafeShiftL c 6 + .|. d) :: Word32 + + poke @Word8 dst (fromIntegral (unsafeShiftR w 16)) + poke @Word8 (plusPtr dst 1) (fromIntegral (unsafeShiftR w 8)) + poke @Word8 (plusPtr dst 2) (fromIntegral w) + go (plusPtr dst 3) (plusPtr src 4) +{-# inline decodeLoopNoError #-} + + lenientLoop :: Ptr Word8 -- ^ decode lookup table @@ -215,7 +275,7 @@ | otherwise -> look False bp $ \cp c -> look False cp $ \dp d -> do - let !w = (unsafeShiftL a 18) .|. (unsafeShiftL b 12) .|. (unsafeShiftL c 6) .|. d + let !w = unsafeShiftL a 18 .|. unsafeShiftL b 12 .|. unsafeShiftL c 6 .|. d poke @Word8 dst (fromIntegral (unsafeShiftR w 16)) if c == 0x63 diff --git a/src/Data/ByteString/Base64/Internal/W32/Loop.hs b/src/Data/ByteString/Base64/Internal/W32/Loop.hs deleted file mode 100644 --- a/src/Data/ByteString/Base64/Internal/W32/Loop.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TypeApplications #-} --- | --- Module : Data.ByteString.Base64.Internal.W32.Loop --- Copyright : (c) 2019-2020 Emily Pillmore --- License : BSD-style --- --- Maintainer : Emily Pillmore --- Stability : Experimental --- Portability : portable --- --- 'Word32'-optimized inner loop --- -module Data.ByteString.Base64.Internal.W32.Loop -( innerLoop -, decodeLoop -, lenientLoop -) where - - -import Data.Bits -import Data.ByteString.Internal -import Data.ByteString.Base64.Internal.Utils -import qualified Data.ByteString.Base64.Internal.W16.Loop as W16 -import Data.Text (Text) - -import Foreign.ForeignPtr -import Foreign.Ptr -import Foreign.Storable - -import GHC.Word - - --- | Encoding inner loop. Packs 3 bytes from src pointer into --- the first 6 bytes of 4 'Word8''s (using the encoding table, --- as 2 'Word12''s ), writing these to the dst pointer. --- -innerLoop - :: Ptr Word16 - -> Ptr Word32 - -> Ptr Word32 - -> Ptr Word32 - -> (Ptr Word8 -> Ptr Word8 -> IO ByteString) - -> IO ByteString -innerLoop !etable !sptr !dptr !end finish = go sptr dptr - where - go !src !dst - | plusPtr src 3 >= end = - W16.innerLoop etable (castPtr src) (castPtr dst) (castPtr end) finish - | otherwise = do - !w <- peekWord32BE src - - let !a = unsafeShiftR w 20 - !b = unsafeShiftR w 8 - - !x <- w32_16 <$> peekElemOff etable (fromIntegral a) - !y <- w32_16 <$> peekElemOff etable (fromIntegral b) - - let !z = x .|. (unsafeShiftL y 16) - poke dst (fromIntegral z) - - go (plusPtr src 3) (plusPtr dst 4) - {-# INLINE go #-} -{-# INLINE innerLoop #-} - -decodeLoop - :: Ptr Word8 - -> Ptr Word8 - -- ^ src pointer - -> Ptr Word8 - -- ^ dst pointer - -> Ptr Word8 - -- ^ end of src ptr - -> ForeignPtr Word8 - -> IO (Either Text ByteString) -decodeLoop = W16.decodeLoop -{-# INLINE decodeLoop #-} - -lenientLoop - :: Ptr Word8 - -- ^ decode lookup table - -> Ptr Word8 - -- ^ src pointer - -> Ptr Word8 - -- ^ dst pointer - -> Ptr Word8 - -- ^ end of src ptr - -> ForeignPtr Word8 - -- ^ dst foreign ptr (for consing bs) - -> IO ByteString -lenientLoop = W16.lenientLoop diff --git a/src/Data/ByteString/Base64/Internal/W64/Loop.hs b/src/Data/ByteString/Base64/Internal/W64/Loop.hs --- a/src/Data/ByteString/Base64/Internal/W64/Loop.hs +++ b/src/Data/ByteString/Base64/Internal/W64/Loop.hs @@ -1,9 +1,7 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE TypeApplications #-} -- | -- Module : Data.ByteString.Base64.Internal.W64.Loop --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -15,6 +13,7 @@ module Data.ByteString.Base64.Internal.W64.Loop ( innerLoop , decodeLoop +, decodeLoopNoError , lenientLoop ) where @@ -51,10 +50,10 @@ | otherwise = do !t <- peekWord64BE src - let !a = (unsafeShiftR t 52) .&. 0xfff - !b = (unsafeShiftR t 40) .&. 0xfff - !c = (unsafeShiftR t 28) .&. 0xfff - !d = (unsafeShiftR t 16) .&. 0xfff + let !a = unsafeShiftR t 52 .&. 0xfff + !b = unsafeShiftR t 40 .&. 0xfff + !c = unsafeShiftR t 28 .&. 0xfff + !d = unsafeShiftR t 16 .&. 0xfff !w <- w64_16 <$> peekElemOff etable (fromIntegral a) !x <- w64_16 <$> peekElemOff etable (fromIntegral b) @@ -62,9 +61,9 @@ !z <- w64_16 <$> peekElemOff etable (fromIntegral d) let !xx = w - .|. (unsafeShiftL x 16) - .|. (unsafeShiftL y 32) - .|. (unsafeShiftL z 48) + .|. unsafeShiftL x 16 + .|. unsafeShiftL y 32 + .|. unsafeShiftL z 48 poke dst (fromIntegral xx) @@ -85,6 +84,21 @@ -> IO (Either Text ByteString) decodeLoop = W16.decodeLoop {-# inline decodeLoop #-} + +decodeLoopNoError + :: Ptr Word8 + -- ^ decode lookup table + -> Ptr Word8 + -- ^ src pointer + -> Ptr Word8 + -- ^ dst pointer + -> Ptr Word8 + -- ^ end of src ptr + -> ForeignPtr Word8 + -- ^ dst foreign ptr (for consing bs) + -> IO ByteString +decodeLoopNoError = W16.decodeLoopNoError +{-# inline decodeLoopNoError #-} lenientLoop :: Ptr Word8 diff --git a/src/Data/ByteString/Base64/URL.hs b/src/Data/ByteString/Base64/URL.hs --- a/src/Data/ByteString/Base64/URL.hs +++ b/src/Data/ByteString/Base64/URL.hs @@ -1,9 +1,10 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.ByteString.Base64.URL --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -11,7 +12,7 @@ -- Portability : non-portable -- -- This module contains 'Data.ByteString.ByteString'-valued combinators for --- implementing the RFC 4648 specification of the Base64url +-- implementing the RFC 4648 specification of the url-safe Base64 (Base64url) -- encoding format. This includes strictly padded/unpadded and lenient decoding -- variants, as well as internal and external validation for canonicity. -- @@ -23,8 +24,11 @@ , encodeBase64Unpadded' -- * Decoding , decodeBase64 +, decodeBase64Untyped , decodeBase64Unpadded +, decodeBase64UnpaddedUntyped , decodeBase64Padded +, decodeBase64PaddedUntyped , decodeBase64Lenient -- * Validation , isBase64Url @@ -32,6 +36,9 @@ ) where +import Data.Base64.Types +import Data.Base64.Types.Internal + import qualified Data.ByteString as BS import Data.ByteString.Internal (ByteString(..)) import Data.ByteString.Base64.Internal @@ -44,6 +51,14 @@ import System.IO.Unsafe +-- $setup +-- +-- >>> import Data.Base64.Types +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- + -- | Encode a 'ByteString' value as a Base64url 'Text' value with padding. -- -- See: @@ -53,8 +68,8 @@ -- >>> encodeBase64 "<>" -- "PDw_Pj4=" -- -encodeBase64 :: ByteString -> Text -encodeBase64 = T.decodeUtf8 . encodeBase64' +encodeBase64 :: ByteString -> Base64 'UrlPadded Text +encodeBase64 = fmap T.decodeUtf8 . encodeBase64' {-# INLINE encodeBase64 #-} -- | Encode a 'ByteString' as a Base64url 'ByteString' value with padding. @@ -66,41 +81,69 @@ -- >>> encodeBase64' "<>" -- "PDw_Pj4=" -- -encodeBase64' :: ByteString -> ByteString -encodeBase64' = encodeBase64_ base64UrlTable +encodeBase64' :: ByteString -> Base64 'UrlPadded ByteString +encodeBase64' = assertBase64 . encodeBase64_ base64UrlTable --- | Decode a padded Base64url encoded 'ByteString' value. If its length is not a multiple +-- | Decode a Base64url encoded 'ByteString' value, either padded or unpadded. +-- The correct decoding function is dispatched based on the existence of padding. +-- +-- For typed values: +-- - If a padded value is required, use 'decodeBase64Padded' +-- - If an unpadded value is required, use 'decodeBase64Unpadded' +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase64 $ assertBase64 @'UrlPadded "PDw_Pj4=" +-- "<>" +-- +-- >>> decodeBase64 $ assertBase64 @'UrlUnpadded "PDw_Pj4" +-- "<>" +-- +decodeBase64 + :: UrlAlphabet k + => Base64 k ByteString + -> ByteString +decodeBase64 b64@(Base64 bs) + | not $ BS.null bs, BS.last bs == 0x3d = decodeBase64Padded $ coerceBase64 b64 + | otherwise = decodeBase64Unpadded $ coerceBase64 b64 +{-# inline decodeBase64 #-} + +-- | Decode an untyped Base64url encoded 'ByteString' value. If its length is not a multiple -- of 4, then padding chars will be added to fill out the input to a multiple of -- 4 for safe decoding as Base64url-encoded values are optionally padded. -- --- For a decoder that fails on unpadded input of incorrect size, use 'decodeBase64Unpadded'. +-- For a decoder that fails to decode untyped values of incorrect size: +-- - If a padded value is required, use 'decodeBase64PaddedUntyped' +-- - If an unpadded value is required, use 'decodeBase64UnpaddedUntyped' -- -- See: -- -- === __Examples__: -- --- >>> decodeBase64 "PDw_Pj4=" +-- >>> decodeBase64Untyped "PDw_Pj4=" -- Right "<>" -- --- >>> decodeBase64 "PDw_Pj4" +-- >>> decodeBase64Untyped "PDw_Pj4" -- Right "<>" -- --- >>> decodeBase64 "PDw-Pg=" +-- >>> decodeBase64Untyped "PDw-Pg=" -- Left "Base64-encoded bytestring has invalid padding" -- --- >>> decodeBase64 "PDw-Pg" +-- >>> decodeBase64Untyped "PDw-Pg" -- Right "<<>>" -- -decodeBase64 :: ByteString -> Either Text ByteString -decodeBase64 bs@(PS _ _ !l) - | l == 0 = Right bs - | r == 0 = unsafeDupablePerformIO $ decodeBase64_ decodeB64UrlTable bs - | r == 2 = unsafeDupablePerformIO $ decodeBase64_ decodeB64UrlTable (BS.append bs "==") - | r == 3 = validateLastPad bs $ decodeBase64_ decodeB64UrlTable (BS.append bs "=") - | otherwise = Left "Base64-encoded bytestring has invalid size" +decodeBase64Untyped :: ByteString -> Either Text ByteString +decodeBase64Untyped bs@(PS _ _ !l) + | l == 0 = Right mempty + | r == 0 = unsafeDupablePerformIO $ decodeBase64_ decodeB64UrlTable bs + | r == 2 = unsafeDupablePerformIO $ decodeBase64_ decodeB64UrlTable $ BS.append bs "==" + | r == 3 = validateLastPad bs $ decodeBase64_ decodeB64UrlTable $ BS.append bs "=" + | otherwise = Left "Base64-encoded bytestring has invalid size" where !r = l `rem` 4 -{-# INLINE decodeBase64 #-} +{-# INLINE decodeBase64Untyped #-} -- | Encode a 'ByteString' value as Base64url 'Text' without padding. Note that for Base64url, -- padding is optional. If you call this function, you will simply be encoding @@ -113,8 +156,8 @@ -- >>> encodeBase64Unpadded "<>" -- "PDw_Pj4" -- -encodeBase64Unpadded :: ByteString -> Text -encodeBase64Unpadded = T.decodeUtf8 . encodeBase64Unpadded' +encodeBase64Unpadded :: ByteString -> Base64 'UrlUnpadded Text +encodeBase64Unpadded = fmap T.decodeUtf8 . encodeBase64Unpadded' {-# INLINE encodeBase64Unpadded #-} -- | Encode a 'ByteString' value as Base64url without padding. Note that for Base64url, @@ -128,65 +171,96 @@ -- >>> encodeBase64Unpadded' "<>" -- "PDw_Pj4" -- -encodeBase64Unpadded' :: ByteString -> ByteString -encodeBase64Unpadded' = encodeBase64Nopad_ base64UrlTable +encodeBase64Unpadded' :: ByteString -> Base64 'UrlUnpadded ByteString +encodeBase64Unpadded' = assertBase64 . encodeBase64Nopad_ base64UrlTable -- | Decode an unpadded Base64url-encoded 'ByteString' value. Input strings are -- required to be unpadded, and will undergo validation prior to decoding to -- confirm. -- --- In general, unless unpadded Base64url is explicitly required, it is --- safer to call 'decodeBase64'. --- -- See: -- -- === __Examples__: -- --- >>> decodeBase64Unpadded "PDw_Pj4" --- Right "<>" --- --- >>> decodeBase64Unpadded "PDw_Pj4=" --- Left "Base64-encoded bytestring has invalid padding" +-- >>> decodeBase64Unpadded $ assertBase64 @'UrlUnpadded "PDw_Pj4" +-- "<>" -- -decodeBase64Unpadded :: ByteString -> Either Text ByteString -decodeBase64Unpadded bs@(PS _ _ !l) - | l == 0 = Right bs - | r == 0 = validateLastPad bs $ decodeBase64_ decodeB64UrlTable bs - | r == 2 = validateLastPad bs $ decodeBase64_ decodeB64UrlTable (BS.append bs "==") - | r == 3 = validateLastPad bs $ decodeBase64_ decodeB64UrlTable (BS.append bs "=") - | otherwise = Left "Base64-encoded bytestring has invalid size" +decodeBase64Unpadded :: Base64 'UrlUnpadded ByteString -> ByteString +decodeBase64Unpadded b64@(Base64 (PS _ _ !l)) + | r == 2 = decodeBase64Padded $ coerceBase64 $ (`BS.append` "==") <$> b64 + | r == 3 = decodeBase64Padded $ coerceBase64 $ (`BS.append` "=") <$> b64 + | otherwise = decodeBase64Padded $ coerceBase64 b64 where !r = l `rem` 4 -{-# INLINE decodeBase64Unpadded #-} --- | Decode a padded Base64url-encoded 'ByteString' value. Input strings are +-- | Decode a padded, untyped Base64url-encoded 'ByteString' value. Input strings are -- required to be correctly padded, and will be validated prior to decoding -- to confirm. -- -- In general, unless padded Base64url is explicitly required, it is --- safer to call 'decodeBase64'. +-- safer to call 'decodeBase64Untyped'. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase64Padded "PDw_Pj4=" +-- >>> decodeBase64PaddedUntyped "PDw_Pj4=" -- Right "<>" -- --- >>> decodeBase64Padded "PDw_Pj4" --- Left "Base64-encoded bytestring requires padding" --- -decodeBase64Padded :: ByteString -> Either Text ByteString -decodeBase64Padded bs@(PS _ _ !l) - | l == 0 = Right bs +decodeBase64PaddedUntyped :: ByteString -> Either Text ByteString +decodeBase64PaddedUntyped bs@(PS _ _ !l) + | l == 0 = Right mempty | r == 1 = Left "Base64-encoded bytestring has invalid size" | r /= 0 = Left "Base64-encoded bytestring requires padding" | otherwise = unsafeDupablePerformIO $ decodeBase64_ decodeB64UrlTable bs where !r = l `rem` 4 +{-# INLINE decodeBase64PaddedUntyped #-} + +-- | Decode a padded Base64url-encoded 'ByteString' value. Input strings are +-- required to be correctly padded, and will be validated prior to decoding +-- to confirm. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase64Padded $ assertBase64 @'UrlPadded "PDw_Pj4=" +-- "<>" +-- +decodeBase64Padded :: Base64 'UrlPadded ByteString -> ByteString +decodeBase64Padded = decodeBase64Typed_ decodeB64UrlTable {-# INLINE decodeBase64Padded #-} --- | Leniently decode an unpadded Base64url-encoded 'ByteString'. This function +-- | Decode an unpadded, untyped Base64url-encoded 'ByteString' value. Input strings are +-- required to be unpadded, and will undergo validation prior to decoding to +-- confirm. +-- +-- In general, unless unpadded Base64url is explicitly required, it is +-- safer to call 'decodeBase64Untyped'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase64UnpaddedUntyped "PDw_Pj4" +-- Right "<>" +-- +-- >>> decodeBase64UnpaddedUntyped "PDw_Pj4=" +-- Left "Base64-encoded bytestring has invalid padding" +-- +decodeBase64UnpaddedUntyped :: ByteString -> Either Text ByteString +decodeBase64UnpaddedUntyped bs@(PS _ _ !l) + | l == 0 = Right mempty + | r == 0 = validateLastPad bs $ decodeBase64_ decodeB64UrlTable bs + | r == 2 = validateLastPad bs $ decodeBase64_ decodeB64UrlTable $ BS.append bs "==" + | r == 3 = validateLastPad bs $ decodeBase64_ decodeB64UrlTable $ BS.append bs "=" + | otherwise = Left "Base64-encoded bytestring has invalid size" + where + !r = l `rem` 4 +{-# INLINE decodeBase64UnpaddedUntyped #-} + +-- | Leniently decode an unpadded, untyped Base64url-encoded 'ByteString'. This function -- will not generate parse errors. If input data contains padding chars, -- then the input will be parsed up until the first pad character. -- @@ -222,7 +296,9 @@ -- False -- isBase64Url :: ByteString -> Bool -isBase64Url bs = isValidBase64Url bs && isRight (decodeBase64 bs) +isBase64Url bs + = isValidBase64Url bs + && isRight (decodeBase64Untyped bs) {-# INLINE isBase64Url #-} -- | Tell whether a 'ByteString' is a valid Base64url format. diff --git a/src/Data/ByteString/Lazy/Base64.hs b/src/Data/ByteString/Lazy/Base64.hs --- a/src/Data/ByteString/Lazy/Base64.hs +++ b/src/Data/ByteString/Lazy/Base64.hs @@ -1,8 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DataKinds #-} -- | -- Module : Data.ByteString.Lazy.Base64 --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -20,6 +20,7 @@ , encodeBase64' -- * Decoding , decodeBase64 +, decodeBase64Untyped , decodeBase64Lenient -- * Validation , isBase64 @@ -27,18 +28,26 @@ ) where -import Prelude hiding (all, elem) - +import Data.Base64.Types import qualified Data.ByteString as BS import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Base64.Internal.Utils (reChunkN) -import Data.ByteString.Lazy (elem, fromChunks, toChunks) +import Data.ByteString.Lazy (fromChunks, toChunks) +import qualified Data.ByteString.Lazy as BL import Data.ByteString.Lazy.Internal (ByteString(..)) import Data.Either (isRight) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL +-- $setup +-- +-- >>> import Data.Base64.Types +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- + -- | Encode a 'ByteString' value as Base64 'Text' with padding. -- -- See: @@ -48,8 +57,8 @@ -- >>> encodeBase64 "Sun" -- "U3Vu" -- -encodeBase64 :: ByteString -> TL.Text -encodeBase64 = TL.decodeUtf8 . encodeBase64' +encodeBase64 :: ByteString -> Base64 'StdPadded TL.Text +encodeBase64 = fmap TL.decodeUtf8 . encodeBase64' {-# INLINE encodeBase64 #-} -- | Encode a 'ByteString' value as a Base64 'ByteString' value with padding. @@ -61,9 +70,10 @@ -- >>> encodeBase64' "Sun" -- "U3Vu" -- -encodeBase64' :: ByteString -> ByteString -encodeBase64' = fromChunks - . fmap B64.encodeBase64' +encodeBase64' :: ByteString -> Base64 'StdPadded ByteString +encodeBase64' = assertBase64 + . fromChunks + . fmap (extractBase64 . B64.encodeBase64') . reChunkN 3 . toChunks {-# INLINE encodeBase64' #-} @@ -74,21 +84,37 @@ -- -- === __Examples__: -- --- >>> decodeBase64 "U3Vu" +-- >>> decodeBase64 $ assertBase64 @'StdPadded "U3Vu" +-- "Sun" +-- +decodeBase64 :: StdAlphabet k => Base64 k ByteString -> ByteString +decodeBase64 = fromChunks + . pure + . B64.decodeBase64 + . fmap (BS.concat . toChunks) +{-# INLINE decodeBase64 #-} + +-- | Decode a padded untyped Base64-encoded 'ByteString' value. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase64Untyped "U3Vu" -- Right "Sun" -- --- >>> decodeBase64 "U3V" +-- >>> decodeBase64Untyped "U3V" -- Left "Base64-encoded bytestring requires padding" -- --- >>> decodebase64 "U3V=" +-- >>> decodeBase64Untyped "U3V=" -- Left "non-canonical encoding detected at offset: 2" -- -decodeBase64 :: ByteString -> Either T.Text ByteString -decodeBase64 = fmap (fromChunks . (:[])) - . B64.decodeBase64 +decodeBase64Untyped :: ByteString -> Either T.Text ByteString +decodeBase64Untyped = fmap (fromChunks . pure) + . B64.decodeBase64Untyped . BS.concat . toChunks -{-# INLINE decodeBase64 #-} +{-# inline decodeBase64Untyped #-} -- | Leniently decode an unpadded Base64-encoded 'ByteString' value. This function -- will not generate parse errors. If input data contains padding chars, @@ -104,21 +130,21 @@ -- >>> decodeBase64Lenient "U3V" -- "Su" -- --- >>> decodebase64Lenient "U3V=" +-- >>> decodeBase64Lenient "U3V=" -- "Su" -- decodeBase64Lenient :: ByteString -> ByteString decodeBase64Lenient = fromChunks . fmap B64.decodeBase64Lenient . reChunkN 4 - . fmap (BS.filter (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=")) + . fmap (BS.filter (`BL.elem` "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=")) . toChunks {-# INLINE decodeBase64Lenient #-} -- | Tell whether a 'ByteString' value is base64 encoded. -- -- This function will also detect non-canonical encodings such as @ZE==@, which are --- externally valid Base64url-encoded values, but are internally inconsistent "impossible" +-- externally valid Base64-encoded values, but are internally inconsistent "impossible" -- values. -- -- === __Examples__: @@ -133,12 +159,14 @@ -- False -- isBase64 :: ByteString -> Bool -isBase64 bs = isValidBase64 bs && isRight (decodeBase64 bs) +isBase64 bs + = isValidBase64 bs + && isRight (decodeBase64Untyped bs) {-# INLINE isBase64 #-} -- | Tell whether a 'ByteString' value is a valid Base64 format. -- --- This will not tell you whether or not this is a correct Base64url representation, +-- This will not tell you whether or not this is a correct Base64 representation, -- only that it conforms to the correct shape. To check whether it is a true -- Base64 encoded 'ByteString' value, use 'isBase64'. -- @@ -162,6 +190,6 @@ go [] = True go [c] = B64.isValidBase64 c go (c:cs) = -- note the lack of padding char - BS.all (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") c + BS.all (`BL.elem` "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") c && go cs {-# INLINE isValidBase64 #-} diff --git a/src/Data/ByteString/Lazy/Base64/URL.hs b/src/Data/ByteString/Lazy/Base64/URL.hs --- a/src/Data/ByteString/Lazy/Base64/URL.hs +++ b/src/Data/ByteString/Lazy/Base64/URL.hs @@ -1,9 +1,9 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} -- | -- Module : Data.ByteString.Lazy.Base64.URL --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -23,8 +23,11 @@ , encodeBase64Unpadded' -- * Decoding , decodeBase64 +, decodeBase64Untyped , decodeBase64Unpadded +, decodeBase64UnpaddedUntyped , decodeBase64Padded +, decodeBase64PaddedUntyped , decodeBase64Lenient -- * Validation , isBase64Url @@ -32,12 +35,12 @@ ) where -import Prelude hiding (all, elem) - +import Data.Base64.Types import qualified Data.ByteString as BS import qualified Data.ByteString.Base64.URL as B64U import Data.ByteString.Base64.Internal.Utils (reChunkN) -import Data.ByteString.Lazy (elem, fromChunks, toChunks) +import Data.ByteString.Lazy (fromChunks, toChunks) +import qualified Data.ByteString.Lazy as BL import Data.ByteString.Lazy.Internal (ByteString(..)) import Data.Either (isRight) import qualified Data.Text as T @@ -45,6 +48,14 @@ import qualified Data.Text.Lazy.Encoding as TL +-- $setup +-- +-- >>> import Data.Base64.Types +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- + -- | Encode a 'ByteString' value as a Base64url 'Text' value with padding. -- -- See: @@ -54,8 +65,8 @@ -- >>> encodeBase64 "<>" -- "PDw_Pj4=" -- -encodeBase64 :: ByteString -> TL.Text -encodeBase64 = TL.decodeUtf8 . encodeBase64' +encodeBase64 :: ByteString -> Base64 'UrlPadded TL.Text +encodeBase64 = fmap TL.decodeUtf8 . encodeBase64' {-# INLINE encodeBase64 #-} -- | Encode a 'ByteString' as a Base64url 'ByteString' value with padding. @@ -67,44 +78,74 @@ -- >>> encodeBase64' "<>" -- "PDw_Pj4=" -- -encodeBase64' :: ByteString -> ByteString -encodeBase64' = fromChunks - . fmap B64U.encodeBase64' +encodeBase64' :: ByteString -> Base64 'UrlPadded ByteString +encodeBase64' = assertBase64 . fromChunks + . fmap (extractBase64 . B64U.encodeBase64') . reChunkN 3 . toChunks +-- | Decode a Base64url encoded 'ByteString' value, either padded or unpadded. +-- The correct decoding function is dispatched based on the existence of padding. +-- +-- For typed values: +-- - If a padded value is required, use 'decodeBase64Padded' +-- - If an unpadded value is required, use 'decodeBase64Unpadded' +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase64 $ assertBase64 @'UrlPadded "PDw_Pj4=" +-- "<>" +-- +-- >>> decodeBase64 $ assertBase64 @'UrlUnpadded "PDw_Pj4" +-- "<>" +-- +-- >>> decodeBase64 $ assertBase64 @'UrlUnpadded "PDw-Pg" +-- "<<>>" +-- +decodeBase64 + :: UrlAlphabet k + => Base64 k ByteString + -> ByteString +decodeBase64 = fromChunks + . pure + . B64U.decodeBase64 + . fmap (BS.concat . toChunks) +{-# INLINE decodeBase64 #-} + -- | Decode a padded Base64url encoded 'ByteString' value. If its length is not a multiple -- of 4, then padding chars will be added to fill out the input to a multiple of -- 4 for safe decoding as Base64url-encoded values are optionally padded. -- --- For a decoder that fails on unpadded input of incorrect size, use 'decodeBase64Unpadded'. +-- For a decoder that fails to decode untyped values of incorrect size: +-- - If a padded value is required, use 'decodeBase64PaddedUntyped' +-- - If an unpadded value is required, use 'decodeBase64UnpaddedUntyped' -- -- See: -- -- === __Examples__: -- --- >>> decodeBase64 "PDw_Pj4=" +-- >>> decodeBase64Untyped "PDw_Pj4=" -- Right "<>" -- --- >>> decodeBase64 "PDw_Pj4" +-- >>> decodeBase64Untyped "PDw_Pj4" -- Right "<>" -- --- >>> decodeBase64 "PDw-Pg=" +-- >>> decodeBase64Untyped "PDw-Pg=" -- Left "Base64-encoded bytestring has invalid padding" -- --- >>> decodeBase64 "PDw-Pg" +-- >>> decodeBase64Untyped "PDw-Pg" -- Right "<<>>" -- -decodeBase64 :: ByteString -> Either T.Text ByteString -decodeBase64 = fmap (fromChunks . (:[])) - . B64U.decodeBase64 +decodeBase64Untyped :: ByteString -> Either T.Text ByteString +decodeBase64Untyped = fmap (fromChunks . pure) + . B64U.decodeBase64Untyped . BS.concat . toChunks -{-# INLINE decodeBase64 #-} +{-# INLINE decodeBase64Untyped #-} --- | Encode a 'ByteString' value as Base64url 'Text' without padding. Note that for Base64url, --- padding is optional. If you call this function, you will simply be encoding --- as Base64url and stripping padding chars from the output. +-- | Encode a 'ByteString' value as Base64url 'Text' without padding. -- -- See: -- @@ -113,13 +154,11 @@ -- >>> encodeBase64Unpadded "<>" -- "PDw_Pj4" -- -encodeBase64Unpadded :: ByteString -> TL.Text -encodeBase64Unpadded = TL.decodeUtf8 . encodeBase64Unpadded' +encodeBase64Unpadded :: ByteString -> Base64 'UrlUnpadded TL.Text +encodeBase64Unpadded = fmap TL.decodeUtf8 . encodeBase64Unpadded' {-# INLINE encodeBase64Unpadded #-} --- | Encode a 'ByteString' value as Base64url without padding. Note that for Base64url, --- padding is optional. If you call this function, you will simply be encoding --- as Base64url and stripping padding chars from the output. +-- | Encode a 'ByteString' value as Base64url without padding. -- -- See: -- @@ -128,37 +167,69 @@ -- >>> encodeBase64Unpadded' "<>" -- "PDw_Pj4" -- -encodeBase64Unpadded' :: ByteString -> ByteString -encodeBase64Unpadded' = fromChunks - . fmap B64U.encodeBase64Unpadded' +encodeBase64Unpadded' :: ByteString -> Base64 'UrlUnpadded ByteString +encodeBase64Unpadded' = assertBase64 + . fromChunks + . fmap (extractBase64 . B64U.encodeBase64Unpadded') . reChunkN 3 . toChunks --- | Decode an unpadded Base64url-encoded 'ByteString' value. Input strings are +-- | Decode an unpadded Base64url-encoded 'ByteString' value. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase64Unpadded $ assertBase64 @'UrlUnpadded "PDw_Pj4" +-- "<>" +-- +decodeBase64Unpadded :: Base64 'UrlUnpadded ByteString -> ByteString +decodeBase64Unpadded = fromChunks + . pure + . B64U.decodeBase64Unpadded + . fmap (BS.concat . toChunks) + +-- | Decode an unpadded, untyped Base64url-encoded 'ByteString' value. Input strings are -- required to be unpadded, and will undergo validation prior to decoding to -- confirm. -- -- In general, unless unpadded Base64url is explicitly required, it is --- safer to call 'decodeBase64'. +-- safer to call 'decodeBase64Untyped'. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase64Unpadded "PDw_Pj4" +-- >>> decodeBase64UnpaddedUntyped "PDw_Pj4" -- Right "<>" -- --- >>> decodeBase64Unpadded "PDw_Pj4=" +-- >>> decodeBase64UnpaddedUntyped "PDw_Pj4=" -- Left "Base64-encoded bytestring has invalid padding" -- -decodeBase64Unpadded :: ByteString -> Either T.Text ByteString -decodeBase64Unpadded = fmap (fromChunks . (:[])) - . B64U.decodeBase64Unpadded +decodeBase64UnpaddedUntyped :: ByteString -> Either T.Text ByteString +decodeBase64UnpaddedUntyped = fmap (fromChunks . (:[])) + . B64U.decodeBase64UnpaddedUntyped . BS.concat . toChunks -{-# INLINE decodeBase64Unpadded #-} +{-# INLINE decodeBase64UnpaddedUntyped #-} --- | Decode a padded Base64url-encoded 'ByteString' value. Input strings are +-- | Decode a padded Base64url-encoded 'ByteString' value. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase64Unpadded $ assertBase64 @'UrlUnpadded "PDw_Pj4" +-- "<>" +-- +decodeBase64Padded :: Base64 'UrlPadded ByteString -> ByteString +decodeBase64Padded = fromChunks + . pure + . B64U.decodeBase64Padded + . fmap (BS.concat . toChunks) +{-# inline decodeBase64Padded #-} + +-- | Decode a padded, untyped Base64url-encoded 'ByteString' value. Input strings are -- required to be correctly padded, and will be validated prior to decoding -- to confirm. -- @@ -169,20 +240,20 @@ -- -- === __Examples__: -- --- >>> decodeBase64Padded "PDw_Pj4=" +-- >>> decodeBase64PaddedUntyped "PDw_Pj4=" -- Right "<>" -- --- >>> decodeBase64Padded "PDw_Pj4" +-- >>> decodeBase64PaddedUntyped "PDw_Pj4" -- Left "Base64-encoded bytestring requires padding" -- -decodeBase64Padded :: ByteString -> Either T.Text ByteString -decodeBase64Padded = fmap (fromChunks . (:[])) - . B64U.decodeBase64Padded +decodeBase64PaddedUntyped :: ByteString -> Either T.Text ByteString +decodeBase64PaddedUntyped = fmap (fromChunks . (:[])) + . B64U.decodeBase64PaddedUntyped . BS.concat . toChunks -{-# INLINE decodeBase64Padded #-} +{-# INLINE decodeBase64PaddedUntyped #-} --- | Leniently decode an unpadded Base64url-encoded 'ByteString'. This function +-- | Leniently decode an unpadded, untyped Base64url-encoded 'ByteString'. This function -- will not generate parse errors. If input data contains padding chars, -- then the input will be parsed up until the first pad character. -- @@ -200,11 +271,11 @@ decodeBase64Lenient = fromChunks . fmap B64U.decodeBase64Lenient . reChunkN 4 - . fmap (BS.filter (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_=")) + . fmap (BS.filter (`BL.elem` "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_=")) . toChunks {-# INLINE decodeBase64Lenient #-} --- | Tell whether a 'ByteString' is Base64url-encoded. +-- | Tell whether an untyped 'ByteString' is Base64url-encoded. -- -- === __Examples__: -- @@ -218,10 +289,12 @@ -- False -- isBase64Url :: ByteString -> Bool -isBase64Url bs = isValidBase64Url bs && isRight (decodeBase64 bs) +isBase64Url bs + = isValidBase64Url bs + && isRight (decodeBase64Untyped bs) {-# INLINE isBase64Url #-} --- | Tell whether a 'ByteString' is a valid Base64url format. +-- | Tell whether an untyped 'ByteString' is a valid Base64url format. -- -- This will not tell you whether or not this is a correct Base64url representation, -- only that it conforms to the correct shape. To check whether it is a true @@ -244,6 +317,6 @@ go [] = True go [c] = B64U.isValidBase64Url c go (c:cs) = -- note the lack of padding char - BS.all (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_") c + BS.all (`BL.elem` "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_") c && go cs {-# INLINE isValidBase64Url #-} diff --git a/src/Data/ByteString/Short/Base64.hs b/src/Data/ByteString/Short/Base64.hs --- a/src/Data/ByteString/Short/Base64.hs +++ b/src/Data/ByteString/Short/Base64.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DataKinds #-} -- | -- Module : Data.ByteString.Short.Base64 --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -19,19 +19,29 @@ , encodeBase64' -- * Decoding , decodeBase64 +, decodeBase64Untyped , decodeBase64Lenient -- * Validation , isBase64 , isValidBase64 ) where - +import Data.Base64.Types import qualified Data.ByteString.Base64 as B64 import Data.ByteString.Short (ShortByteString, fromShort, toShort) import Data.Text (Text) import Data.Text.Short (ShortText) import Data.Text.Short.Unsafe (fromShortByteStringUnsafe) +-- $setup +-- +-- >>> import Data.Base64.Types +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- + + -- | Encode a 'ShortByteString' value as Base64 'ShortText' with padding. -- -- See: @@ -41,8 +51,8 @@ -- >>> encodeBase64 "Sun" -- "U3Vu" -- -encodeBase64 :: ShortByteString -> ShortText -encodeBase64 = fromShortByteStringUnsafe . encodeBase64' +encodeBase64 :: ShortByteString -> Base64 'StdPadded ShortText +encodeBase64 = fmap fromShortByteStringUnsafe . encodeBase64' {-# INLINE encodeBase64 #-} -- | Encode a 'ShortByteString' value as a Base64 'ShortByteString' value with padding. @@ -54,8 +64,8 @@ -- >>> encodeBase64' "Sun" -- "U3Vu" -- -encodeBase64' :: ShortByteString -> ShortByteString -encodeBase64' = toShort . B64.encodeBase64' . fromShort +encodeBase64' :: ShortByteString -> Base64 'StdPadded ShortByteString +encodeBase64' = fmap toShort . B64.encodeBase64' . fromShort {-# INLINE encodeBase64' #-} -- | Decode a padded Base64-encoded 'ShortByteString' value. @@ -64,18 +74,34 @@ -- -- === __Examples__: -- --- >>> decodeBase64 "U3Vu" +-- >>> decodeBase64 $ assertBase64 @'StdPadded "U3Vu" +-- "Sun" +-- +decodeBase64 + :: StdAlphabet k + => Base64 k ShortByteString + -> ShortByteString +decodeBase64 = toShort . B64.decodeBase64 . fmap fromShort +{-# INLINE decodeBase64 #-} + +-- | Decode a padded Base64-encoded 'ShortByteString' value. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase64Untyped "U3Vu" -- Right "Sun" -- --- >>> decodeBase64 "U3V" +-- >>> decodeBase64Untyped "U3V" -- Left "Base64-encoded bytestring requires padding" -- --- >>> decodebase64 "U3V=" +-- >>> decodeBase64Untyped "U3V=" -- Left "non-canonical encoding detected at offset: 2" -- -decodeBase64 :: ShortByteString -> Either Text ShortByteString -decodeBase64 = fmap toShort . B64.decodeBase64 . fromShort -{-# INLINE decodeBase64 #-} +decodeBase64Untyped :: ShortByteString -> Either Text ShortByteString +decodeBase64Untyped = fmap toShort . B64.decodeBase64Untyped . fromShort +{-# inline decodeBase64Untyped #-} -- | Leniently decode an unpadded Base64-encoded 'ShortByteString' value. This function -- will not generate parse errors. If input data contains padding chars, @@ -91,7 +117,7 @@ -- >>> decodeBase64Lenient "U3V" -- "Su" -- --- >>> decodebase64Lenient "U3V=" +-- >>> decodeBase64Lenient "U3V=" -- "Su" -- decodeBase64Lenient :: ShortByteString -> ShortByteString @@ -100,6 +126,10 @@ -- | Tell whether a 'ShortByteString' value is base64 encoded. -- +-- This function will also detect non-canonical encodings such as @ZE==@, which are +-- externally valid Base64-encoded values, but are internally inconsistent "impossible" +-- values. +-- -- === __Examples__: -- -- >>> isBase64 "U3Vu" @@ -117,7 +147,7 @@ -- | Tell whether a 'ShortByteString' value is a valid Base64 format. -- --- This will not tell you whether or not this is a correct Base64url representation, +-- This will not tell you whether or not this is a correct Base64 representation, -- only that it conforms to the correct shape. To check whether it is a true -- Base64 encoded 'ShortByteString' value, use 'isBase64'. -- diff --git a/src/Data/ByteString/Short/Base64/URL.hs b/src/Data/ByteString/Short/Base64/URL.hs --- a/src/Data/ByteString/Short/Base64/URL.hs +++ b/src/Data/ByteString/Short/Base64/URL.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DataKinds #-} -- | -- Module : Data.ByteString.Short.Base64.URL --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -21,8 +21,11 @@ , encodeBase64Unpadded' -- * Decoding , decodeBase64 +, decodeBase64Untyped , decodeBase64Unpadded +, decodeBase64UnpaddedUntyped , decodeBase64Padded +, decodeBase64PaddedUntyped , decodeBase64Lenient -- * Validation , isBase64Url @@ -30,12 +33,23 @@ ) where +import Data.Base64.Types + import qualified Data.ByteString.Base64.URL as B64U import Data.ByteString.Short (ShortByteString, fromShort, toShort) import Data.Text (Text) import Data.Text.Short (ShortText) import Data.Text.Short.Unsafe (fromShortByteStringUnsafe) + +-- $setup +-- +-- >>> import Data.Base64.Types +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- + -- | Encode a 'ShortByteString' value as a Base64url 'Text' value with padding. -- -- See: @@ -45,8 +59,8 @@ -- >>> encodeBase64 "<>" -- "PDw_Pj4=" -- -encodeBase64 :: ShortByteString -> ShortText -encodeBase64 = fromShortByteStringUnsafe . encodeBase64' +encodeBase64 :: ShortByteString -> Base64 'UrlPadded ShortText +encodeBase64 = fmap fromShortByteStringUnsafe . encodeBase64' {-# INLINE encodeBase64 #-} -- | Encode a 'ShortByteString' as a Base64url 'ShortByteString' value with padding. @@ -58,39 +72,61 @@ -- >>> encodeBase64' "<>" -- "PDw_Pj4=" -- -encodeBase64' :: ShortByteString -> ShortByteString -encodeBase64' = toShort . B64U.encodeBase64' . fromShort +encodeBase64' :: ShortByteString -> Base64 'UrlPadded ShortByteString +encodeBase64' = fmap toShort . B64U.encodeBase64' . fromShort --- | Decode a padded Base64url encoded 'ShortByteString' value. If its length is not a multiple +-- | Decode a Base64url encoded 'ShortByteString' value, either padded or unpadded. +-- The correct decoding function is dispatched based on the existence of padding. +-- +-- For typed values: +-- - If a padded value is required, use 'decodeBase64Padded' +-- - If an unpadded value is required, use 'decodeBase64Unpadded' +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase64 $ assertBase64 @'UrlPadded "PDw_Pj4=" +-- "<>" +-- +-- >>> decodeBase64 $ assertBase64 @'UrlUnpadded "PDw_Pj4" +-- "<>" +-- +decodeBase64 + :: UrlAlphabet k + => Base64 k ShortByteString + -> ShortByteString +decodeBase64 = toShort . B64U.decodeBase64 . fmap fromShort + +-- | Decode an untyped Base64url encoded 'ByteString' value. If its length is not a multiple -- of 4, then padding chars will be added to fill out the input to a multiple of -- 4 for safe decoding as Base64url-encoded values are optionally padded. -- --- For a decoder that fails on unpadded input of incorrect size, use 'decodeBase64Unpadded'. +-- For a decoder that fails to decode untyped values of incorrect size: +-- - If a padded value is required, use 'decodeBase64PaddedUntyped' +-- - If an unpadded value is required, use 'decodeBase64UnpaddedUntyped' -- -- See: -- -- === __Examples__: -- --- >>> decodeBase64 "PDw_Pj4=" +-- >>> decodeBase64Untyped "PDw_Pj4=" -- Right "<>" -- --- >>> decodeBase64 "PDw_Pj4" +-- >>> decodeBase64Untyped "PDw_Pj4" -- Right "<>" -- --- >>> decodeBase64 "PDw-Pg=" +-- >>> decodeBase64Untyped "PDw-Pg=" -- Left "Base64-encoded bytestring has invalid padding" -- --- >>> decodeBase64 "PDw-Pg" +-- >>> decodeBase64Untyped "PDw-Pg" -- Right "<<>>" -- -decodeBase64 :: ShortByteString -> Either Text ShortByteString -decodeBase64 = fmap toShort . B64U.decodeBase64 . fromShort - -{-# INLINE decodeBase64 #-} +decodeBase64Untyped :: ShortByteString -> Either Text ShortByteString +decodeBase64Untyped = fmap toShort . B64U.decodeBase64Untyped . fromShort +{-# inline decodeBase64Untyped #-} --- | Encode a 'ShortByteString' value as Base64url 'Text' without padding. Note that for Base64url, --- padding is optional. If you call this function, you will simply be encoding --- as Base64url and stripping padding chars from the output. +-- | Encode a 'ShortByteString' value as Base64url 'Text' without padding. -- -- See: -- @@ -99,13 +135,11 @@ -- >>> encodeBase64Unpadded "<>" -- "PDw_Pj4" -- -encodeBase64Unpadded :: ShortByteString -> ShortText -encodeBase64Unpadded = fromShortByteStringUnsafe . encodeBase64Unpadded' +encodeBase64Unpadded :: ShortByteString -> Base64 'UrlUnpadded ShortText +encodeBase64Unpadded = fmap fromShortByteStringUnsafe . encodeBase64Unpadded' {-# INLINE encodeBase64Unpadded #-} --- | Encode a 'ShortByteString' value as Base64url without padding. Note that for Base64url, --- padding is optional. If you call this function, you will simply be encoding --- as Base64url and stripping padding chars from the output. +-- | Encode a 'ShortByteString' value as Base64url without padding. -- -- See: -- @@ -114,13 +148,27 @@ -- >>> encodeBase64Unpadded' "<>" -- "PDw_Pj4" -- -encodeBase64Unpadded' :: ShortByteString -> ShortByteString -encodeBase64Unpadded' = toShort . B64U.encodeBase64Unpadded' . fromShort +encodeBase64Unpadded' :: ShortByteString -> Base64 'UrlUnpadded ShortByteString +encodeBase64Unpadded' = fmap toShort . B64U.encodeBase64Unpadded' . fromShort --- | Decode an unpadded Base64url-encoded 'ShortByteString' value. Input strings are --- required to be unpadded, and will undergo validation prior to decoding to --- confirm. +-- | Decode an unpadded Base64url-encoded 'ShortByteString' value. -- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase64Unpadded $ assertBase64 @'UrlUnpadded "PDw_Pj4" +-- "<>" +-- +decodeBase64Unpadded :: Base64 'UrlUnpadded ShortByteString -> ShortByteString +decodeBase64Unpadded = toShort . B64U.decodeBase64Unpadded . fmap fromShort +{-# INLINE decodeBase64Unpadded #-} + +-- | Decode an unpadded, untyped Base64url encoded 'ByteString' value. +-- If its length is not a multiple of 4, then padding chars will be added +-- to fill out the input to a multiple of 4 for safe decoding as +-- Base64url-encoded values are optionally padded. +-- -- In general, unless unpadded Base64url is explicitly required, it is -- safer to call 'decodeBase64'. -- @@ -128,38 +176,56 @@ -- -- === __Examples__: -- --- >>> decodeBase64Unpadded "PDw_Pj4" +-- >>> decodeBase64UnpaddedUntyped "PDw_Pj4" -- Right "<>" -- --- >>> decodeBase64Unpadded "PDw_Pj4=" +-- >>> decodeBase64UnpaddedUntyped "PDw-Pg=" -- Left "Base64-encoded bytestring has invalid padding" -- -decodeBase64Unpadded :: ShortByteString -> Either Text ShortByteString -decodeBase64Unpadded = fmap toShort . B64U.decodeBase64Unpadded . fromShort -{-# INLINE decodeBase64Unpadded #-} +-- >>> decodeBase64UnpaddedUntyped "PDw-Pg" +-- Right "<<>>" +-- +decodeBase64UnpaddedUntyped :: ShortByteString -> Either Text ShortByteString +decodeBase64UnpaddedUntyped = fmap toShort + . B64U.decodeBase64UnpaddedUntyped + . fromShort +{-# inline decodeBase64UnpaddedUntyped #-} --- | Decode a padded Base64url-encoded 'ShortByteString' value. Input strings are --- required to be correctly padded, and will be validated prior to decoding --- to confirm. +-- | Decode a padded Base64url-encoded 'ShortByteString' value. -- --- In general, unless padded Base64url is explicitly required, it is --- safer to call 'decodeBase64'. +-- See: -- +-- === __Examples__: +-- +-- >>> decodeBase64Padded $ assertBase64 @'UrlPadded "PDw_Pj4=" +-- "<>" +-- +decodeBase64Padded :: Base64 'UrlPadded ShortByteString -> ShortByteString +decodeBase64Padded = toShort . B64U.decodeBase64Padded . fmap fromShort +{-# INLINE decodeBase64Padded #-} + +-- | Decode a padded, untyped Base64url encoded 'ByteString' value. +-- +-- For a decoder that fails on unpadded input of incorrect size, +-- use 'decodeBase64UnpaddedUntyped'. +-- -- See: -- -- === __Examples__: -- --- >>> decodeBase64Padded "PDw_Pj4=" +-- >>> decodeBase64PaddedUntyped "PDw_Pj4=" -- Right "<>" -- --- >>> decodeBase64Padded "PDw_Pj4" +-- >>> decodeBase64PaddedUntyped "PDw_Pj4" -- Left "Base64-encoded bytestring requires padding" -- -decodeBase64Padded :: ShortByteString -> Either Text ShortByteString -decodeBase64Padded = fmap toShort . B64U.decodeBase64Padded . fromShort -{-# INLINE decodeBase64Padded #-} +decodeBase64PaddedUntyped :: ShortByteString -> Either Text ShortByteString +decodeBase64PaddedUntyped = fmap toShort + . B64U.decodeBase64PaddedUntyped + . fromShort +{-# inline decodeBase64PaddedUntyped #-} --- | Leniently decode an unpadded Base64url-encoded 'ShortByteString'. This function +-- | Leniently decode an unpadded, untyped Base64url-encoded 'ShortByteString'. This function -- will not generate parse errors. If input data contains padding chars, -- then the input will be parsed up until the first pad character. -- @@ -177,7 +243,7 @@ decodeBase64Lenient = toShort . B64U.decodeBase64Lenient . fromShort {-# INLINE decodeBase64Lenient #-} --- | Tell whether a 'ShortByteString' is Base64url-encoded. +-- | Tell whether an untyped 'ShortByteString' is Base64url-encoded. -- -- === __Examples__: -- @@ -194,7 +260,7 @@ isBase64Url = B64U.isBase64Url . fromShort {-# INLINE isBase64Url #-} --- | Tell whether a 'ShortByteString' is a valid Base64url format. +-- | Tell whether an untyped 'ShortByteString' is a valid Base64url format. -- -- This will not tell you whether or not this is a correct Base64url representation, -- only that it conforms to the correct shape. To check whether it is a true diff --git a/src/Data/Text/Encoding/Base64.hs b/src/Data/Text/Encoding/Base64.hs --- a/src/Data/Text/Encoding/Base64.hs +++ b/src/Data/Text/Encoding/Base64.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE DataKinds #-} -- | -- Module : Data.Text.Encoding.Base64 --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -18,7 +18,8 @@ encodeBase64 -- * Decoding , decodeBase64 -, decodeBase64With +, decodeBase64Untyped +, decodeBase64UntypedWith , decodeBase64Lenient -- * Validation , isBase64 @@ -26,6 +27,7 @@ ) where +import Data.Base64.Types import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as B64 @@ -34,6 +36,14 @@ import qualified Data.Text.Encoding as T import Data.Text.Encoding.Base64.Error +-- $setup +-- +-- >>> import Data.Base64.Types +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- + -- | Encode a 'Text' value in Base64 with padding. -- -- See: @@ -43,36 +53,39 @@ -- >>> encodeBase64 "Sun" -- "U3Vu" -- -encodeBase64 :: Text -> Text +encodeBase64 :: Text -> Base64 'StdPadded Text encodeBase64 = B64.encodeBase64 . T.encodeUtf8 {-# INLINE encodeBase64 #-} -- | Decode a padded Base64-encoded 'Text' value. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded --- text value, but it may not round trip for bad inputs. The onus is on the --- caller to make sure inputs are valid. If unsure, defer to `decodeBase64With` --- and pass in a custom decode function. --- -- See: -- -- === __Examples__: -- --- >>> decodeBase64 "U3Vu" --- Right "Sun" +-- >>> decodeBase64 $ assertBase64 @'StdPadded "U3Vu" +-- "Sun" -- --- >>> decodeBase64 "U3V" --- Left "Base64-encoded bytestring requires padding" +decodeBase64 :: StdAlphabet k => Base64 k Text -> Text +decodeBase64 = T.decodeUtf8 . B64.decodeBase64 . fmap T.encodeUtf8 +{-# INLINE decodeBase64 #-} + +-- | Decode a padded, untyped Base64-encoded 'Text' value. -- --- >>> decodebase64 "U3V=" --- Left "non-canonical encoding detected at offset: 2" +-- See: -- -decodeBase64 :: Text -> Either Text Text -decodeBase64 = fmap T.decodeLatin1 . B64.decodeBase64 . T.encodeUtf8 -{-# INLINE decodeBase64 #-} +-- === __Examples__: +-- +-- >>> decodeBase64Untyped "U3Vu" +-- Right "Sun" +-- +decodeBase64Untyped :: Text -> Either Text Text +decodeBase64Untyped = fmap T.decodeUtf8 + . B64.decodeBase64Untyped + . T.encodeUtf8 +{-# INLINE decodeBase64Untyped #-} --- | Attempt to decode a 'Text' value as Base64, converting from +-- | Attempt to decode an untyped 'Text' value as Base64, converting from -- 'ByteString' to 'Text' according to some encoding function. In practice, -- This is something like 'decodeUtf8'', which may produce an error. -- @@ -81,22 +94,22 @@ -- === __Example__: -- -- @ --- 'decodeBase64With' 'T.decodeUtf8'' +-- 'decodeBase64UntypedWith' 'T.decodeUtf8'' -- :: 'ByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'Text' -- @ -- -decodeBase64With +decodeBase64UntypedWith :: (ByteString -> Either err Text) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base64Error err) Text -decodeBase64With f t = case B64.decodeBase64 t of +decodeBase64UntypedWith f t = case B64.decodeBase64Untyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) -{-# INLINE decodeBase64With #-} +{-# INLINE decodeBase64UntypedWith #-} --- | Leniently decode a Base64-encoded 'Text' value. This function +-- | Leniently decode an untyped Base64-encoded 'Text' value. This function -- will not generate parse errors. If input data contains padding chars, -- then the input will be parsed up until the first pad character. -- @@ -110,16 +123,16 @@ -- >>> decodeBase64Lenient "U3V" -- "Su" -- --- >>> decodebase64Lenient "U3V=" +-- >>> decodeBase64Lenient "U3V=" -- "Su" -- decodeBase64Lenient :: Text -> Text -decodeBase64Lenient = T.decodeLatin1 +decodeBase64Lenient = T.decodeUtf8 . B64.decodeBase64Lenient . T.encodeUtf8 {-# INLINE decodeBase64Lenient #-} --- | Tell whether a 'Text' value is Base64-encoded. +-- | Tell whether an untyped 'Text' value is Base64-encoded. -- -- === __Examples__: -- @@ -136,7 +149,7 @@ isBase64 = B64.isBase64 . T.encodeUtf8 {-# INLINE isBase64 #-} --- | Tell whether a 'Text' value is a valid Base64 format. +-- | Tell whether an untyped 'Text' value is a valid Base64 format. -- -- This will not tell you whether or not this is a correct Base64 representation, -- only that it conforms to the correct shape. To check whether it is a true diff --git a/src/Data/Text/Encoding/Base64/Error.hs b/src/Data/Text/Encoding/Base64/Error.hs --- a/src/Data/Text/Encoding/Base64/Error.hs +++ b/src/Data/Text/Encoding/Base64/Error.hs @@ -1,8 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE Safe #-} -- | -- Module : Data.Text.Encoding.Base64.Error --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -30,10 +29,10 @@ -- unicode exceptions caught in the unicode decoding process. -- data Base64Error e - = DecodeError Text + = DecodeError !Text -- ^ The error associated with decoding failure -- as a result of the Base64 decoding process - | ConversionError e + | ConversionError !e -- ^ The error associated with the decoding failure -- as a result of the conversion process deriving diff --git a/src/Data/Text/Encoding/Base64/URL.hs b/src/Data/Text/Encoding/Base64/URL.hs --- a/src/Data/Text/Encoding/Base64/URL.hs +++ b/src/Data/Text/Encoding/Base64/URL.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE DataKinds #-} -- | -- Module : Data.Text.Encoding.Base64.URL --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -19,11 +19,14 @@ , encodeBase64Unpadded -- * Decoding , decodeBase64 -, decodeBase64With +, decodeBase64Untyped +, decodeBase64UntypedWith , decodeBase64Unpadded -, decodeBase64UnpaddedWith +, decodeBase64UnpaddedUntyped +, decodeBase64UnpaddedUntypedWith , decodeBase64Padded -, decodeBase64PaddedWith +, decodeBase64PaddedUntyped +, decodeBase64PaddedUntypedWith , decodeBase64Lenient -- * Validation , isBase64Url @@ -31,6 +34,8 @@ ) where +import Data.Base64.Types + import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString.Base64.URL as B64U @@ -39,6 +44,15 @@ import qualified Data.Text.Encoding as T import Data.Text.Encoding.Base64.Error + +-- $setup +-- +-- >>> import Data.Base64.Types +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- + -- | Encode a 'Text' value in Base64url with padding. -- -- See: @@ -48,43 +62,62 @@ -- >>> encodeBase64 "<>" -- "PDw_Pj4=" -- -encodeBase64 :: Text -> Text +encodeBase64 :: Text -> Base64 'UrlPadded Text encodeBase64 = B64U.encodeBase64 . T.encodeUtf8 {-# INLINE encodeBase64 #-} --- | Decode a padded Base64url-encoded 'Text' value. If its length is not a multiple --- of 4, then padding chars will be added to fill out the input to a multiple of --- 4 for safe decoding as base64url encodings are optionally padded. +-- | Decode a Base64url encoded 'Text' value, either padded or unpadded. +-- The correct decoding function is dispatched based on the existence of padding. -- --- For a decoder that fails on unpadded input, use 'decodeBase64Unpadded' +-- For typed values: +-- - If a padded value is required, use 'decodeBase64Padded' +-- - If an unpadded value is required, use 'decodeBase64Unpadded' -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded --- text value, but it may not round trip for bad inputs. The onus is on the --- caller to make sure inputs are valid. If unsure, defer to `decodeBase64With` --- and pass in a custom decode function. +-- See: -- +-- === __Examples__: +-- +-- >>> decodeBase64 $ assertBase64 @'UrlPadded "PDw_Pj4=" +-- "<>" +-- +-- >>> decodeBase64 $ assertBase64 @'UrlUnpadded "PDw_Pj4" +-- "<>" +-- +decodeBase64 :: UrlAlphabet k => Base64 k Text -> Text +decodeBase64 = T.decodeUtf8 . B64U.decodeBase64 . fmap T.encodeUtf8 +{-# INLINE decodeBase64 #-} + +-- | Decode an untyped Base64url encoded 'Text' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as Base64url-encoded values are optionally padded. +-- +-- For a decoder that fails to decode untyped values of incorrect size: +-- - If a padded value is required, use 'decodeBase64PaddedUntyped' +-- - If an unpadded value is required, use 'decodeBase64UnpaddedUntyped' +-- -- See: -- -- === __Examples__: -- --- >>> decodeBase64 "PDw_Pj4=" +-- >>> decodeBase64Untyped "PDw_Pj4=" -- Right "<>" -- --- >>> decodeBase64 "PDw_Pj4" +-- >>> decodeBase64Untyped "PDw_Pj4" -- Right "<>" -- --- >>> decodeBase64 "PDw-Pg=" +-- >>> decodeBase64Untyped "PDw-Pg=" -- Left "Base64-encoded bytestring has invalid padding" -- --- >>> decodeBase64 "PDw-Pg" +-- >>> decodeBase64Untyped "PDw-Pg" -- Right "<<>>" -- -decodeBase64 :: Text -> Either Text Text -decodeBase64 = fmap T.decodeLatin1 . B64U.decodeBase64 . T.encodeUtf8 -{-# INLINE decodeBase64 #-} +decodeBase64Untyped :: Text -> Either Text Text +decodeBase64Untyped = fmap T.decodeUtf8 + . B64U.decodeBase64Untyped + . T.encodeUtf8 +{-# inline decodeBase64Untyped #-} --- | Attempt to decode a 'ByteString' value as Base64url, converting from +-- | Attempt to decode an untyped 'ByteString' value as Base64url, converting from -- 'ByteString' to 'Text' according to some encoding function. In practice, -- This is something like 'decodeUtf8'', which may produce an error. -- @@ -93,24 +126,22 @@ -- === __Examples__: -- -- @ --- 'decodeBase64With' 'T.decodeUtf8'' +-- 'decodeBase64UntypedWith' 'T.decodeUtf8'' -- :: 'Text' -> 'Either' ('Base64Error' 'UnicodeException') 'Text' -- @ -- -decodeBase64With +decodeBase64UntypedWith :: (ByteString -> Either err Text) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base64Error err) Text -decodeBase64With f t = case B64U.decodeBase64 t of +decodeBase64UntypedWith f t = case B64U.decodeBase64Untyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) -{-# INLINE decodeBase64With #-} +{-# INLINE decodeBase64UntypedWith #-} --- | Encode a 'Text' value in Base64url without padding. Note that for Base64url, --- padding is optional. If you call this function, you will simply be encoding --- as Base64url and stripping padding chars from the output. +-- | Encode a 'Text' value in Base64url without padding. -- -- See: -- @@ -119,35 +150,52 @@ -- >>> encodeBase64Unpadded "<>" -- "PDw_Pj4" -- -encodeBase64Unpadded :: Text -> Text +encodeBase64Unpadded :: Text -> Base64 'UrlUnpadded Text encodeBase64Unpadded = B64U.encodeBase64Unpadded . T.encodeUtf8 {-# INLINE encodeBase64Unpadded #-} -- | Decode an unpadded Base64url encoded 'Text' value. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded --- text value, but it may not round trip for bad inputs. The onus is on the --- caller to make sure inputs are valid. If unsure, defer to --- 'decodeBase64UnpaddedWith' and pass in a custom decode function. +-- See: -- +-- === __Examples__: +-- +-- >>> decodeBase64Unpadded $ assertBase64 @'UrlUnpadded "PDw_Pj4" +-- "<>" +-- +decodeBase64Unpadded :: Base64 'UrlUnpadded Text -> Text +decodeBase64Unpadded = T.decodeUtf8 + . B64U.decodeBase64Unpadded + . fmap T.encodeUtf8 +{-# INLINE decodeBase64Unpadded #-} + +-- | Decode a unpadded, untyped Base64url-encoded 'Text' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as base64url encodings are optionally padded. +-- +-- For a decoder that fails on unpadded input, use 'decodeBase64PaddedUntyped' +-- -- See: -- -- === __Examples__: -- --- >>> decodeBase64Unpadded "PDw_Pj4" +-- >>> decodeBase64UnpaddedUntyped "PDw_Pj4" -- Right "<>" -- --- >>> decodeBase64Unpadded "PDw_Pj4=" +-- >>> decodeBase64UnpaddedUntyped "PDw-Pg=" -- Left "Base64-encoded bytestring has invalid padding" -- -decodeBase64Unpadded :: Text -> Either Text Text -decodeBase64Unpadded = fmap T.decodeLatin1 - . B64U.decodeBase64Unpadded - . T.encodeUtf8 -{-# INLINE decodeBase64Unpadded #-} +-- >>> decodeBase64UnpaddedUntyped "PDw-Pg" +-- Right "<<>>" +-- +decodeBase64UnpaddedUntyped :: Text -> Either Text Text +decodeBase64UnpaddedUntyped = fmap T.decodeUtf8 + . B64U.decodeBase64UnpaddedUntyped + . T.encodeUtf8 +{-# inline decodeBase64UnpaddedUntyped #-} --- | Attempt to decode an unpadded 'ByteString' value as Base64url, converting from + +-- | Attempt to decode an untyped, unpadded 'ByteString' value as Base64url, converting from -- 'ByteString' to 'Text' according to some encoding function. In practice, -- This is something like 'decodeUtf8'', which may produce an error. -- @@ -156,46 +204,54 @@ -- === __Example__: -- -- @ --- 'decodeBase64UnpaddedWith' 'T.decodeUtf8'' +-- 'decodeBase64UnpaddedUntypedWith' 'T.decodeUtf8'' -- :: 'ByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'Text' -- @ -- -decodeBase64UnpaddedWith +decodeBase64UnpaddedUntypedWith :: (ByteString -> Either err Text) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base64Error err) Text -decodeBase64UnpaddedWith f t = case B64U.decodeBase64Unpadded t of +decodeBase64UnpaddedUntypedWith f t = case B64U.decodeBase64UnpaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) -{-# INLINE decodeBase64UnpaddedWith #-} +{-# INLINE decodeBase64UnpaddedUntypedWith #-} --- | Decode an padded Base64url encoded 'Text' value +-- | Decode a padded Base64url encoded 'Text' value -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded --- text value, but it may not round trip for bad inputs. The onus is on the --- caller to make sure inputs are valid. If unsure, defer to 'decodeBase64PaddedWith' --- and pass in a custom decode function. +-- See: -- +-- === __Examples__: +-- +-- >>> decodeBase64Padded $ assertBase64 @'UrlPadded "PDw_Pj4=" +-- "<>" +-- +decodeBase64Padded :: Base64 'UrlPadded Text -> Text +decodeBase64Padded = T.decodeUtf8 + . B64U.decodeBase64Padded + . fmap T.encodeUtf8 +{-# INLINE decodeBase64Padded #-} + +-- | Decode an untyped, padded Base64url encoded 'Text' value +-- +-- For a decoder that fails on padded input, use 'decodeBase64UnpaddedUntyped' +-- -- See: -- -- === __Examples__: -- --- >>> decodeBase64Padded "PDw_Pj4=" +-- >>> decodeBase64PaddedUntyped "PDw_Pj4=" -- Right "<>" -- --- >>> decodeBase64Padded "PDw_Pj4" --- Left "Base64-encoded bytestring requires padding" --- -decodeBase64Padded :: Text -> Either Text Text -decodeBase64Padded = fmap T.decodeLatin1 - . B64U.decodeBase64Padded - . T.encodeUtf8 -{-# INLINE decodeBase64Padded #-} +decodeBase64PaddedUntyped :: Text -> Either Text Text +decodeBase64PaddedUntyped = fmap T.decodeUtf8 + . B64U.decodeBase64PaddedUntyped + . T.encodeUtf8 +{-# inline decodeBase64PaddedUntyped #-} --- | Attempt to decode a padded 'ByteString' value as Base64url, converting from +-- | Attempt to decode a padded, untyped 'ByteString' value as Base64url, converting from -- 'ByteString' to 'Text' according to some encoding function. In practice, -- This is something like 'decodeUtf8'', which may produce an error. -- @@ -208,18 +264,18 @@ -- :: 'ByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'Text' -- @ -- -decodeBase64PaddedWith +decodeBase64PaddedUntypedWith :: (ByteString -> Either err Text) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base64Error err) Text -decodeBase64PaddedWith f t = case B64U.decodeBase64Padded t of +decodeBase64PaddedUntypedWith f t = case B64U.decodeBase64PaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) -{-# INLINE decodeBase64PaddedWith #-} +{-# INLINE decodeBase64PaddedUntypedWith #-} --- | Leniently decode an unpadded Base64url-encoded 'Text'. This function +-- | Leniently decode an untyped Base64url-encoded 'Text'. This function -- will not generate parse errors. If input data contains padding chars, -- then the input will be parsed up until the first pad character. -- @@ -234,12 +290,12 @@ -- "<>" -- decodeBase64Lenient :: Text -> Text -decodeBase64Lenient = T.decodeLatin1 +decodeBase64Lenient = T.decodeUtf8 . B64U.decodeBase64Lenient . T.encodeUtf8 {-# INLINE decodeBase64Lenient #-} --- | Tell whether a 'Text' value is Base64url-encoded. +-- | Tell whether an untyped 'Text' value is Base64url-encoded. -- -- === __Examples__: -- @@ -256,7 +312,7 @@ isBase64Url = B64U.isBase64Url . T.encodeUtf8 {-# INLINE isBase64Url #-} --- | Tell whether a 'Text' value is a valid Base64url format. +-- | Tell whether an untyped 'Text' value is a valid Base64url format. -- -- This will not tell you whether or not this is a correct Base64url representation, -- only that it conforms to the correct shape. To check whether it is a true diff --git a/src/Data/Text/Lazy/Encoding/Base64.hs b/src/Data/Text/Lazy/Encoding/Base64.hs --- a/src/Data/Text/Lazy/Encoding/Base64.hs +++ b/src/Data/Text/Lazy/Encoding/Base64.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE DataKinds #-} -- | -- Module : Data.Text.Lazy.Encoding.Base64 --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -18,7 +18,8 @@ encodeBase64 -- * Decoding , decodeBase64 -, decodeBase64With +, decodeBase64Untyped +, decodeBase64UntypedWith , decodeBase64Lenient -- * Validation , isBase64 @@ -26,6 +27,8 @@ ) where +import Data.Base64.Types + import Data.Bifunctor (first) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Base64 as BL64 @@ -35,6 +38,16 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL + + +-- $setup +-- +-- >>> import Data.Base64.Types +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- + -- | Encode a 'TL.Text' value in Base64 with padding. -- -- See: @@ -44,7 +57,7 @@ -- >>> encodeBase64 "Sun" -- "U3Vu" -- -encodeBase64 :: TL.Text -> TL.Text +encodeBase64 :: TL.Text -> Base64 'StdPadded TL.Text encodeBase64 = BL64.encodeBase64 . TL.encodeUtf8 {-# INLINE encodeBase64 #-} @@ -52,26 +65,33 @@ -- -- See: -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded --- text value, but it may not round trip for bad inputs. The onus is on the --- caller to make sure inputs are valid. If unsure, defer to `decodeBase64With` --- and pass in a custom decode function. +-- === __Examples__: -- +-- >>> decodeBase64 $ assertBase64 @'StdPadded "U3Vu" +-- "Sun" +-- +decodeBase64 :: StdAlphabet k => Base64 k TL.Text -> TL.Text +decodeBase64 = TL.decodeUtf8 . BL64.decodeBase64 . fmap TL.encodeUtf8 +{-# INLINE decodeBase64 #-} + +-- | Decode a padded, untyped Base64-encoded 'TL.Text' value +-- +-- See: +-- -- === __Examples__: -- --- >>> decodeBase64 "U3Vu" +-- >>> decodeBase64Untyped "U3Vu" -- Right "Sun" -- --- >>> decodeBase64 "U3V" +-- >>> decodeBase64Untyped "U3V" -- Left "Base64-encoded bytestring requires padding" -- --- >>> decodebase64 "U3V=" +-- >>> decodeBase64Untyped "U3V=" -- Left "non-canonical encoding detected at offset: 2" -- -decodeBase64 :: TL.Text -> Either T.Text TL.Text -decodeBase64 = fmap TL.decodeLatin1 . BL64.decodeBase64 . TL.encodeUtf8 -{-# INLINE decodeBase64 #-} +decodeBase64Untyped :: TL.Text -> Either T.Text TL.Text +decodeBase64Untyped = fmap TL.decodeUtf8 . BL64.decodeBase64Untyped . TL.encodeUtf8 +{-# INLINE decodeBase64Untyped #-} -- | Attempt to decode a 'ByteString' value as Base64, converting from -- 'ByteString' to 'TL.Text' according to some encoding function. In practice, @@ -82,22 +102,22 @@ -- === __Example__: -- -- @ --- 'decodeBase64With' 'TL.decodeUtf8'' +-- 'decodeBase64UntypedWith' 'TL.decodeUtf8'' -- :: 'ByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'TL.Text' -- @ -- -decodeBase64With +decodeBase64UntypedWith :: (ByteString -> Either err TL.Text) -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base64Error err) TL.Text -decodeBase64With f t = case BL64.decodeBase64 t of +decodeBase64UntypedWith f t = case BL64.decodeBase64Untyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) -{-# INLINE decodeBase64With #-} +{-# INLINE decodeBase64UntypedWith #-} --- | Leniently decode a Base64-encoded 'TL.Text' value. This function +-- | Leniently decode an untyped Base64-encoded 'TL.Text' value. This function -- will not generate parse errors. If input data contains padding chars, -- then the input will be parsed up until the first pad character. -- @@ -111,16 +131,16 @@ -- >>> decodeBase64Lenient "U3V" -- "Su" -- --- >>> decodebase64Lenient "U3V=" +-- >>> decodeBase64Lenient "U3V=" -- "Su" -- decodeBase64Lenient :: TL.Text -> TL.Text -decodeBase64Lenient = TL.decodeLatin1 - . BL64.decodeBase64Lenient - . TL.encodeUtf8 +decodeBase64Lenient = TL.decodeUtf8 + . BL64.decodeBase64Lenient + . TL.encodeUtf8 {-# INLINE decodeBase64Lenient #-} --- | Tell whether a 'TL.Text' value is Base64-encoded. +-- | Tell whether an untyped 'TL.Text' value is Base64-encoded. -- -- === __Examples__: -- @@ -137,7 +157,7 @@ isBase64 = BL64.isBase64 . TL.encodeUtf8 {-# INLINE isBase64 #-} --- | Tell whether a 'TL.Text' value is a valid Base64 format. +-- | Tell whether an untyped 'TL.Text' value is a valid Base64 format. -- -- This will not tell you whether or not this is a correct Base64 representation, -- only that it conforms to the correct shape. To check whether it is a true diff --git a/src/Data/Text/Lazy/Encoding/Base64/URL.hs b/src/Data/Text/Lazy/Encoding/Base64/URL.hs --- a/src/Data/Text/Lazy/Encoding/Base64/URL.hs +++ b/src/Data/Text/Lazy/Encoding/Base64/URL.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE Safe #-} +{-# LANGUAGE DataKinds #-} -- | -- Module : Data.Text.Lazy.Encoding.Base64.URL --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -19,17 +19,21 @@ , encodeBase64Unpadded -- * Decoding , decodeBase64 -, decodeBase64With +, decodeBase64Untyped +, decodeBase64UntypedWith , decodeBase64Unpadded -, decodeBase64UnpaddedWith +, decodeBase64UnpaddedUntyped +, decodeBase64UnpaddedUntypedWith , decodeBase64Padded -, decodeBase64PaddedWith +, decodeBase64PaddedUntyped +, decodeBase64PaddedUntypedWith , decodeBase64Lenient -- * Validation , isBase64Url , isValidBase64Url ) where +import Data.Base64.Types import Data.Bifunctor (first) import Data.ByteString.Lazy (ByteString) @@ -40,6 +44,16 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL + + +-- $setup +-- +-- >>> import Data.Base64.Types +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- + -- | Encode a 'TL.Text' value in Base64url with padding. -- -- See: @@ -49,43 +63,59 @@ -- >>> encodeBase64 "<>" -- "PDw_Pj4=" -- -encodeBase64 :: TL.Text -> TL.Text +encodeBase64 :: TL.Text -> Base64 'UrlPadded TL.Text encodeBase64 = BL64U.encodeBase64 . TL.encodeUtf8 {-# INLINE encodeBase64 #-} --- | Decode a padded Base64url-encoded 'TL.Text' value. If its length is not a multiple +-- | Decode an arbitrarily Base64url-encoded 'TL.Text' value. +-- +-- For typed values: +-- - If a padded value is required, use 'decodeBase64Padded' +-- - If an unpadded value is required, use 'decodeBase64Unpadded' +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase64 $ assertBase64 @'UrlPadded "PDw_Pj4=" +-- "<>" +-- +-- >>> decodeBase64 $ assertBase64 @'UrlUnpadded "PDw_Pj4" +-- "<>" +-- +decodeBase64 :: UrlAlphabet k => Base64 k TL.Text -> TL.Text +decodeBase64 = TL.decodeUtf8 . BL64U.decodeBase64 . fmap TL.encodeUtf8 +{-# INLINE decodeBase64 #-} + +-- | Decode an untyped Base64url-encoded 'TL.Text' value. If its length is not a multiple -- of 4, then padding chars will be added to fill out the input to a multiple of -- 4 for safe decoding as base64url encodings are optionally padded. -- -- For a decoder that fails on unpadded input, use 'decodeBase64Unpadded'. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded --- text value, but it may not round trip for bad inputs. The onus is on the --- caller to make sure inputs are valid. If unsure, defer to `decodeBase64With` --- and pass in a custom decode function. --- -- See: -- -- === __Examples__: -- --- >>> decodeBase64 "PDw_Pj4=" +-- >>> decodeBase64Untyped "PDw_Pj4=" -- Right "<>" -- --- >>> decodeBase64 "PDw_Pj4" +-- >>> decodeBase64Untyped "PDw_Pj4" -- Right "<>" -- --- >>> decodeBase64 "PDw-Pg=" +-- >>> decodeBase64Untyped "PDw-Pg=" -- Left "Base64-encoded bytestring has invalid padding" -- --- >>> decodeBase64 "PDw-Pg" +-- >>> decodeBase64Untyped "PDw-Pg" -- Right "<<>>" -- -decodeBase64 :: TL.Text -> Either T.Text TL.Text -decodeBase64 = fmap TL.decodeLatin1 . BL64U.decodeBase64 . TL.encodeUtf8 -{-# INLINE decodeBase64 #-} +decodeBase64Untyped :: TL.Text -> Either T.Text TL.Text +decodeBase64Untyped = fmap TL.decodeUtf8 + . BL64U.decodeBase64Untyped + . TL.encodeUtf8 +{-# INLINE decodeBase64Untyped #-} --- | Attempt to decode a lazy 'ByteString' value as Base64url, converting from +-- | Attempt to decode an untyped lazy 'ByteString' value as Base64url, converting from -- 'ByteString' to 'TL.Text' according to some encoding function. In practice, -- This is something like 'decodeUtf8'', which may produce an error. -- @@ -98,16 +128,16 @@ -- :: 'ByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'TL.Text' -- @ -- -decodeBase64With +decodeBase64UntypedWith :: (ByteString -> Either err TL.Text) -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base64Error err) TL.Text -decodeBase64With f t = case BL64U.decodeBase64 t of +decodeBase64UntypedWith f t = case BL64U.decodeBase64Untyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) -{-# INLINE decodeBase64With #-} +{-# INLINE decodeBase64UntypedWith #-} -- | Encode a 'TL.Text' value in Base64url without padding. Note that for Base64url, -- padding is optional. If you call this function, you will simply be encoding @@ -120,35 +150,44 @@ -- >>> encodeBase64Unpadded "<>" -- "PDw_Pj4" -- -encodeBase64Unpadded :: TL.Text -> TL.Text +encodeBase64Unpadded :: TL.Text -> Base64 'UrlUnpadded TL.Text encodeBase64Unpadded = BL64U.encodeBase64Unpadded . TL.encodeUtf8 {-# INLINE encodeBase64Unpadded #-} --- | Decode an unpadded Base64url encoded 'TL.Text' value. +-- | Decode an unpadded Base64url encoded 'Text' value. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded --- text value, but it may not round trip for bad inputs. The onus is on the --- caller to make sure inputs are valid. If unsure, defer to `decodeBase64WUnpaddedWith` --- and pass in a custom decode function. +-- See: -- +-- === __Examples__: +-- +-- >>> decodeBase64Unpadded $ assertBase64 @'UrlUnpadded "PDw_Pj4" +-- "<>" +-- +decodeBase64Unpadded :: Base64 'UrlUnpadded TL.Text -> TL.Text +decodeBase64Unpadded = TL.decodeUtf8 + . BL64U.decodeBase64Unpadded + . fmap TL.encodeUtf8 +{-# INLINE decodeBase64Unpadded #-} + +-- | Decode an unpadded, untyped Base64url encoded 'TL.Text' value. +-- -- See: -- -- === __Examples__: -- --- >>> decodeBase64Unpadded "PDw_Pj4" +-- >>> decodeBase64UnpaddedUntyped "PDw_Pj4" -- Right "<>" -- --- >>> decodeBase64Unpadded "PDw_Pj4=" +-- >>> decodeBase64UnpaddedUntyped "PDw_Pj4=" -- Left "Base64-encoded bytestring has invalid padding" -- -decodeBase64Unpadded :: TL.Text -> Either T.Text TL.Text -decodeBase64Unpadded = fmap TL.decodeLatin1 - . BL64U.decodeBase64Unpadded +decodeBase64UnpaddedUntyped :: TL.Text -> Either T.Text TL.Text +decodeBase64UnpaddedUntyped = fmap TL.decodeUtf8 + . BL64U.decodeBase64UnpaddedUntyped . TL.encodeUtf8 -{-# INLINE decodeBase64Unpadded #-} +{-# INLINE decodeBase64UnpaddedUntyped #-} --- | Attempt to decode an unpadded lazy 'ByteString' value as Base64url, converting from +-- | Attempt to decode an unpadded, untyped lazy 'ByteString' value as Base64url, converting from -- 'ByteString' to 'TL.Text' according to some encoding function. In practice, -- This is something like 'decodeUtf8'', which may produce an error. -- @@ -157,46 +196,52 @@ -- === __Examples__: -- -- @ --- 'decodeBase64UnpaddedWith' 'TL.decodeUtf8'' +-- 'decodeBase64UnpaddedUntypedWith' 'TL.decodeUtf8'' -- :: 'ByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'TL.Text' -- @ -- -decodeBase64UnpaddedWith +decodeBase64UnpaddedUntypedWith :: (ByteString -> Either err TL.Text) -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base64Error err) TL.Text -decodeBase64UnpaddedWith f t = case BL64U.decodeBase64Unpadded t of +decodeBase64UnpaddedUntypedWith f t = case BL64U.decodeBase64UnpaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) -{-# INLINE decodeBase64UnpaddedWith #-} +{-# INLINE decodeBase64UnpaddedUntypedWith #-} --- | Decode an padded Base64url encoded 'TL.Text' value +-- | Decode a padded Base64url encoded 'TL.Text' value -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded --- text value, but it may not round trip for bad inputs. The onus is on the --- caller to make sure inputs are valid. If unsure, defer to `decodeBase64PaddedWith` --- and pass in a custom decode function. +-- See: -- +-- === __Examples__: +-- +-- >>> decodeBase64Padded $ assertBase64 @'UrlPadded "PDw_Pj4=" +-- "<>" +-- +decodeBase64Padded :: Base64 'UrlPadded TL.Text -> TL.Text +decodeBase64Padded = TL.decodeUtf8 + . BL64U.decodeBase64Padded + . fmap TL.encodeUtf8 +{-# INLINE decodeBase64Padded #-} + +-- | Decode an untyped, padded Base64url encoded 'Text' value +-- -- See: -- -- === __Examples__: -- --- >>> decodeBase64Padded "PDw_Pj4=" +-- >>> decodeBase64PaddedUntyped "PDw_Pj4=" -- Right "<>" -- --- >>> decodeBase64Padded "PDw_Pj4" --- Left "Base64-encoded bytestring requires padding" --- -decodeBase64Padded :: TL.Text -> Either T.Text TL.Text -decodeBase64Padded = fmap TL.decodeLatin1 - . BL64U.decodeBase64Padded - . TL.encodeUtf8 -{-# INLINE decodeBase64Padded #-} +decodeBase64PaddedUntyped :: TL.Text -> Either T.Text TL.Text +decodeBase64PaddedUntyped = fmap TL.decodeUtf8 + . BL64U.decodeBase64PaddedUntyped + . TL.encodeUtf8 +{-# inline decodeBase64PaddedUntyped #-} --- | Attempt to decode a padded lazy 'ByteString' value as Base64url, converting from +-- | Attempt to decode a padded, untyped lazy 'ByteString' value as Base64url, converting from -- 'ByteString' to 'TL.Text' according to some encoding function. In practice, -- This is something like 'decodeUtf8'', which may produce an error. -- @@ -209,18 +254,18 @@ -- :: 'ByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'Text' -- @ -- -decodeBase64PaddedWith +decodeBase64PaddedUntypedWith :: (ByteString -> Either err TL.Text) -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base64Error err) TL.Text -decodeBase64PaddedWith f t = case BL64U.decodeBase64Padded t of +decodeBase64PaddedUntypedWith f t = case BL64U.decodeBase64PaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) -{-# INLINE decodeBase64PaddedWith #-} +{-# INLINE decodeBase64PaddedUntypedWith #-} --- | Leniently decode an unpadded Base64url-encoded 'TL.Text'. This function +-- | Leniently decode an untyped Base64url-encoded 'TL.Text'. This function -- will not generate parse errors. If input data contains padding chars, -- then the input will be parsed up until the first pad character. -- @@ -235,12 +280,12 @@ -- "<>" -- decodeBase64Lenient :: TL.Text -> TL.Text -decodeBase64Lenient = TL.decodeLatin1 +decodeBase64Lenient = TL.decodeUtf8 . BL64U.decodeBase64Lenient . TL.encodeUtf8 {-# INLINE decodeBase64Lenient #-} --- | Tell whether a 'TL.Text' value is Base64url-encoded +-- | Tell whether an untyped 'TL.Text' value is Base64url-encoded -- -- === __Examples__: -- @@ -257,7 +302,7 @@ isBase64Url = BL64U.isBase64Url . TL.encodeUtf8 {-# INLINE isBase64Url #-} --- | Tell whether a 'TL.Text' value is a valid Base64url format. +-- | Tell whether an untyped 'TL.Text' value is a valid Base64url format. -- -- This will not tell you whether or not this is a correct Base64url representation, -- only that it conforms to the correct shape. To check whether it is a true diff --git a/src/Data/Text/Short/Encoding/Base64.hs b/src/Data/Text/Short/Encoding/Base64.hs --- a/src/Data/Text/Short/Encoding/Base64.hs +++ b/src/Data/Text/Short/Encoding/Base64.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DataKinds #-} -- | -- Module : Data.Text.Short.Encoding.Base64 --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -18,13 +18,15 @@ encodeBase64 -- * Decoding , decodeBase64 -, decodeBase64With +, decodeBase64Untyped +, decodeBase64UntypedWith , decodeBase64Lenient -- * Validation , isBase64 , isValidBase64 ) where +import Data.Base64.Types import Data.Bifunctor (first) import qualified Data.ByteString.Base64 as B64 @@ -36,6 +38,15 @@ import Data.Text.Short import Data.Text.Short.Unsafe + +-- $setup +-- +-- >>> import Data.Base64.Types +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- + -- | Encode a 'ShortText' value in Base64 with padding. -- -- See: @@ -45,38 +56,45 @@ -- >>> encodeBase64 "Sun" -- "U3Vu" -- -encodeBase64 :: ShortText -> ShortText -encodeBase64 = fromByteStringUnsafe +encodeBase64 :: ShortText -> Base64 'StdPadded ShortText +encodeBase64 = fmap fromByteStringUnsafe . B64.encodeBase64' . toByteString {-# INLINE encodeBase64 #-} -- | Decode a padded Base64-encoded 'ShortText' value -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded --- text value, but it may not round trip for bad inputs. The onus is on the --- caller to make sure inputs are valid. If unsure, defer to `decodeBase64With` --- and pass in a custom decode function. +-- See: -- +-- === __Examples__: +-- +-- >>> decodeBase64 $ assertBase64 @'StdPadded "U3Vu" +-- "Sun" +-- +decodeBase64 :: StdAlphabet k => Base64 k ShortText -> ShortText +decodeBase64 = fromText . B64T.decodeBase64 . fmap toText +{-# INLINE decodeBase64 #-} + +-- | Decode a padded Base64-encoded 'ShortText' value +-- -- See: -- -- === __Examples__: -- --- >>> decodeBase64 "U3Vu" +-- >>> decodeBase64Untyped "U3Vu" -- Right "Sun" -- --- >>> decodeBase64 "U3V" +-- >>> decodeBase64Untyped "U3V" -- Left "Base64-encoded bytestring requires padding" -- --- >>> decodebase64 "U3V=" +-- >>> decodeBase64Untyped "U3V=" -- Left "non-canonical encoding detected at offset: 2" -- -decodeBase64 :: ShortText -> Either Text ShortText -decodeBase64 = fmap fromText . B64T.decodeBase64 . toText -{-# INLINE decodeBase64 #-} +decodeBase64Untyped :: ShortText -> Either Text ShortText +decodeBase64Untyped = fmap fromText . B64T.decodeBase64Untyped . toText +{-# INLINE decodeBase64Untyped #-} --- | Attempt to decode a 'ShortByteString' value as Base64, converting from +-- | Attempt to decode an untyped 'ShortByteString' value as Base64, converting from -- 'ByteString' to 'ShortText' according to some encoding function. In practice, -- This is something like 'decodeUtf8'', which may produce an error. -- @@ -85,22 +103,22 @@ -- === __Example__: -- -- @ --- 'decodeBase64With' 'T.decodeUtf8'' +-- 'decodeBase64UntypedWith' 'T.decodeUtf8'' -- :: 'ShortByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'ShortText' -- @ -- -decodeBase64With +decodeBase64UntypedWith :: (ShortByteString -> Either err ShortText) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ShortByteString -- ^ Input text to decode -> Either (Base64Error err) ShortText -decodeBase64With f t = case BS64.decodeBase64 t of +decodeBase64UntypedWith f t = case BS64.decodeBase64Untyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) -{-# INLINE decodeBase64With #-} +{-# INLINE decodeBase64UntypedWith #-} --- | Leniently decode a Base64-encoded 'ShortText' value. This function +-- | Leniently decode an untyped Base64-encoded 'ShortText' value. This function -- will not generate parse errors. If input data contains padding chars, -- then the input will be parsed up until the first pad character. -- @@ -114,14 +132,14 @@ -- >>> decodeBase64Lenient "U3V" -- "Su" -- --- >>> decodebase64Lenient "U3V=" +-- >>> decodeBase64Lenient "U3V=" -- "Su" -- decodeBase64Lenient :: ShortText -> ShortText decodeBase64Lenient = fromText . B64T.decodeBase64Lenient . toText {-# INLINE decodeBase64Lenient #-} --- | Tell whether a 'ShortText' value is Base64-encoded. +-- | Tell whether an untyped 'ShortText' value is Base64-encoded. -- -- === __Examples__: -- @@ -138,7 +156,7 @@ isBase64 = B64.isBase64 . toByteString {-# INLINE isBase64 #-} --- | Tell whether a 'ShortText' value is a valid Base64 format. +-- | Tell whether an untyped 'ShortText' value is a valid Base64 format. -- -- This will not tell you whether or not this is a correct Base64 representation, -- only that it conforms to the correct shape. To check whether it is a true diff --git a/src/Data/Text/Short/Encoding/Base64/URL.hs b/src/Data/Text/Short/Encoding/Base64/URL.hs --- a/src/Data/Text/Short/Encoding/Base64/URL.hs +++ b/src/Data/Text/Short/Encoding/Base64/URL.hs @@ -1,7 +1,7 @@ -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE DataKinds #-} -- | -- Module : Data.Text.Short.Encoding.Base64.URL --- Copyright : (c) 2019-2020 Emily Pillmore +-- Copyright : (c) 2019-2023 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -19,17 +19,21 @@ , encodeBase64Unpadded -- * Decoding , decodeBase64 -, decodeBase64With +, decodeBase64Untyped +, decodeBase64UntypedWith , decodeBase64Unpadded -, decodeBase64UnpaddedWith +, decodeBase64UnpaddedUntyped +, decodeBase64UnpaddedUntypedWith , decodeBase64Padded -, decodeBase64PaddedWith +, decodeBase64PaddedUntyped +, decodeBase64PaddedUntypedWith , decodeBase64Lenient -- * Validation , isBase64Url , isValidBase64Url ) where +import Data.Base64.Types import Data.Bifunctor (first) import qualified Data.ByteString.Base64.URL as B64U @@ -41,6 +45,16 @@ import Data.Text.Short import Data.Text.Short.Unsafe + +-- $setup +-- +-- >>> import Data.Base64.Types +-- >>> :set -XOverloadedStrings +-- >>> :set -XTypeApplications +-- >>> :set -XDataKinds +-- + + -- | Encode a 'ShortText' value in Base64url with padding. -- -- See: @@ -50,20 +64,40 @@ -- >>> encodeBase64 "<>" -- "PDw_Pj4=" -- -encodeBase64 :: ShortText -> ShortText -encodeBase64 = fromByteStringUnsafe +encodeBase64 :: ShortText -> Base64 'UrlPadded ShortText +encodeBase64 = fmap fromByteStringUnsafe . B64U.encodeBase64' . toByteString {-# INLINE encodeBase64 #-} --- | Decode a padded Base64url-encoded 'ShortText' value. If its length is not a multiple +-- | Decode an arbitrarily padded Base64url-encoded 'ShortText' value. +-- +-- For typed values: +-- - If a padded value is required, use 'decodeBase64Padded' +-- - If an unpadded value is required, use 'decodeBase64Unpadded' +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase64 $ assertBase64 @'UrlPadded "PDw_Pj4=" +-- "<>" +-- +-- >>> decodeBase64 $ assertBase64 @'UrlUnpadded "PDw_Pj4" +-- "<>" +-- +decodeBase64 :: UrlAlphabet k => Base64 k ShortText -> ShortText +decodeBase64 = fromText . B64TU.decodeBase64 . fmap toText +{-# INLINE decodeBase64 #-} + +-- | Decode an untyped padded Base64url-encoded 'ShortText' value. If its length is not a multiple -- of 4, then padding chars will be added to fill out the input to a multiple of -- 4 for safe decoding as base64url encodings are optionally padded. -- -- For a decoder that fails on unpadded input, use 'decodeBase64Unpadded'. -- -- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded +-- 'T.decodeUtf8'. This will always round trip for any valid Base64-encoded -- text value, but it may not round trip for bad inputs. The onus is on the -- caller to make sure inputs are valid. If unsure, defer to `decodeBase64With` -- and pass in a custom decode function. @@ -72,23 +106,23 @@ -- -- === __Examples__: -- --- >>> decodeBase64 "PDw_Pj4=" +-- >>> decodeBase64Untyped "PDw_Pj4=" -- Right "<>" -- --- >>> decodeBase64 "PDw_Pj4" +-- >>> decodeBase64Untyped "PDw_Pj4" -- Right "<>" -- --- >>> decodeBase64 "PDw-Pg=" +-- >>> decodeBase64Untyped "PDw-Pg=" -- Left "Base64-encoded bytestring has invalid padding" -- --- >>> decodeBase64 "PDw-Pg" +-- >>> decodeBase64Untyped "PDw-Pg" -- Right "<<>>" -- -decodeBase64 :: ShortText -> Either Text ShortText -decodeBase64 = fmap fromText . B64TU.decodeBase64 . toText -{-# INLINE decodeBase64 #-} +decodeBase64Untyped :: ShortText -> Either Text ShortText +decodeBase64Untyped = fmap fromText . B64TU.decodeBase64Untyped . toText +{-# INLINE decodeBase64Untyped #-} --- | Attempt to decode a 'ShortByteString' value as Base64url, converting from +-- | Attempt to decode an untyped 'ShortByteString' value as Base64url, converting from -- 'ByteString' to 'ShortText' according to some encoding function. In practice, -- This is something like 'decodeUtf8'', which may produce an error. -- @@ -101,20 +135,18 @@ -- :: 'ShortByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'ShortText' -- @ -- -decodeBase64With +decodeBase64UntypedWith :: (ShortByteString -> Either err ShortText) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ShortByteString -- ^ Input text to decode -> Either (Base64Error err) ShortText -decodeBase64With f t = case BS64U.decodeBase64 t of +decodeBase64UntypedWith f t = case BS64U.decodeBase64Untyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) -{-# INLINE decodeBase64With #-} +{-# INLINE decodeBase64UntypedWith #-} --- | Encode a 'ShortText' value in Base64url without padding. Note that for Base64url, --- padding is optional. If you call this function, you will simply be encoding --- as Base64url and stripping padding chars from the output. +-- | Encode a 'ShortText' value in Base64url without padding. -- -- See: -- @@ -123,35 +155,44 @@ -- >>> encodeBase64Unpadded "<>" -- "PDw_Pj4" -- -encodeBase64Unpadded :: ShortText -> ShortText -encodeBase64Unpadded = fromByteStringUnsafe +encodeBase64Unpadded :: ShortText -> Base64 'UrlUnpadded ShortText +encodeBase64Unpadded = fmap fromByteStringUnsafe . B64U.encodeBase64Unpadded' . toByteString {-# INLINE encodeBase64Unpadded #-} -- | Decode an unpadded Base64url encoded 'ShortText' value. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded --- text value, but it may not round trip for bad inputs. The onus is on the --- caller to make sure inputs are valid. If unsure, defer to `decodeBase64UnpaddedWith` --- and pass in a custom decode function. +-- See: -- +-- === __Examples__: +-- +-- >>> decodeBase64Unpadded $ assertBase64 @'UrlUnpadded "PDw_Pj4" +-- "<>" +-- +decodeBase64Unpadded :: Base64 'UrlUnpadded ShortText -> ShortText +decodeBase64Unpadded = fromText . B64TU.decodeBase64Unpadded . fmap toText +{-# INLINE decodeBase64Unpadded #-} + +-- | Decode an untyped, unpadded Base64url encoded 'ShortText' value. +-- -- See: -- -- === __Examples__: -- --- >>> decodeBase64Unpadded "PDw_Pj4" +-- >>> decodeBase64UnpaddedUntyped "PDw_Pj4" -- Right "<>" -- --- >>> decodeBase64Unpadded "PDw_Pj4=" +-- >>> decodeBase64UnpaddedUntyped "PDw_Pj4=" -- Left "Base64-encoded bytestring has invalid padding" -- -decodeBase64Unpadded :: ShortText -> Either Text ShortText -decodeBase64Unpadded = fmap fromText . B64TU.decodeBase64Unpadded . toText -{-# INLINE decodeBase64Unpadded #-} +decodeBase64UnpaddedUntyped :: ShortText -> Either Text ShortText +decodeBase64UnpaddedUntyped = fmap fromText + . B64TU.decodeBase64UnpaddedUntyped + . toText +{-# INLINE decodeBase64UnpaddedUntyped #-} --- | Attempt to decode an unpadded 'ShortByteString' value as Base64url, converting from +-- | Attempt to decode an untyped, unpadded 'ShortByteString' value as Base64url, converting from -- 'ShortByteString' to 'ShortText' according to some encoding function. In practice, -- This is something like 'decodeUtf8'', which may produce an error. -- @@ -164,40 +205,47 @@ -- :: 'ShortByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'ShortText' -- @ -- -decodeBase64UnpaddedWith +decodeBase64UnpaddedUntypedWith :: (ShortByteString -> Either err ShortText) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ShortByteString -- ^ Input text to decode -> Either (Base64Error err) ShortText -decodeBase64UnpaddedWith f t = case BS64U.decodeBase64Unpadded t of +decodeBase64UnpaddedUntypedWith f t = case BS64U.decodeBase64UnpaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) -{-# INLINE decodeBase64UnpaddedWith #-} +{-# INLINE decodeBase64UnpaddedUntypedWith #-} --- | Decode an padded Base64url encoded 'ShortText' value +-- | Decode a padded Base64url encoded 'ShortText' value -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded --- text value, but it may not round trip for bad inputs. The onus is on the --- caller to make sure inputs are valid. If unsure, defer to `decodeBase64PaddedWith` --- and pass in a custom decode function. +-- See: -- +-- === __Examples__: +-- +-- >>> decodeBase64Padded $ assertBase64 @'UrlPadded "PDw_Pj4=" +-- "<>" +-- +decodeBase64Padded :: Base64 'UrlPadded ShortText -> ShortText +decodeBase64Padded = fromText . B64TU.decodeBase64Padded . fmap toText +{-# INLINE decodeBase64Padded #-} + +-- | Decode an untyped, padded Base64url encoded 'ShortText' value +-- -- See: -- -- === __Examples__: -- --- >>> decodeBase64Padded "PDw_Pj4=" +-- >>> decodeBase64PaddedUntyped "PDw_Pj4=" -- Right "<>" -- --- >>> decodeBase64Padded "PDw_Pj4" +-- >>> decodeBase64PaddedUntyped "PDw_Pj4" -- Left "Base64-encoded bytestring requires padding" -- -decodeBase64Padded :: ShortText -> Either Text ShortText -decodeBase64Padded = fmap fromText . B64TU.decodeBase64Padded . toText -{-# INLINE decodeBase64Padded #-} +decodeBase64PaddedUntyped :: ShortText -> Either Text ShortText +decodeBase64PaddedUntyped = fmap fromText . B64TU.decodeBase64PaddedUntyped . toText +{-# INLINE decodeBase64PaddedUntyped #-} --- | Attempt to decode a padded 'ShortByteString' value as Base64url, converting from +-- | Attempt to decode an untyped, padded 'ShortByteString' value as Base64url, converting from -- 'ByteString' to 'ShortText' according to some encoding function. In practice, -- This is something like 'decodeUtf8'', which may produce an error. -- @@ -210,18 +258,18 @@ -- :: 'ShortByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'ShortText' -- @ -- -decodeBase64PaddedWith +decodeBase64PaddedUntypedWith :: (ShortByteString -> Either err ShortText) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ShortByteString -- ^ Input text to decode -> Either (Base64Error err) ShortText -decodeBase64PaddedWith f t = case BS64U.decodeBase64Padded t of +decodeBase64PaddedUntypedWith f t = case BS64U.decodeBase64PaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) -{-# INLINE decodeBase64PaddedWith #-} +{-# INLINE decodeBase64PaddedUntypedWith #-} --- | Leniently decode an unpadded Base64url-encoded 'ShortText'. This function +-- | Leniently decode an untyped, unpadded Base64url-encoded 'ShortText'. This function -- will not generate parse errors. If input data contains padding chars, -- then the input will be parsed up until the first pad character. -- @@ -239,7 +287,7 @@ decodeBase64Lenient = fromText . B64TU.decodeBase64Lenient . toText {-# INLINE decodeBase64Lenient #-} --- | Tell whether a 'ShortText' value is Base64url-encoded. +-- | Tell whether an untyped 'ShortText' value is Base64url-encoded. -- -- === __Examples__: -- @@ -256,7 +304,7 @@ isBase64Url = B64U.isBase64Url . toByteString {-# INLINE isBase64Url #-} --- | Tell whether a 'ShortText' value is a valid Base64url format. +-- | Tell whether an untyped 'ShortText' value is a valid Base64url format. -- -- This will not tell you whether or not this is a correct Base64url representation, -- only that it conforms to the correct shape. To check whether it is a true diff --git a/test/Internal.hs b/test/Internal.hs --- a/test/Internal.hs +++ b/test/Internal.hs @@ -1,5 +1,7 @@ {-# LANGUAGE PackageImports #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Main @@ -27,6 +29,7 @@ ) where +import "base64" Data.Base64.Types import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Short as SBS @@ -58,13 +61,17 @@ -- data Harness bs = Harness { label :: String - , encode :: bs -> bs - , encodeUrl :: bs -> bs - , encodeUrlNopad :: bs -> bs + , encode :: bs -> Base64 'StdPadded bs + , encodeUrl :: bs -> Base64 'UrlPadded bs + , encodeUrlNopad :: bs -> Base64 'UrlUnpadded bs , decode :: bs -> Either Text bs + , decodeTyped :: Base64 'StdPadded bs -> bs , decodeUrl :: bs -> Either Text bs , decodeUrlPad :: bs -> Either Text bs , decodeUrlNopad :: bs -> Either Text bs + , decodeUrlTyped :: forall k. UrlAlphabet k => Base64 k bs -> bs + , decodeUrlTypedPad :: Base64 'UrlPadded bs -> bs + , decodeUrlTypedNopad :: Base64 'UrlUnpadded bs -> bs , lenientUrl :: bs -> bs , lenient :: bs -> bs , correct :: bs -> Bool @@ -78,15 +85,19 @@ b64 = Harness { label = "ByteString" , encode = B64.encodeBase64' - , decode = B64.decodeBase64 + , decode = B64.decodeBase64Untyped + , decodeTyped = B64.decodeBase64 , lenient = B64.decodeBase64Lenient , correct = B64.isBase64 , validate = B64.isValidBase64 , encodeUrl = B64U.encodeBase64' , encodeUrlNopad = B64U.encodeBase64Unpadded' - , decodeUrl = B64U.decodeBase64 - , decodeUrlPad = B64U.decodeBase64Padded - , decodeUrlNopad = B64U.decodeBase64Unpadded + , decodeUrl = B64U.decodeBase64Untyped + , decodeUrlPad = B64U.decodeBase64PaddedUntyped + , decodeUrlNopad = B64U.decodeBase64UnpaddedUntyped + , decodeUrlTyped = B64U.decodeBase64 + , decodeUrlTypedPad = B64U.decodeBase64Padded + , decodeUrlTypedNopad = B64U.decodeBase64Unpadded , lenientUrl = B64U.decodeBase64Lenient , correctUrl = B64U.isBase64Url , validateUrl = B64U.isValidBase64Url @@ -96,15 +107,19 @@ lb64 = Harness { label = "Lazy ByteString" , encode = LB64.encodeBase64' - , decode = LB64.decodeBase64 + , decode = LB64.decodeBase64Untyped + , decodeTyped = LB64.decodeBase64 , lenient = LB64.decodeBase64Lenient , correct = LB64.isBase64 , validate = LB64.isValidBase64 , encodeUrl = LB64U.encodeBase64' , encodeUrlNopad = LB64U.encodeBase64Unpadded' - , decodeUrl = LB64U.decodeBase64 - , decodeUrlPad = LB64U.decodeBase64Padded - , decodeUrlNopad = LB64U.decodeBase64Unpadded + , decodeUrl = LB64U.decodeBase64Untyped + , decodeUrlPad = LB64U.decodeBase64PaddedUntyped + , decodeUrlNopad = LB64U.decodeBase64UnpaddedUntyped + , decodeUrlTyped = LB64U.decodeBase64 + , decodeUrlTypedPad = LB64U.decodeBase64Padded + , decodeUrlTypedNopad = LB64U.decodeBase64Unpadded , lenientUrl = LB64U.decodeBase64Lenient , correctUrl = LB64U.isBase64Url , validateUrl = LB64U.isValidBase64Url @@ -114,15 +129,19 @@ sb64 = Harness { label = "Short ByteString" , encode = SB64.encodeBase64' - , decode = SB64.decodeBase64 + , decode = SB64.decodeBase64Untyped + , decodeTyped = SB64.decodeBase64 , lenient = SB64.decodeBase64Lenient , correct = SB64.isBase64 , validate = SB64.isValidBase64 , encodeUrl = SB64U.encodeBase64' , encodeUrlNopad = SB64U.encodeBase64Unpadded' - , decodeUrl = SB64U.decodeBase64 - , decodeUrlPad = SB64U.decodeBase64Padded - , decodeUrlNopad = SB64U.decodeBase64Unpadded + , decodeUrl = SB64U.decodeBase64Untyped + , decodeUrlPad = SB64U.decodeBase64PaddedUntyped + , decodeUrlNopad = SB64U.decodeBase64UnpaddedUntyped + , decodeUrlTyped = SB64U.decodeBase64 + , decodeUrlTypedPad = SB64U.decodeBase64Padded + , decodeUrlTypedNopad = SB64U.decodeBase64Unpadded , lenientUrl = SB64U.decodeBase64Lenient , correctUrl = SB64U.isBase64Url , validateUrl = SB64U.isValidBase64Url @@ -132,15 +151,19 @@ t64 = Harness { label = "Text" , encode = T64.encodeBase64 - , decode = T64.decodeBase64 + , decode = T64.decodeBase64Untyped + , decodeTyped = T64.decodeBase64 , lenient = T64.decodeBase64Lenient , correct = T64.isBase64 , validate = T64.isValidBase64 , encodeUrl = T64U.encodeBase64 , encodeUrlNopad = T64U.encodeBase64Unpadded - , decodeUrl = T64U.decodeBase64 - , decodeUrlPad = T64U.decodeBase64Padded - , decodeUrlNopad = T64U.decodeBase64Unpadded + , decodeUrl = T64U.decodeBase64Untyped + , decodeUrlPad = T64U.decodeBase64PaddedUntyped + , decodeUrlNopad = T64U.decodeBase64UnpaddedUntyped + , decodeUrlTyped = T64U.decodeBase64 + , decodeUrlTypedPad = T64U.decodeBase64Padded + , decodeUrlTypedNopad = T64U.decodeBase64Unpadded , lenientUrl = T64U.decodeBase64Lenient , correctUrl = T64U.isBase64Url , validateUrl = T64U.isValidBase64Url @@ -150,15 +173,19 @@ tl64 = Harness { label = "Lazy Text" , encode = TL64.encodeBase64 - , decode = TL64.decodeBase64 + , decode = TL64.decodeBase64Untyped + , decodeTyped = TL64.decodeBase64 , lenient = TL64.decodeBase64Lenient , correct = TL64.isBase64 , validate = TL64.isValidBase64 , encodeUrl = TL64U.encodeBase64 , encodeUrlNopad = TL64U.encodeBase64Unpadded - , decodeUrl = TL64U.decodeBase64 - , decodeUrlPad = TL64U.decodeBase64Padded - , decodeUrlNopad = TL64U.decodeBase64Unpadded + , decodeUrl = TL64U.decodeBase64Untyped + , decodeUrlPad = TL64U.decodeBase64PaddedUntyped + , decodeUrlNopad = TL64U.decodeBase64UnpaddedUntyped + , decodeUrlTyped = TL64U.decodeBase64 + , decodeUrlTypedPad = TL64U.decodeBase64Padded + , decodeUrlTypedNopad = TL64U.decodeBase64Unpadded , lenientUrl = TL64U.decodeBase64Lenient , correctUrl = TL64U.isBase64Url , validateUrl = TL64U.isValidBase64Url @@ -168,15 +195,19 @@ ts64 = Harness { label = "Short Text" , encode = TS64.encodeBase64 - , decode = TS64.decodeBase64 + , decode = TS64.decodeBase64Untyped + , decodeTyped = TS64.decodeBase64 , lenient = TS64.decodeBase64Lenient , correct = TS64.isBase64 , validate = TS64.isValidBase64 , encodeUrl = TS64U.encodeBase64 , encodeUrlNopad = TS64U.encodeBase64Unpadded - , decodeUrl = TS64U.decodeBase64 - , decodeUrlPad = TS64U.decodeBase64Padded - , decodeUrlNopad = TS64U.decodeBase64Unpadded + , decodeUrl = TS64U.decodeBase64Untyped + , decodeUrlPad = TS64U.decodeBase64PaddedUntyped + , decodeUrlNopad = TS64U.decodeBase64UnpaddedUntyped + , decodeUrlTyped = TS64U.decodeBase64 + , decodeUrlTypedPad = TS64U.decodeBase64Padded + , decodeUrlTypedNopad = TS64U.decodeBase64Unpadded , lenientUrl = TS64U.decodeBase64Lenient , correctUrl = TS64U.isBase64Url , validateUrl = TS64U.isValidBase64Url @@ -194,26 +225,26 @@ tt64 :: TextHarness BS.ByteString Text tt64 = TextHarness - { decodeWith_ = T64.decodeBase64With - , decodeUrlWith_ = T64U.decodeBase64With - , decodeUrlPaddedWith_ = T64U.decodeBase64PaddedWith - , decodeUrlUnpaddedWith_ = T64U.decodeBase64UnpaddedWith + { decodeWith_ = T64.decodeBase64UntypedWith + , decodeUrlWith_ = T64U.decodeBase64UntypedWith + , decodeUrlPaddedWith_ = T64U.decodeBase64PaddedUntypedWith + , decodeUrlUnpaddedWith_ = T64U.decodeBase64UnpaddedUntypedWith } ttl64 :: TextHarness LBS.ByteString TL.Text ttl64 = TextHarness - { decodeWith_ = TL64.decodeBase64With - , decodeUrlWith_ = TL64U.decodeBase64With - , decodeUrlPaddedWith_ = TL64U.decodeBase64PaddedWith - , decodeUrlUnpaddedWith_ = TL64U.decodeBase64UnpaddedWith + { decodeWith_ = TL64.decodeBase64UntypedWith + , decodeUrlWith_ = TL64U.decodeBase64UntypedWith + , decodeUrlPaddedWith_ = TL64U.decodeBase64PaddedUntypedWith + , decodeUrlUnpaddedWith_ = TL64U.decodeBase64UnpaddedUntypedWith } tts64 :: TextHarness SBS.ShortByteString TS.ShortText tts64 = TextHarness - { decodeWith_ = TS64.decodeBase64With - , decodeUrlWith_ = TS64U.decodeBase64With - , decodeUrlPaddedWith_ = TS64U.decodeBase64PaddedWith - , decodeUrlUnpaddedWith_ = TS64U.decodeBase64UnpaddedWith + { decodeWith_ = TS64.decodeBase64UntypedWith + , decodeUrlWith_ = TS64U.decodeBase64UntypedWith + , decodeUrlPaddedWith_ = TS64U.decodeBase64PaddedUntypedWith + , decodeUrlUnpaddedWith_ = TS64U.decodeBase64UnpaddedUntypedWith } -- ------------------------------------------------------------------ -- @@ -241,12 +272,12 @@ coarbitrary = coarbitrary . SBS.unpack instance Arbitrary T.Text where - arbitrary = T.pack <$> arbitrary - shrink xs = T.pack <$> shrink (T.unpack xs) + arbitrary = T.pack . getUnicodeString <$> arbitrary + shrink xs = T.pack . getUnicodeString <$> shrink (UnicodeString $ T.unpack xs) instance Arbitrary TL.Text where - arbitrary = TL.pack <$> arbitrary - shrink xs = TL.pack <$> shrink (TL.unpack xs) + arbitrary = TL.pack . getUnicodeString <$> arbitrary + shrink xs = TL.pack . getUnicodeString <$> shrink (UnicodeString $ TL.unpack xs) instance CoArbitrary T.Text where coarbitrary = coarbitrary . T.unpack @@ -256,7 +287,7 @@ instance Arbitrary TS.ShortText where arbitrary = TS.fromText <$> arbitrary - shrink xs = fmap TS.fromText $ shrink (TS.toText xs) + shrink xs = TS.fromText <$> shrink (TS.toText xs) instance CoArbitrary TS.ShortText where coarbitrary = coarbitrary . TS.toText diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -2,6 +2,8 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE DataKinds #-} -- | -- Module : Main -- Copyright : (c) 2019-2020 Emily Pillmore @@ -20,6 +22,8 @@ import Prelude hiding (length) +import Data.Base64.Types + import Data.Bifunctor (second) import qualified Data.ByteString as BS import Data.ByteString.Internal (c2w) @@ -163,58 +167,66 @@ prop_roundtrip :: (Arbitrary a, IsString a, Eq a, Show a) => Harness a -> TestTree prop_roundtrip Harness{..} = testGroup "prop_roundtrip" - [ testProperty "prop_std_roundtrip" $ \(bs :: b) -> - Right (encode bs) == decode (encode (encode bs)) - , testProperty "prop_url_roundtrip" $ \(bs :: b) -> - Right (encodeUrl bs) == decodeUrl (encodeUrl (encodeUrl bs)) - , testProperty "prop_url_roundtrip_nopad" $ \(bs :: b) -> - Right (encodeUrlNopad bs) - == decodeUrlNopad (encodeUrlNopad (encodeUrlNopad bs)) - , testProperty "prop_std_lenient_roundtrip" $ \(bs :: b) -> - encode bs == lenient (encode (encode bs)) - , testProperty "prop_url_lenient_roundtrip" $ \(bs :: b) -> - encodeUrl bs == lenientUrl (encodeUrl (encodeUrl bs)) + [ testProperty "prop_std_roundtrip" $ \(bs :: a) -> + Right bs == decode (extractBase64 $ encode bs) + , testProperty "prop_url_roundtrip" $ \(bs :: a) -> + Right bs == decodeUrl (extractBase64 $ encodeUrl bs) + , testProperty "prop_url_roundtrip_nopad" $ \(bs :: a) -> + Right bs + == decodeUrlNopad (extractBase64 $ encodeUrlNopad bs) + , testProperty "prop_std_lenient_roundtrip" $ \(bs :: a) -> + bs == lenient (extractBase64 $ encode bs) + , testProperty "prop_url_lenient_roundtrip" $ \(bs :: a) -> + bs == lenientUrl (extractBase64 $ encodeUrl bs) ] prop_correctness :: (Arbitrary a, IsString a, Eq a, Show a) => Harness a -> TestTree prop_correctness Harness{..} = testGroup "prop_validity" - [ testProperty "prop_std_valid" $ \(bs :: b) -> - validate (encode bs) - , testProperty "prop_url_valid" $ \(bs :: b) -> - validateUrl (encodeUrl bs) - , testProperty "prop_std_correct" $ \(bs :: b) -> - correct (encode bs) - , testProperty "prop_url_correct" $ \(bs :: b) -> - correctUrl (encodeUrl bs) + [ testProperty "prop_std_valid" $ \(bs :: a) -> + validate (extractBase64 $ encode bs) + , testProperty "prop_url_valid" $ \(bs :: a) -> + validateUrl (extractBase64 $ encodeUrl bs) + , testProperty "prop_std_correct" $ \(bs :: a) -> + correct (extractBase64 $ encode bs) + , testProperty "prop_url_correct" $ \(bs :: a) -> + correctUrl (extractBase64 $ encodeUrl bs) ] prop_url_padding :: (Arbitrary a, IsString a, Eq a, Show a) => Harness a -> TestTree prop_url_padding Harness{..} = testGroup "prop_url_padding" - [ testProperty "prop_url_nopad_roundtrip" $ \(bs :: b) -> - Right (encodeUrlNopad bs) - == decodeUrlNopad (encodeUrlNopad (encodeUrlNopad bs)) - - , testProperty "prop_url_pad_roundtrip" $ \(bs :: b) -> - Right (encodeUrl bs) == decodeUrlPad (encodeUrl (encodeUrl bs)) + [ testProperty "prop_url_nopad_roundtrip_untyped" $ \(bs :: a) -> + Right bs + == decodeUrlNopad (extractBase64 $ encodeUrlNopad bs) + , testProperty "prop_url_nopad_roundtrip_typed" $ \(bs :: a) -> + bs == decodeUrlTypedNopad (encodeUrlNopad bs) + , testProperty "prop_url_pad_roundtrip_untyped" $ \(bs :: a) -> + Right bs == decodeUrlPad (extractBase64 $ encodeUrl bs) + , testProperty "prop_url_pad_roundtrip_typed" $ \(bs :: a) -> + bs == decodeUrlTypedPad (encodeUrl bs) + , testProperty "prop_url_decode_invariant_untyped" $ \(bs :: a) -> + (decodeUrlNopad (extractBase64 $ encodeUrlNopad bs) + == decodeUrl (extractBase64 $ encodeUrlNopad bs)) + || + (decodeUrlPad (extractBase64 $ encodeUrl bs) + == decodeUrl (extractBase64 $ encodeUrl bs)) - , testProperty "prop_url_decode_invariant" $ \(bs :: b) -> - ( decodeUrlNopad (encodeUrlNopad (encodeUrlNopad bs)) - == decodeUrl (encodeUrl (encodeUrl bs)) - ) || - ( decodeUrlPad (encodeUrl (encodeUrl bs)) - == decodeUrl (encodeUrl (encodeUrl bs)) - ) + , testProperty "prop_url_decode_invariant_typed" $ \(bs :: a) -> + (decodeUrlTypedNopad (encodeUrlNopad bs) + == decodeUrlTyped (encodeUrlNopad bs)) + || + (decodeUrlPad (extractBase64 $ encodeUrl bs) + == decodeUrl (extractBase64 $ encodeUrl bs)) -- NOTE: we need to fix the bitmasking issue for "impossible" -- inputs - , testProperty "prop_url_padding_coherence" $ \(bs :: b) -> - Right (encodeUrl bs) == decodeUrl (encodeUrl (encodeUrl bs)) - && Right (encodeUrl bs) == decodeUrlPad (encodeUrl (encodeUrl bs)) + , testProperty "prop_url_padding_coherence" $ \(bs :: a) -> + Right bs == decodeUrl (extractBase64 $ encodeUrl bs) + && Right bs == decodeUrlPad (extractBase64 $ encodeUrl bs) - , testProperty "prop_url_nopadding_coherence" $ \(bs :: b) -> - Right (encodeUrlNopad bs) == decodeUrlNopad (encodeUrlNopad (encodeUrlNopad bs)) - && Right (encodeUrlNopad bs) == decodeUrl (encodeUrlNopad (encodeUrlNopad bs)) + , testProperty "prop_url_nopadding_coherence" $ \(bs :: a) -> + Right bs == decodeUrlNopad (extractBase64 $ encodeUrlNopad bs) + && Right bs == decodeUrl (extractBase64 $ encodeUrlNopad bs) ] -- | just a sanity check against `base64-bytestring` @@ -222,11 +234,13 @@ prop_bos_coherence :: TestTree prop_bos_coherence = testGroup "prop_bos_coherence" [ testProperty "prop_std_bos_coherence" $ \bs -> - Right bs == B64.decodeBase64 (B64.encodeBase64' bs) + Right bs == B64.decodeBase64Untyped (extractBase64 $ B64.encodeBase64' bs) && Right bs == Bos.decode (Bos.encode bs) + && bs == B64.decodeBase64 (B64.encodeBase64' bs) , testProperty "prop_url_bos_coherence" $ \bs -> - Right bs == B64U.decodeBase64 (B64U.encodeBase64' bs) + Right bs == B64U.decodeBase64Untyped (extractBase64 $ B64U.encodeBase64' bs) && Right bs == BosU.decode (BosU.encode bs) + && bs == B64U.decodeBase64 (B64U.encodeBase64' bs) ] -- ---------------------------------------------------------------- -- @@ -260,19 +274,31 @@ testCaseStd s t = testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do step "encode is sound" - t @=? encode s + assertBase64 t @=? encode s - step "decode is sound" - Right s @=? decode (encode s) + step "decode is sound - untyped" + Right s @=? decode (extractBase64 $ encode s) + Right s @=? decode t + step "decode is sound - typed" + s @=? decodeTyped (encode s) + s @=? decodeTyped (assertBase64 t) + testCaseUrl s t = testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do step "encode is sound" - t @=? encodeUrl s + assertBase64 t @=? encodeUrl s - step "decode is sound" - Right s @=? decodeUrlPad t + step "decode is sound - untyped" + Right s @=? decodeUrl (extractBase64 $ encodeUrl s) + Right s @=? decodeUrl t + step "decode is sound - typed" + s @=? decodeUrlTyped (encodeUrl s) + s @=? decodeUrlTypedPad (encodeUrl s) + s @=? decodeUrlTyped (assertBase64 @'UrlPadded t) + s @=? decodeUrlTypedPad (assertBase64 @'UrlPadded t) + -- | Url-safe padding unit tests (stresses entire alphabet) -- paddingTests @@ -361,29 +387,29 @@ offsetVectors Harness{..} = testGroup "Offset tests" [ testGroup "Invalid padding" [ testCase "Invalid staggered padding" $ do - decodeUrl "=A==" @=? Left "invalid padding at offset: 0" - decodeUrl "P===" @=? Left "invalid padding at offset: 1" + decodeUrl "=A==" @=? Left "invalid padding near offset: 0" + decodeUrl "P===" @=? Left "invalid padding near offset: 1" , testCase "Invalid character coverage - final chunk" $ do - decodeUrl "%D==" @=? Left "invalid character at offset: 0" - decodeUrl "P%==" @=? Left "invalid character at offset: 1" - decodeUrl "PD%=" @=? Left "invalid character at offset: 2" - decodeUrl "PA=%" @=? Left "invalid character at offset: 3" - decodeUrl "PDw%" @=? Left "invalid character at offset: 3" + decodeUrl "%D==" @=? Left "invalid base64 encoding near offset: 0" + decodeUrl "P%==" @=? Left "invalid base64 encoding near offset: 1" + decodeUrl "PD%=" @=? Left "invalid base64 encoding near offset: 2" + decodeUrl "PA=%" @=? Left "invalid base64 encoding near offset: 3" + decodeUrl "PDw%" @=? Left "invalid base64 encoding near offset: 3" , testCase "Invalid character coverage - decode chunk" $ do - decodeUrl "%Dw_PDw_" @=? Left "invalid character at offset: 0" - decodeUrl "P%w_PDw_" @=? Left "invalid character at offset: 1" - decodeUrl "PD%_PDw_" @=? Left "invalid character at offset: 2" - decodeUrl "PDw%PDw_" @=? Left "invalid character at offset: 3" + decodeUrl "%Dw_PDw_" @=? Left "invalid base64 encoding near offset: 0" + decodeUrl "P%w_PDw_" @=? Left "invalid base64 encoding near offset: 1" + decodeUrl "PD%_PDw_" @=? Left "invalid base64 encoding near offset: 2" + decodeUrl "PDw%PDw_" @=? Left "invalid base64 encoding near offset: 3" , testCase "Invalid padding in body" $ do - decodeUrl "PD=_PDw_" @=? Left "invalid padding at offset: 2" - decodeUrl "PDw=PDw_" @=? Left "invalid padding at offset: 3" + decodeUrl "PD=_PDw_" @=? Left "invalid padding near offset: 2" + decodeUrl "PDw=PDw_" @=? Left "invalid padding near offset: 3" , testCase "Padding fails everywhere but end" $ do - decode "=eAoeAo=" @=? Left "invalid padding at offset: 0" - decode "e=AoeAo=" @=? Left "invalid padding at offset: 1" - decode "eA=oeAo=" @=? Left "invalid padding at offset: 2" - decode "eAo=eAo=" @=? Left "invalid padding at offset: 3" - decode "eAoe=Ao=" @=? Left "invalid padding at offset: 4" - decode "eAoeA=o=" @=? Left "invalid padding at offset: 5" + decode "=eAoeAo=" @=? Left "invalid padding near offset: 0" + decode "e=AoeAo=" @=? Left "invalid padding near offset: 1" + decode "eA=oeAo=" @=? Left "invalid padding near offset: 2" + decode "eAo=eAo=" @=? Left "invalid padding near offset: 3" + decode "eAoe=Ao=" @=? Left "invalid padding near offset: 4" + decode "eAoeA=o=" @=? Left "invalid padding near offset: 5" ] ] @@ -433,7 +459,7 @@ Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodeWith valid utf8 inputs on decodeUtf8" $ do - case decodeWith_ utf8 (encode h "\1079743") of + case decodeWith_ utf8 (extractBase64 $ encode h "\1079743") of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" , testCase "decodeUrlWith non-utf8 inputs on decodeUtf8" $ do @@ -441,7 +467,7 @@ Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodeUrlWith valid utf8 inputs on decodeUtf8" $ do - case decodeUrlWith_ utf8 (encodeUrl h "\1079743") of + case decodeUrlWith_ utf8 (extractBase64 $ encodeUrl h "\1079743") of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" , testCase "decodeUrlPaddedWith non-utf8 inputs on decodeUtf8" $ do @@ -449,7 +475,7 @@ Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodePaddedWith valid utf8 inputs on decodeUtf8" $ do - case decodeUrlPaddedWith_ utf8 (encodeUrl h "\1079743") of + case decodeUrlPaddedWith_ utf8 (extractBase64 $ encodeUrl h "\1079743") of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" , testCase "decodeUnpaddedWith non-utf8 inputs on decodeUtf8" $ do @@ -457,7 +483,7 @@ Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodeUnpaddedWith valid utf8 inputs on decodeUtf8" $ do - case decodeUrlUnpaddedWith_ utf8 (encodeUrlNopad h "\1079743") of + case decodeUrlUnpaddedWith_ utf8 (extractBase64 $ encodeUrlNopad h "\1079743") of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" ]