diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,28 @@ # Revision history for base32 +## 1.0 + +This release introduces a typed encoding API with breaking signature changes. +See [MIGRATION-1.0.md](MIGRATION-1.0.md) for the changes from 0.4. + +* Introduce alphabet- and padding-tagged `Base32` values in `Data.Base32.Types`. + Encoders return wrapped values; typed decoders consume them. Checked decoders + now use the `Untyped` suffix for consuming raw Base32 encoded bytes. + + Typed decoding uses unchecked scalar and SIMD loops, with streaming lazy decoding. + `StdAlphabet` and `HexAlphabet` admit both padding forms in general typed decoders; + padding-specific typed decoders require exact tags. + +* Replace `isBase32`, `isValidBase32`, `isBase32Hex`, and `isValidBase32Hex` with + `parseBase32Padded` and `parseBase32Unpadded` in all twelve APIs. + Parsers preserve input, accept the decoder's existing case-insensitive alphabets, + and check unused pad bits. Noncanonical pad bits are now rejected by decoders too. These were removed because they had no measurable downstream usage, and were of questionable utility. +* Added an optional, default-off `simd` flag with NEON, SSSE3, and AVX2 prefixes + and a portable scalar fallback, for both standard and extended-hex alphabets. +* Remove `Data.ByteString.Base32.Internal`; use `Internal.Head` for codec entry + points and `Internal.Utils` for `validateLastNPads`. They were relics of older development. +* Support GHC 9.6–9.14; update copyright through 2026, CI, bounds, and benchmarks. + ## 0.4 * Support for GHC 9.8 diff --git a/LICENSE b/LICENSE --- a/LICENSE +++ b/LICENSE @@ -1,4 +1,4 @@ -Copyright (c) 2020, Emily Pillmore +Copyright (c) 2020-2026, Emily Pillmore All rights reserved. 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,95 @@ +# Migrating from base32 0.4 to 1.0 + +## Encoded values carry their alphabet and padding + +Encoding now produces type-tagged values that carry the alphabet and padding provenance +carried out by the encoding. You can extract these bytes or assert their provenance by importing `Data.Base32.Types` and manipulating the wrapper through the supplied functions. `Alphabet(..)` is also included, and can be used in conjunction with `-XDataKinds` to assert what you need. Standard encoders return `Base32 'StdPadded a` +or `Base32 'StdUnpadded a`, while extended-hex encoders return `Base32 'HexPadded a` or +`Base32 'HexUnpadded a`. For example: + +```haskell +-- Before +rawb32bytes = B32.encodeBase32' bytes + +-- After, when the surrounding API expects a plain ByteString +rawb32bytes = extractBase32 (B32.encodeBase32' unencodedbytes) + +-- A typed roundtrip no longer returns Either +unencodedBytesAgain = B32.decodeBase32 (B32.encodeBase32' unencodedbytes) +``` + +The reasoning behind this wrapper is clear from a performance perspective: by shoving the information about the bytes into the typed wrapper and shunting the contract to the user +or the program, we have all the info we need to forego validity checks during the decode +process. This removes most branching from the procedure and hotpath detection is both +faster and easier, resulting in a significant speedup. Go Haskell! + +## Checked decoding keeps an explicit name + +| 0.4 | 1.0 checked equivalent | +| --- | --- | +| `decodeBase32` | `decodeBase32Untyped` | +| `decodeBase32Padded` | `decodeBase32PaddedUntyped` | +| `decodeBase32Unpadded` | `decodeBase32UnpaddedUntyped` | + +These replacements apply to all twelve ByteString/Text modules. The old names +now consume `Base32` values and return the decoded result directly. The +`decodeBase32With`, `decodeBase32PaddedWith`, and `decodeBase32UnpaddedWith` +functions keep their checked signatures and names, and are `Text` only, because +decoding is separate from utf8 conversion and errors are surfaced accordingly for each step. + +Typed decoders use dedicated unchecked loops. They trust the established +provenance and do not check the alphabet, input length, padding, or unused bits. +`decodeBase32` accepts both padding forms within its alphabet through the +`StdAlphabet k` or `HexAlphabet k` constraint. The padding-specific decoders +require the corresponding exact tag, so mixing their API paths is a type error. +For example, `decodeBase32Padded (encodeBase32Unpadded' bytes)` cannot compile. +Use `TypeFamilies` when writing signatures with these constraints. +Callers using `assertBase32`, record updates, or mapping instances must preserve +validity themselves. + +Typed lazy decoding streams through complete quanta. Checked lazy decoding and +parsing still validate a complete finite input. + +## Replace predicates with parsers + +`isBase32`, `isValidBase32`, `isBase32Hex`, and `isValidBase32Hex` are removed. +Use `parseBase32Padded` or `parseBase32Unpadded` from the corresponding standard +or `.Hex` module. Each returns the precise padding tag; there is no permissive +`parseBase32`. `Data.Either.isRight . parseBase32Padded` provides a Boolean check +for padded input when needed. Prefer retaining the successful parsed value: + +```haskell +case B32.parseBase32Padded wire of + Left err -> handleError err + Right encoded -> consumeBytes (B32.decodeBase32 encoded) +``` + +Parsers return the original encoded representation, including case, padding, +and lazy chunk structure. Unlike the old shape predicates, they perform full +validation. The decoders' existing lowercase acceptance is preserved; encoders +produce uppercase. Inputs with nonzero unused bits, such as `MZ======`, are now +rejected instead of silently decoding as `f`. + +## Text decoding and binary payloads + +The wrapper establishes Base32 syntax, not the decoded payload's character +encoding. `parseBase32Padded (Text.pack "74======")` succeeds, since it encodes +byte `0xff`. +Checked Text decoding now reports invalid UTF-8 as `Left`, including short and +lazy Text. Typed Text decoding requires valid UTF-8 and fails otherwise. Use +ByteString decoding for binary data, or a `decode*With` function for explicit +character conversion. + +## Build and compatibility + +`Data.ByteString.Base32.Internal` is removed. Import codec entry points from +`Data.ByteString.Base32.Internal.Head` and `validateLastNPads` from +`Data.ByteString.Base32.Internal.Utils`. + +The compiler range is GHC 9.6–9.14. Dependencies include `primitive` for direct +short byte-array codecs. SIMD is optional and remains disabled unless selected +with `-fsimd`; both modes use identical validation rules. The source archive +contains the bundled C sources, headers, tests, and this migration guide. + +Update downstream libraries, including `base32-lens`, before widening their +bounds to accept 1.0. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,25 +3,99 @@ ![Build Status](https://github.com/emilypi/base32/workflows/ci/badge.svg) [![Hackage](https://img.shields.io/hackage/v/base32.svg)](https://hackage.haskell.org/package/base32) -Padded and unpadded base32 and base32hex encoding and decoding for `Text` and `ByteString` values. +RFC 4648 standard and extended-hex Base32 encoding, with padded and unpadded +variants for strict, lazy, and short `ByteString` and `Text`. -For the companion optics and pattern synonyms, see [base32-lens](https://hackage.haskell.org/package/base32-lens). +```haskell +import Data.Base32.Types +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Base32 as B32 -### Summary +encoded = B32.encodeBase32' (BS.pack "Sun") +-- encoded :: Base32 'StdPadded ByteString +-- extractBase32 encoded == BS.pack "KN2W4===" +-- B32.decodeBase32 encoded == BS.pack "Sun" -The following types are supported for both padded and unpadded std and extended hex alphabets: +parsed = B32.parseBase32Unpadded (BS.pack "KN2W4") +-- Right "KN2W4"; the original encoded representation is retained -- `Data.ByteString` -- `Data.ByteString.Lazy` -- `Data.ByteString.Short` -- `Data.Text` -- `Data.Text.Lazy` -- `Data.Text.Short` +raw = B32.decodeBase32Untyped (BS.pack "KN2W4") +-- Right "Sun" +``` -Additionally this library has +Use `.Hex` modules for the extended-hex alphabet. Values carry `'StdPadded`, +`'StdUnpadded`, `'HexPadded`, or `'HexUnpadded`, preventing accidental mixing of +alphabets or padding-specific APIs. See +[MIGRATION-1.0.md](MIGRATION-1.0.md) for the changes from 0.4. -- Better performance than `memory` for encode and decode 3-4x. -- Optics for handling more complex structures with Base32 representations via the `base32-lens` package -- Checks for both validity and correctness of Base32 and Base32hex encodings +## Validation -There are no dependencies aside from those bundled with GHC, `text-short`. +`parseBase32Padded` and `parseBase32Unpadded` establish the corresponding padding +tag. Both check the alphabet, input length, padding placement, and zero unused +trailing bits. +They accept upper- and lowercase letters, preserve the original case and +representation, and accept empty input. Whitespace is rejected. + +Typed decoders use dedicated unchecked loops: provenance establishes validity, +so decoding does not repeat alphabet, length, padding, or canonical-bit checks. +`decodeBase32` uses the `StdAlphabet` or `HexAlphabet` constraint to accept both +padding forms of its alphabet. `decodeBase32Padded` and `decodeBase32Unpadded` +require their exact tags; calling them with the wrong padding form is a type error. + +The wrapper identifies the alphabet; it does not prove that decoded bytes form UTF-8. +Checked Text decoders return `Left` for invalid UTF-8; `decodeBase32With` and +its variants let you choose a character conversion. For arbitrary binary +payloads, use ByteString decoders. + +`assertBase32`, record updates, and the mapping instances +can bypass validation. Typed decoding requires a truthful encoded value and, +for Text, valid UTF-8 payload bytes. Use parsers and checked decoders for +external input. + +Lazy encoding and typed decoding preserve streaming through rechunking. +Checked lazy decoding and parsing validate a complete finite input. + +## Optional SIMD + +```sh +cabal build -fsimd +cabal test -fsimd +``` + +The `simd` flag defaults to **off**. It enables bundled NEON kernels on AArch64 +and runtime-dispatched SSSE3/AVX2 kernels on x86-64, with scalar fallback on +other targets. Small inputs and final quanta use Haskell scalar code. No +external native library is required. + +Strict and short values use SIMD directly. Short codecs use byte arrays without +pinning; typed ShortText additionally converts the decoded UTF-8 payload. Lazy +variants reach the same kernels through their strict chunks or checked input. + +## Development + +```sh +cabal test -f-simd +cabal test -fsimd --ghc-options='-fcheck-prim-bounds -fno-ignore-asserts' +cabal exec -- sh test/typecheck.sh +cabal haddock -fsimd +cabal check +``` + +CI tests both flag configurations across GHC 9.6–9.14, builds from the source +archive, and runs native sanitizer and guard-page tests on x86-64 and ARM64. + +Compare optimized scalar and SIMD benchmark builds separately: + +```sh +cabal bench -f-simd --builddir=dist-scalar -O2 --benchmark-options='--csv scalar.csv' +cabal bench -fsimd --builddir=dist-simd -O2 --benchmark-options='--csv simd.csv' +``` + +Benchmark names identify the selected flag configuration. Both builds measure +the same deterministic inputs, with setup excluded from timing. The suite covers +strict and short codecs, both alphabets and padding forms, encoding, typed and +untyped decoding, parsing, sizes around dispatch thresholds, large buffers, and +sliced strict inputs. + +The companion [base32-lens](https://hackage.haskell.org/package/base32-lens) +package needs an update for the 1.0 API before it can be used with this release. diff --git a/base32.cabal b/base32.cabal --- a/base32.cabal +++ b/base32.cabal @@ -1,10 +1,11 @@ cabal-version: 3.0 name: base32 -version: 0.4 +version: 1.0 synopsis: Fast RFC 4648-compliant Base32 encoding description: RFC 4648-compliant Base32 encodings and decodings. - This library provides performant encoding and decoding primitives, as well as support for textual values. + This library provides performant encoding and decoding primitives, + as well as support for textual values. homepage: https://github.com/emilypi/base32 bug-reports: https://github.com/emilypi/base32/issues @@ -12,25 +13,36 @@ license-file: LICENSE author: Emily Pillmore maintainer: emilypi@cohomolo.gy -copyright: (c) 2020-2023 Emily Pillmore +copyright: (c) 2020-2026 Emily Pillmore category: Data build-type: Simple -extra-source-files: +extra-doc-files: CHANGELOG.md README.md + MIGRATION-1.0.md tested-with: - GHC ==9.0.2 || ==9.2.8 || ==9.4.7 || ==9.6.3 || ==9.8.1 + GHC ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.4 || ==9.14.1 +extra-source-files: + cbits/base32_simd.h + test/simd-native.c + test/typecheck.sh + +flag simd + description: Enable bundled SIMD kernels with portable scalar fallback + default: False + manual: True + source-repository head type: git location: https://github.com/emilypi/base32.git library exposed-modules: + Data.Base32.Types Data.ByteString.Base32 Data.ByteString.Base32.Hex - Data.ByteString.Base32.Internal Data.ByteString.Lazy.Base32 Data.ByteString.Lazy.Base32.Hex Data.ByteString.Short.Base32 @@ -43,37 +55,47 @@ Data.Text.Short.Encoding.Base32 Data.Text.Short.Encoding.Base32.Hex - other-modules: + Data.ByteString.Base32.Internal.Short Data.ByteString.Base32.Internal.Head Data.ByteString.Base32.Internal.Loop Data.ByteString.Base32.Internal.Tables Data.ByteString.Base32.Internal.Tail Data.ByteString.Base32.Internal.Utils + if flag(simd) + exposed-modules: Data.ByteString.Base32.Internal.SIMD + cpp-options: -DBASE32_SIMD + c-sources: cbits/base32_simd.c + include-dirs: cbits + cc-options: -O2 -std=c99 + build-depends: - base >=4.15 && <4.20 - , bytestring ^>=0.11 + base >=4.18 && <4.23 + , bytestring >=0.11 && <0.13 , deepseq >=1.4.4.0 && <1.6 - , text >=2.0 && <2.2 + , primitive >=0.6 && <0.10 + , text >=2.0 && <2.3 , text-short ^>=0.1 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall -test-suite tasty +test-suite base32-tests default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test other-modules: Internal + Regression main-is: Main.hs + ghc-options: -Wall -threaded -rtsopts build-depends: - base >=4.15 && <4.20 + base >=4.18 && <4.23 , base32 - , bytestring ^>=0.11 + , bytestring >=0.11 && <0.13 + , deepseq , memory , QuickCheck - , random-bytestring , tasty , tasty-hunit , tasty-quickcheck @@ -86,11 +108,15 @@ hs-source-dirs: benchmarks main-is: Base32Bench.hs build-depends: - base >=4.15 && <4.20 + base >=4.18 && <4.23 , base32 - , bytestring ^>=0.11 + , bytestring >=0.11 && <0.13 , criterion , deepseq - , memory - , random-bytestring , text >=2.0 + , text-short + + if flag(simd) + cpp-options: -DBASE32_SIMD + + ghc-options: -Wall -rtsopts diff --git a/benchmarks/Base32Bench.hs b/benchmarks/Base32Bench.hs --- a/benchmarks/Base32Bench.hs +++ b/benchmarks/Base32Bench.hs @@ -1,96 +1,129 @@ -{-# LANGUAGE PackageImports #-} -module Main -( main -)where - +{-# LANGUAGE CPP #-} +-- | +-- Module : Main +-- Copyright : (c) 2020-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- Build once with -f-simd and once with -fsimd to compare the same cases. +-- Sizes describe raw input bytes; sliced inputs also apply to decode buffers. +-- +module Main (main) where -import Criterion import Criterion.Main - -import "memory" Data.ByteArray.Encoding as Mem -import Data.ByteString -import "base32" Data.ByteString.Base32 as B32 -import Data.ByteString.Random (random) - +import Data.Base32.Types (assertBase32, extractBase32) +import qualified Data.ByteString as B +import qualified Data.ByteString.Base32 as B32 +import qualified Data.ByteString.Base32.Hex as H32 +import qualified Data.ByteString.Short as S +import qualified Data.ByteString.Short.Base32 as S32 +import qualified Data.ByteString.Short.Base32.Hex as SH32 +import qualified Data.Text.Short as T +import qualified Data.Text.Short.Encoding.Base32 as T32 main :: IO () -main = - defaultMain - [ env bs $ \ ~(bs25,bs100,bs1k,bs10k,bs100k,bs1mm) -> - bgroup "encode" - [ bgroup "25" - [ bench "memory" $ whnf ctob bs25 - , bench "base32" $ whnf B32.encodeBase32' bs25 - ] - , bgroup "100" - [ bench "memory" $ whnf ctob bs100 - , bench "base32" $ whnf B32.encodeBase32' bs100 - ] - , bgroup "1k" - [ bench "memory" $ whnf ctob bs1k - , bench "base32" $ whnf B32.encodeBase32' bs1k - ] - , bgroup "10k" - [ bench "memory" $ whnf ctob bs10k - , bench "base32" $ whnf B32.encodeBase32' bs10k - ] - , bgroup "100k" - [ bench "memory" $ whnf ctob bs100k - , bench "base32" $ whnf B32.encodeBase32' bs100k - ] - , bgroup "1mm" - [ bench "memory" $ whnf ctob bs1mm - , bench "base32" $ whnf B32.encodeBase32' bs1mm - ] - ] - , env bs' $ \ ~(bs25,bs100,bs1k,bs10k,bs100k,bs1mm) -> - bgroup "decode" - [ bgroup "25" - [ bench "memory" $ whnf btoc bs25 - , bench "base32" $ whnf B32.decodeBase32 bs25 - ] - , bgroup "100" - [ bench "memory" $ whnf btoc bs100 - , bench "base32" $ whnf B32.decodeBase32 bs100 - ] - , bgroup "1k" - [ bench "memory" $ whnf btoc bs1k - , bench "base32" $ whnf B32.decodeBase32 bs1k - ] - , bgroup "10k" - [ bench "memory" $ whnf btoc bs10k - , bench "base32" $ whnf B32.decodeBase32 bs10k - ] - , bgroup "100k" - [ bench "memory" $ whnf btoc bs100k - , bench "base32" $ whnf B32.decodeBase32 bs100k - ] - , bgroup "1mm" - [ bench "memory" $ whnf btoc bs1mm - , bench "base32" $ whnf B32.decodeBase32 bs1mm - ] +main = defaultMain + [ bgroup implementation + [ bgroup (show size) + [ bgroup "strict" + [ env (inputs id size offset) $ + \ ~(raw, std, stdUnpadded, hex, hexUnpadded) -> + bgroup ("offset-" ++ show offset) + [ bgroup "standard-padded" + [ bench "encode" $ nf B32.encodeBase32' raw + , bench "decode-typed" $ + nf (B32.decodeBase32Padded . assertBase32) std + , bench "decode-untyped" $ nf B32.decodeBase32PaddedUntyped std + , bench "parse" $ nf B32.parseBase32Padded std + ] + , bgroup "standard-unpadded" + [ bench "encode" $ nf B32.encodeBase32Unpadded' raw + , bench "decode-typed" $ + nf (B32.decodeBase32Unpadded . assertBase32) stdUnpadded + , bench "decode-untyped" $ + nf B32.decodeBase32UnpaddedUntyped stdUnpadded + , bench "parse" $ nf B32.parseBase32Unpadded stdUnpadded + ] + , bgroup "hex-padded" + [ bench "encode" $ nf H32.encodeBase32' raw + , bench "decode-typed" $ + nf (H32.decodeBase32Padded . assertBase32) hex + , bench "decode-untyped" $ nf H32.decodeBase32PaddedUntyped hex + , bench "parse" $ nf H32.parseBase32Padded hex + ] + , bgroup "hex-unpadded" + [ bench "encode" $ nf H32.encodeBase32Unpadded' raw + , bench "decode-typed" $ + nf (H32.decodeBase32Unpadded . assertBase32) hexUnpadded + , bench "decode-untyped" $ + nf H32.decodeBase32UnpaddedUntyped hexUnpadded + , bench "parse" $ nf H32.parseBase32Unpadded hexUnpadded + ] + ] + | offset <- [0, 1] + ] + , env (inputs S.toShort size 0) $ + \ ~(raw, std, stdUnpadded, hex, hexUnpadded) -> + bgroup "short" + [ bgroup "standard-padded" + [ bench "encode" $ nf S32.encodeBase32' raw + , bench "decode-typed" $ + nf (S32.decodeBase32Padded . assertBase32) std + , bench "decode-untyped" $ nf S32.decodeBase32PaddedUntyped std + , bench "parse" $ nf S32.parseBase32Padded std + ] + , bgroup "standard-unpadded" + [ bench "encode" $ nf S32.encodeBase32Unpadded' raw + , bench "decode-typed" $ + nf (S32.decodeBase32Unpadded . assertBase32) stdUnpadded + , bench "decode-untyped" $ + nf S32.decodeBase32UnpaddedUntyped stdUnpadded + , bench "parse" $ nf S32.parseBase32Unpadded stdUnpadded + ] + , bgroup "hex-padded" + [ bench "encode" $ nf SH32.encodeBase32' raw + , bench "decode-typed" $ + nf (SH32.decodeBase32Padded . assertBase32) hex + , bench "decode-untyped" $ nf SH32.decodeBase32PaddedUntyped hex + , bench "parse" $ nf SH32.parseBase32Padded hex + ] + , bgroup "hex-unpadded" + [ bench "encode" $ nf SH32.encodeBase32Unpadded' raw + , bench "decode-typed" $ + nf (SH32.decodeBase32Unpadded . assertBase32) hexUnpadded + , bench "decode-untyped" $ + nf SH32.decodeBase32UnpaddedUntyped hexUnpadded + , bench "parse" $ nf SH32.parseBase32Unpadded hexUnpadded + ] + ] + ] + | size <- [25, 39, 40, 41, 79, 80, 81, 4096, 1048576] ] - ] - where - ctob :: ByteString -> ByteString - ctob = Mem.convertToBase Mem.Base32 - btoc :: ByteString -> Either String ByteString - btoc = Mem.convertFromBase Mem.Base32 + , env (pure (T.pack "Base32 benchmark λ")) $ \shortText -> + bgroup implementation [bench "short-text" $ nf T32.encodeBase32 shortText] + ] - bs = do - a <- random 25 - b <- random 100 - c <- random 1000 - d <- random 10000 - e <- random 100000 - f <- random 1000000 - return (a,b,c,d,e,f) +implementation :: String +#ifdef BASE32_SIMD +implementation = "simd" +#else +implementation = "scalar" +#endif - bs' = do - a <- B32.encodeBase32' <$> random 25 - b <- B32.encodeBase32' <$> random 100 - c <- B32.encodeBase32' <$> random 1000 - d <- B32.encodeBase32' <$> random 10000 - e <- B32.encodeBase32' <$> random 100000 - f <- B32.encodeBase32' <$> random 1000000 - return (a,b,c,d,e,f) +-- Criterion forces this environment before timing. Both builds use the same +-- deterministic data; encoding, slicing, and conversion are excluded from timing. +inputs :: (B.ByteString -> a) -> Int -> Int -> IO (a, a, a, a, a) +inputs convert size offset = pure + ( prepared raw + , prepared (extractBase32 (B32.encodeBase32' raw)) + , prepared (extractBase32 (B32.encodeBase32Unpadded' raw)) + , prepared (extractBase32 (H32.encodeBase32' raw)) + , prepared (extractBase32 (H32.encodeBase32Unpadded' raw)) + ) + where + raw = B.pack (take size (cycle [0 .. 255])) + prepared bytes = convert . B.take (B.length bytes) . B.drop offset $ + B.replicate offset 0xe5 <> bytes <> B.replicate 32 0xff diff --git a/cbits/base32_simd.c b/cbits/base32_simd.c new file mode 100644 --- /dev/null +++ b/cbits/base32_simd.c @@ -0,0 +1,466 @@ +/* Copyright (c) 2026 Emily Pillmore. BSD-3-Clause; see LICENSE. */ +#include "base32_simd.h" +#include + +/* Each lane encodes ten bytes or decodes sixteen. All loads/stores are + * bounded; invalid decode blocks are not committed. Target attributes keep + * optional x86 instructions out of the baseline dispatcher. Force macros + * only cap backend selection; they never bypass hardware/OS checks. */ +#if !defined(HS_BASE32_SIMD_FORCE_SCALAR) +#if defined(__aarch64__) && defined(__ARM_NEON) +#define HS_BASE32_NEON +#include +#elif defined(__x86_64__) && (defined(__GNUC__) || defined(__clang__)) +#define HS_BASE32_X86 +#include +#endif +#endif + +#if defined(HS_BASE32_NEON) || defined(HS_BASE32_X86) +static const uint8_t enc_a[16] = { + 0, 0, 1, 1, 2, 3, 3, 4, 5, 5, 6, 6, 7, 8, 8, 9 +}; +static const uint8_t enc_b[16] = { + 255, 1, 255, 2, 3, 255, 4, 255, 255, 6, 255, 7, 8, 255, 9, 255 +}; +static const uint8_t dec_a[16] = { + 0, 1, 3, 4, 6, 8, 9, 11, 12, 14, 255, 255, 255, 255, 255, 255 +}; +static const uint8_t dec_b[16] = { + 1, 2, 4, 5, 7, 9, 10, 12, 13, 15, 255, 255, 255, 255, 255, 255 +}; +static const uint8_t dec_c[16] = { + 255, 3, 255, 6, 255, 255, 11, 255, 14, 255, 255, 255, 255, 255, 255, 255 +}; +#endif + +#if defined(HS_BASE32_NEON) + +static uint8x16_t load10(const uint8_t *src) +{ + uint8_t bytes[16] = {0}; + memcpy(bytes, src, 10); + return vld1q_u8(bytes); +} + +static void store10(uint8_t *dst, uint8x16_t value) +{ + uint8_t bytes[16]; + vst1q_u8(bytes, value); + memcpy(dst, bytes, 10); +} + +static size_t neon_encode(const uint8_t *src, size_t len, uint8_t *dst, int hex) +{ + static const int8_t shifts_a[16] = { + -3,2,-1,4,1,-2,3,0, -3,2,-1,4,1,-2,3,0 + }; + static const int8_t shifts_b[16] = { + 0,-6,0,-4,-7,0,-5,0, 0,-6,0,-4,-7,0,-5,0 + }; + size_t done = 0; + while (len - done >= 10) { + const uint8x16_t input = load10(src + done); + const uint8x16_t a = vqtbl1q_u8(input, vld1q_u8(enc_a)); + const uint8x16_t b = vqtbl1q_u8(input, vld1q_u8(enc_b)); + const uint8x16_t index = vandq_u8(vdupq_n_u8(31), vorrq_u8( + vshlq_u8(a, vld1q_s8(shifts_a)), vshlq_u8(b, vld1q_s8(shifts_b)))); + const uint8x16_t high = vcgtq_u8(index, vdupq_n_u8(hex ? 9 : 25)); + const uint8x16_t offset = vbslq_u8(high, + vdupq_n_u8(hex ? 55 : 24), vdupq_n_u8(hex ? 48 : 65)); + vst1q_u8(dst, vaddq_u8(index, offset)); + dst += 16; + done += 10; + } + return done; +} + +static size_t neon_decode(const uint8_t *src, size_t len, uint8_t *dst, + int hex, int checked) +{ + static const int8_t shifts_a[16] = {3,6,4,7,5,3,6,4,7,5,0,0,0,0,0,0}; + static const int8_t shifts_b[16] = {-2,1,-1,2,0,-2,1,-1,2,0,0,0,0,0,0,0}; + static const int8_t shifts_c[16] = {0,-4,0,-3,0,0,-4,0,-3,0,0,0,0,0,0,0}; + size_t done = 0; + while (len - done >= 16) { + const uint8x16_t input = vld1q_u8(src + done); + const uint8x16_t upper = vandq_u8(input, vdupq_n_u8(0xdf)); + const uint8x16_t letter = vsubq_u8(upper, vdupq_n_u8('A')); + const uint8x16_t digit = vsubq_u8(input, vdupq_n_u8(hex ? '0' : '2')); + const uint8x16_t is_letter = vcleq_u8(letter, vdupq_n_u8(hex ? 21 : 25)); + const uint8x16_t is_digit = vcleq_u8(digit, vdupq_n_u8(hex ? 9 : 5)); + if (checked && vminvq_u8(vorrq_u8(is_letter, is_digit)) == 0) { + break; + } + const uint8x16_t value = vbslq_u8(is_letter, + vaddq_u8(letter, vdupq_n_u8(hex ? 10 : 0)), + vaddq_u8(digit, vdupq_n_u8(hex ? 0 : 26))); + const uint8x16_t a = vqtbl1q_u8(value, vld1q_u8(dec_a)); + const uint8x16_t b = vqtbl1q_u8(value, vld1q_u8(dec_b)); + const uint8x16_t c = vqtbl1q_u8(value, vld1q_u8(dec_c)); + store10(dst, vorrq_u8(vshlq_u8(a, vld1q_s8(shifts_a)), + vorrq_u8(vshlq_u8(b, vld1q_s8(shifts_b)), + vshlq_u8(c, vld1q_s8(shifts_c))))); + dst += 10; + done += 16; + } + return done; +} +#elif defined(HS_BASE32_X86) + +__attribute__((target("ssse3"))) +static __m128i ssse3_mask(const uint8_t *bytes) +{ + const __m128i value = _mm_loadu_si128((const __m128i *)bytes); + return value; +} + +__attribute__((target("ssse3"))) +static size_t ssse3_encode(const uint8_t *src, size_t len, uint8_t *dst, int hex) +{ + size_t done = 0; + while (len - done >= 10) { + uint8_t bytes[16] = {0}; + memcpy(bytes + 0, src + done + 0, 10); + const __m128i value = _mm_loadu_si128((const __m128i *)bytes); + __m128i output = _mm_setzero_si128(); + const __m128i a = _mm_shuffle_epi8(value, ssse3_mask(enc_a)); + output = _mm_or_si128(output, _mm_and_si128( + _mm_srli_epi16(a, 3), + ssse3_mask((const uint8_t[16]){31,0,0,0,0,0,0,0,31,0,0,0,0,0,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_srli_epi16(a, 2), + ssse3_mask((const uint8_t[16]){0,0,0,0,0,31,0,0,0,0,0,0,0,31,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_srli_epi16(a, 1), + ssse3_mask((const uint8_t[16]){0,0,31,0,0,0,0,0,0,0,31,0,0,0,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + a, + ssse3_mask((const uint8_t[16]){0,0,0,0,0,0,0,31,0,0,0,0,0,0,0,31}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_slli_epi16(a, 1), + ssse3_mask((const uint8_t[16]){0,0,0,0,30,0,0,0,0,0,0,0,30,0,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_slli_epi16(a, 2), + ssse3_mask((const uint8_t[16]){0,28,0,0,0,0,0,0,0,28,0,0,0,0,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_slli_epi16(a, 3), + ssse3_mask((const uint8_t[16]){0,0,0,0,0,0,24,0,0,0,0,0,0,0,24,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_slli_epi16(a, 4), + ssse3_mask((const uint8_t[16]){0,0,0,16,0,0,0,0,0,0,0,16,0,0,0,0}))); + const __m128i b = _mm_shuffle_epi8(value, ssse3_mask(enc_b)); + output = _mm_or_si128(output, _mm_and_si128( + _mm_srli_epi16(b, 7), + ssse3_mask((const uint8_t[16]){0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_srli_epi16(b, 6), + ssse3_mask((const uint8_t[16]){0,3,0,0,0,0,0,0,0,3,0,0,0,0,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_srli_epi16(b, 5), + ssse3_mask((const uint8_t[16]){0,0,0,0,0,0,7,0,0,0,0,0,0,0,7,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_srli_epi16(b, 4), + ssse3_mask((const uint8_t[16]){0,0,0,15,0,0,0,0,0,0,0,15,0,0,0,0}))); + const __m128i high = _mm_cmpgt_epi8(output, _mm_set1_epi8(hex ? 9 : 25)); + const __m128i offset = _mm_or_si128( + _mm_and_si128(high, _mm_set1_epi8(hex ? 55 : 24)), + _mm_andnot_si128(high, _mm_set1_epi8(hex ? 48 : 65))); + _mm_storeu_si128((__m128i *)dst, _mm_add_epi8(output, offset)); + dst += 16; + done += 10; + } + return done; +} + +__attribute__((target("ssse3"))) +static size_t ssse3_decode(const uint8_t *src, size_t len, uint8_t *dst, + int hex, int checked) +{ + size_t done = 0; + while (len - done >= 16) { + const __m128i input = _mm_loadu_si128((const __m128i *)(src + done)); + const __m128i upper = _mm_and_si128(input, _mm_set1_epi8((char)0xdf)); + const __m128i letters = _mm_and_si128( + _mm_cmpgt_epi8(upper, _mm_set1_epi8('A' - 1)), + _mm_cmpgt_epi8(_mm_set1_epi8(hex ? 'V' + 1 : 'Z' + 1), upper)); + const __m128i digits = _mm_and_si128( + _mm_cmpgt_epi8(input, _mm_set1_epi8(hex ? '0' - 1 : '2' - 1)), + _mm_cmpgt_epi8(_mm_set1_epi8(hex ? '9' + 1 : '7' + 1), input)); + if (checked && (unsigned)_mm_movemask_epi8(_mm_or_si128(letters, digits)) + != 0xffffU) { + break; + } + const __m128i value = _mm_or_si128( + _mm_and_si128(letters, + _mm_add_epi8(upper, _mm_set1_epi8(hex ? 10 - 'A' : -'A'))), + _mm_and_si128(digits, + _mm_add_epi8(input, _mm_set1_epi8(hex ? -'0' : 26 - '2')))); + __m128i output = _mm_setzero_si128(); + const __m128i a = _mm_shuffle_epi8(value, ssse3_mask(dec_a)); + output = _mm_or_si128(output, _mm_and_si128( + _mm_slli_epi16(a, 3), + ssse3_mask((const uint8_t[16]){248,0,0,0,0,248,0,0,0,0,0,0,0,0,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_slli_epi16(a, 4), + ssse3_mask((const uint8_t[16]){0,0,240,0,0,0,0,240,0,0,0,0,0,0,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_slli_epi16(a, 5), + ssse3_mask((const uint8_t[16]){0,0,0,0,224,0,0,0,0,224,0,0,0,0,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_slli_epi16(a, 6), + ssse3_mask((const uint8_t[16]){0,192,0,0,0,0,192,0,0,0,0,0,0,0,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_slli_epi16(a, 7), + ssse3_mask((const uint8_t[16]){0,0,0,128,0,0,0,0,128,0,0,0,0,0,0,0}))); + const __m128i b = _mm_shuffle_epi8(value, ssse3_mask(dec_b)); + output = _mm_or_si128(output, _mm_and_si128( + _mm_srli_epi16(b, 2), + ssse3_mask((const uint8_t[16]){7,0,0,0,0,7,0,0,0,0,0,0,0,0,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_srli_epi16(b, 1), + ssse3_mask((const uint8_t[16]){0,0,15,0,0,0,0,15,0,0,0,0,0,0,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + b, + ssse3_mask((const uint8_t[16]){0,0,0,0,31,0,0,0,0,31,0,0,0,0,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_slli_epi16(b, 1), + ssse3_mask((const uint8_t[16]){0,62,0,0,0,0,62,0,0,0,0,0,0,0,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_slli_epi16(b, 2), + ssse3_mask((const uint8_t[16]){0,0,0,124,0,0,0,0,124,0,0,0,0,0,0,0}))); + const __m128i c = _mm_shuffle_epi8(value, ssse3_mask(dec_c)); + output = _mm_or_si128(output, _mm_and_si128( + _mm_srli_epi16(c, 4), + ssse3_mask((const uint8_t[16]){0,15,0,0,0,0,15,0,0,0,0,0,0,0,0,0}))); + output = _mm_or_si128(output, _mm_and_si128( + _mm_srli_epi16(c, 3), + ssse3_mask((const uint8_t[16]){0,0,0,7,0,0,0,0,7,0,0,0,0,0,0,0}))); + uint8_t bytes[16]; + _mm_storeu_si128((__m128i *)bytes, output); + memcpy(dst + 0, bytes + 0, 10); + dst += 10; + done += 16; + } + return done; +} + +__attribute__((target("avx2"))) +static __m256i avx2_mask(const uint8_t *bytes) +{ + const __m128i value = _mm_loadu_si128((const __m128i *)bytes); + return _mm256_broadcastsi128_si256(value); +} + +__attribute__((target("avx2"))) +static size_t avx2_encode(const uint8_t *src, size_t len, uint8_t *dst, int hex) +{ + size_t done = 0; + while (len - done >= 20) { + uint8_t bytes[32] = {0}; + memcpy(bytes + 0, src + done + 0, 10); + memcpy(bytes + 16, src + done + 10, 10); + const __m256i value = _mm256_loadu_si256((const __m256i *)bytes); + __m256i output = _mm256_setzero_si256(); + const __m256i a = _mm256_shuffle_epi8(value, avx2_mask(enc_a)); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_srli_epi16(a, 3), + avx2_mask((const uint8_t[16]){31,0,0,0,0,0,0,0,31,0,0,0,0,0,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_srli_epi16(a, 2), + avx2_mask((const uint8_t[16]){0,0,0,0,0,31,0,0,0,0,0,0,0,31,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_srli_epi16(a, 1), + avx2_mask((const uint8_t[16]){0,0,31,0,0,0,0,0,0,0,31,0,0,0,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + a, + avx2_mask((const uint8_t[16]){0,0,0,0,0,0,0,31,0,0,0,0,0,0,0,31}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_slli_epi16(a, 1), + avx2_mask((const uint8_t[16]){0,0,0,0,30,0,0,0,0,0,0,0,30,0,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_slli_epi16(a, 2), + avx2_mask((const uint8_t[16]){0,28,0,0,0,0,0,0,0,28,0,0,0,0,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_slli_epi16(a, 3), + avx2_mask((const uint8_t[16]){0,0,0,0,0,0,24,0,0,0,0,0,0,0,24,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_slli_epi16(a, 4), + avx2_mask((const uint8_t[16]){0,0,0,16,0,0,0,0,0,0,0,16,0,0,0,0}))); + const __m256i b = _mm256_shuffle_epi8(value, avx2_mask(enc_b)); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_srli_epi16(b, 7), + avx2_mask((const uint8_t[16]){0,0,0,0,1,0,0,0,0,0,0,0,1,0,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_srli_epi16(b, 6), + avx2_mask((const uint8_t[16]){0,3,0,0,0,0,0,0,0,3,0,0,0,0,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_srli_epi16(b, 5), + avx2_mask((const uint8_t[16]){0,0,0,0,0,0,7,0,0,0,0,0,0,0,7,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_srli_epi16(b, 4), + avx2_mask((const uint8_t[16]){0,0,0,15,0,0,0,0,0,0,0,15,0,0,0,0}))); + const __m256i high = _mm256_cmpgt_epi8(output, _mm256_set1_epi8(hex ? 9 : 25)); + const __m256i offset = _mm256_or_si256( + _mm256_and_si256(high, _mm256_set1_epi8(hex ? 55 : 24)), + _mm256_andnot_si256(high, _mm256_set1_epi8(hex ? 48 : 65))); + _mm256_storeu_si256((__m256i *)dst, _mm256_add_epi8(output, offset)); + dst += 32; + done += 20; + } + return done; +} + +__attribute__((target("avx2"))) +static size_t avx2_decode(const uint8_t *src, size_t len, uint8_t *dst, + int hex, int checked) +{ + size_t done = 0; + while (len - done >= 32) { + const __m256i input = _mm256_loadu_si256((const __m256i *)(src + done)); + const __m256i upper = _mm256_and_si256(input, _mm256_set1_epi8((char)0xdf)); + const __m256i letters = _mm256_and_si256( + _mm256_cmpgt_epi8(upper, _mm256_set1_epi8('A' - 1)), + _mm256_cmpgt_epi8(_mm256_set1_epi8(hex ? 'V' + 1 : 'Z' + 1), upper)); + const __m256i digits = _mm256_and_si256( + _mm256_cmpgt_epi8(input, _mm256_set1_epi8(hex ? '0' - 1 : '2' - 1)), + _mm256_cmpgt_epi8(_mm256_set1_epi8(hex ? '9' + 1 : '7' + 1), input)); + if (checked && (unsigned)_mm256_movemask_epi8(_mm256_or_si256(letters, digits)) + != 0xffffffffU) { + break; + } + const __m256i value = _mm256_or_si256( + _mm256_and_si256(letters, + _mm256_add_epi8(upper, _mm256_set1_epi8(hex ? 10 - 'A' : -'A'))), + _mm256_and_si256(digits, + _mm256_add_epi8(input, _mm256_set1_epi8(hex ? -'0' : 26 - '2')))); + __m256i output = _mm256_setzero_si256(); + const __m256i a = _mm256_shuffle_epi8(value, avx2_mask(dec_a)); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_slli_epi16(a, 3), + avx2_mask((const uint8_t[16]){248,0,0,0,0,248,0,0,0,0,0,0,0,0,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_slli_epi16(a, 4), + avx2_mask((const uint8_t[16]){0,0,240,0,0,0,0,240,0,0,0,0,0,0,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_slli_epi16(a, 5), + avx2_mask((const uint8_t[16]){0,0,0,0,224,0,0,0,0,224,0,0,0,0,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_slli_epi16(a, 6), + avx2_mask((const uint8_t[16]){0,192,0,0,0,0,192,0,0,0,0,0,0,0,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_slli_epi16(a, 7), + avx2_mask((const uint8_t[16]){0,0,0,128,0,0,0,0,128,0,0,0,0,0,0,0}))); + const __m256i b = _mm256_shuffle_epi8(value, avx2_mask(dec_b)); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_srli_epi16(b, 2), + avx2_mask((const uint8_t[16]){7,0,0,0,0,7,0,0,0,0,0,0,0,0,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_srli_epi16(b, 1), + avx2_mask((const uint8_t[16]){0,0,15,0,0,0,0,15,0,0,0,0,0,0,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + b, + avx2_mask((const uint8_t[16]){0,0,0,0,31,0,0,0,0,31,0,0,0,0,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_slli_epi16(b, 1), + avx2_mask((const uint8_t[16]){0,62,0,0,0,0,62,0,0,0,0,0,0,0,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_slli_epi16(b, 2), + avx2_mask((const uint8_t[16]){0,0,0,124,0,0,0,0,124,0,0,0,0,0,0,0}))); + const __m256i c = _mm256_shuffle_epi8(value, avx2_mask(dec_c)); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_srli_epi16(c, 4), + avx2_mask((const uint8_t[16]){0,15,0,0,0,0,15,0,0,0,0,0,0,0,0,0}))); + output = _mm256_or_si256(output, _mm256_and_si256( + _mm256_srli_epi16(c, 3), + avx2_mask((const uint8_t[16]){0,0,0,7,0,0,0,0,7,0,0,0,0,0,0,0}))); + uint8_t bytes[32]; + _mm256_storeu_si256((__m256i *)bytes, output); + memcpy(dst + 0, bytes + 0, 10); + memcpy(dst + 10, bytes + 16, 10); + dst += 20; + done += 32; + } + return done; +} + +#endif + +int hs_base32_simd_backend(void) +{ +#if defined(HS_BASE32_NEON) + return 2; +#elif defined(HS_BASE32_X86) +#if !defined(HS_BASE32_SIMD_FORCE_SSSE3) + /* Compiler CPU queries include OS support for AVX register state. */ + if (__builtin_cpu_supports("avx2")) { + return 3; + } +#endif + return __builtin_cpu_supports("ssse3") ? 1 : 0; +#else + return 0; +#endif +} + +size_t hs_base32_simd_encode(const uint8_t *src, size_t len, uint8_t *dst, int hex) +{ +#if defined(HS_BASE32_NEON) + return neon_encode(src, len, dst, hex); +#elif defined(HS_BASE32_X86) + const int backend = hs_base32_simd_backend(); + if (backend == 3) { + return avx2_encode(src, len, dst, hex); + } + if (backend == 1) { + return ssse3_encode(src, len, dst, hex); + } +#endif + (void)src; + (void)len; + (void)dst; + (void)hex; + return 0; +} + +size_t hs_base32_simd_decode(const uint8_t *src, size_t len, uint8_t *dst, int hex) +{ +#if defined(HS_BASE32_NEON) + return neon_decode(src, len, dst, hex, 1); +#elif defined(HS_BASE32_X86) + const int backend = hs_base32_simd_backend(); + if (backend == 3) { + return avx2_decode(src, len, dst, hex, 1); + } + if (backend == 1) { + return ssse3_decode(src, len, dst, hex, 1); + } +#endif + (void)src; + (void)len; + (void)dst; + (void)hex; + return 0; +} + +/* Typed callers establish validity before entering these loops. */ +size_t hs_base32_simd_decode_typed(const uint8_t *src, size_t len, + uint8_t *dst, int hex) +{ +#if defined(HS_BASE32_NEON) + return neon_decode(src, len, dst, hex, 0); +#elif defined(HS_BASE32_X86) + const int backend = hs_base32_simd_backend(); + if (backend == 3) { + return avx2_decode(src, len, dst, hex, 0); + } + if (backend == 1) { + return ssse3_decode(src, len, dst, hex, 0); + } +#endif + (void)src; + (void)len; + (void)dst; + (void)hex; + return 0; +} diff --git a/cbits/base32_simd.h b/cbits/base32_simd.h new file mode 100644 --- /dev/null +++ b/cbits/base32_simd.h @@ -0,0 +1,15 @@ +/* Copyright (c) 2026 Emily Pillmore. BSD-3-Clause; see LICENSE. */ +#ifndef HS_BASE32_SIMD_H +#define HS_BASE32_SIMD_H +#include +#include +/* Backends: 0 scalar fallback, 1 SSSE3, 2 NEON, 3 AVX2. */ +int hs_base32_simd_backend(void); +/* Return consumed input bytes. No tail, padding, or invalid block is written. + * Source and destination must be distinct, nonoverlapping buffers; destination + * capacities are len/5*8 (encode) and len/8*5 (decode). hex is 0 or 1. */ +size_t hs_base32_simd_encode(const uint8_t *, size_t, uint8_t *, int hex); +size_t hs_base32_simd_decode(const uint8_t *, size_t, uint8_t *, int hex); +/* Known-valid symbols only, with trailing padding excluded. No validation. */ +size_t hs_base32_simd_decode_typed(const uint8_t *, size_t, uint8_t *, int hex); +#endif diff --git a/src/Data/Base32/Types.hs b/src/Data/Base32/Types.hs new file mode 100644 --- /dev/null +++ b/src/Data/Base32/Types.hs @@ -0,0 +1,113 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DerivingVia #-} +{-# LANGUAGE ExplicitForAll #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE RoleAnnotations #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} +{-# LANGUAGE Trustworthy #-} +-- | +-- Module : Data.Base32.Types +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- Encoded values tagged with their alphabet and padding policy. +-- +-- @since 1.0 +-- +module Data.Base32.Types + ( Alphabet (..) + , StdAlphabet + , HexAlphabet + , Base32 + , extractBase32 + , assertBase32 + ) where + +import Control.DeepSeq (NFData) +import Data.Functor.Identity (Identity (..)) +import Data.Kind (Constraint) +import GHC.TypeLits (ErrorMessage (..), TypeError) + +-- | The alphabets and padding forms from RFC 4648 sections 6 and 7. +-- +-- @since 1.0 +-- +data Alphabet = StdPadded | StdUnpadded | HexPadded | HexUnpadded + deriving + ( Eq -- ^ @since 1.0 + , Ord -- ^ @since 1.0 + , Show -- ^ @since 1.0 + ) + +-- | Padded and unpadded forms of the standard alphabet. +-- +-- @since 1.0 +-- +type family StdAlphabet (k :: Alphabet) :: Constraint where + StdAlphabet 'StdPadded = () + StdAlphabet 'StdUnpadded = () + StdAlphabet _ = TypeError + ( 'Text "Cannot prove base32 value is encoded using the standard alphabet. " + ':<>: 'Text "Use the standard encoders or padding-specific parsers." + ) + +-- | Padded and unpadded forms of the extended-hex alphabet. +-- +-- >>> let hex :: HexAlphabet k => Base32 k a -> a; hex = extractBase32 +-- >>> hex (assertBase32 @'HexPadded "ADQMS===") +-- "ADQMS===" +-- >>> hex (assertBase32 @'HexUnpadded "ADQMS") +-- "ADQMS" +-- +-- @since 1.0 +-- +type family HexAlphabet (k :: Alphabet) :: Constraint where + HexAlphabet 'HexPadded = () + HexAlphabet 'HexUnpadded = () + HexAlphabet _ = TypeError + ( 'Text "Cannot prove base32 value is encoded using the extended-hex alphabet. " + ':<>: 'Text "Use the hex encoders or padding-specific parsers." + ) + +-- | A value encoded with the given alphabet and padding. Encoding and parsing establish +-- this provenance. 'assertBase32', record updates, and the derived mapping +-- instances do not validate their results. +-- +-- @since 1.0 +-- +type role Base32 nominal representational +newtype Base32 (alphabet :: Alphabet) a = Base32 + { extractBase32 :: a + -- ^ Extract the encoded representation without decoding it. + -- + -- @since 1.0 + } + deriving + ( Eq -- ^ @since 1.0 + , Ord -- ^ @since 1.0 + , Show -- ^ @since 1.0 + , NFData -- ^ @since 1.0 + ) via a + deriving + ( Functor -- ^ @since 1.0 + , Applicative -- ^ @since 1.0 + , Monad -- ^ @since 1.0 + ) via Identity + +-- | Assert that a value is Base32-encoded. +-- +-- @since 1.0 +-- +assertBase32 :: forall alphabet a. a -> Base32 alphabet a +assertBase32 = Base32 +{-# INLINE assertBase32 #-} + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> :seti -XDataKinds -XTypeApplications -XTypeFamilies -XFlexibleContexts diff --git a/src/Data/ByteString/Base32.hs b/src/Data/ByteString/Base32.hs --- a/src/Data/ByteString/Base32.hs +++ b/src/Data/ByteString/Base32.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Trustworthy #-} -- | -- Module : Data.ByteString.Base32 --- Copyright : (c) 2019-2023 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -23,22 +24,27 @@ , encodeBase32Unpadded , encodeBase32Unpadded' -- * Decoding +, decodeBase32Untyped +, decodeBase32UnpaddedUntyped +, decodeBase32PaddedUntyped + -- * Validation , decodeBase32 -, decodeBase32Unpadded , decodeBase32Padded --- , decodeBase32Lenient - -- * Validation -, isBase32 -, isValidBase32 +, decodeBase32Unpadded +, parseBase32Padded +, parseBase32Unpadded ) where +import Data.Base32.Types + import qualified Data.ByteString as BS import Data.ByteString.Internal (ByteString(..)) -import Data.ByteString.Base32.Internal +import Data.ByteString.Base32.Internal.Head import Data.ByteString.Base32.Internal.Tables -import Data.Either (isRight) +import Data.ByteString.Base32.Internal.Utils (validateLastNPads) import Data.Text (Text) +import qualified Data.Text as Text import qualified Data.Text.Encoding as T import System.IO.Unsafe (unsafeDupablePerformIO) @@ -53,8 +59,10 @@ -- >>> encodeBase32 "Sun" -- "KN2W4===" -- -encodeBase32 :: ByteString -> Text -encodeBase32 = T.decodeUtf8 . encodeBase32' +-- @since 1.0 +-- +encodeBase32 :: ByteString -> Base32 'StdPadded Text +encodeBase32 = fmap T.decodeUtf8 . encodeBase32' {-# INLINE encodeBase32 #-} -- | Encode a 'ByteString' value as a Base32 'ByteString' value with padding. @@ -66,8 +74,10 @@ -- >>> encodeBase32' "Sun" -- "KN2W4===" -- -encodeBase32' :: ByteString -> ByteString -encodeBase32' = encodeBase32_ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# +-- @since 1.0 +-- +encodeBase32' :: ByteString -> Base32 'StdPadded ByteString +encodeBase32' = assertBase32 . encodeBase32_ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# {-# INLINE encodeBase32' #-} -- | Decode an arbitrarily padded Base32-encoded 'ByteString' value. If its length @@ -79,27 +89,33 @@ -- -- === __Examples__: -- --- >>> decodeBase32 "KN2W4===" +-- >>> decodeBase32Untyped "KN2W4===" -- Right "Sun" -- --- >>> decodeBase32 "KN2W4" +-- >>> decodeBase32Untyped "KN2W4" -- Right "Sun" -- --- >>> decodeBase32 "KN2W===" +-- >>> decodeBase32Untyped "KN2W===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32 :: ByteString -> Either Text ByteString -decodeBase32 bs@(BS _ !l) +-- @since 1.0 +-- +decodeBase32Untyped :: ByteString -> Either Text ByteString +decodeBase32Untyped bs@(BS _ !l) | l == 0 = Right bs | r == 0 = unsafeDupablePerformIO $ decodeBase32_ stdDecodeTable bs - | r == 2 = unsafeDupablePerformIO $ decodeBase32_ stdDecodeTable (BS.append bs "======") - | r == 4 = validateLastNPads 2 bs $ decodeBase32_ stdDecodeTable (BS.append bs "====") - | r == 5 = validateLastNPads 3 bs $ decodeBase32_ stdDecodeTable (BS.append bs "===") - | r == 7 = validateLastNPads 5 bs $ decodeBase32_ stdDecodeTable (BS.append bs "=") - | otherwise = Left "Base32-encoded bytestring has invalid size" + | r == 2 = unsafeDupablePerformIO $ + decodeBase32_ stdDecodeTable (BS.append bs (BS.replicate 6 0x3d)) + | r == 4 = validateLastNPads 2 bs $ + decodeBase32_ stdDecodeTable (BS.append bs (BS.replicate 4 0x3d)) + | r == 5 = validateLastNPads 3 bs $ + decodeBase32_ stdDecodeTable (BS.append bs (BS.replicate 3 0x3d)) + | r == 7 = validateLastNPads 5 bs $ + decodeBase32_ stdDecodeTable (BS.append bs (BS.replicate 1 0x3d)) + | otherwise = Left (Text.pack "Base32-encoded bytestring has invalid size") where !r = l `rem` 8 -{-# INLINE decodeBase32 #-} +{-# INLINE decodeBase32Untyped #-} -- | Encode a 'ByteString' value as a Base32 'Text' value without padding. -- @@ -110,8 +126,10 @@ -- >>> encodeBase32Unpadded "Sun" -- "KN2W4" -- -encodeBase32Unpadded :: ByteString -> Text -encodeBase32Unpadded = T.decodeUtf8 . encodeBase32Unpadded' +-- @since 1.0 +-- +encodeBase32Unpadded :: ByteString -> Base32 'StdUnpadded Text +encodeBase32Unpadded = fmap T.decodeUtf8 . encodeBase32Unpadded' {-# INLINE encodeBase32Unpadded #-} -- | Encode a 'ByteString' value as a Base32 'ByteString' value without padding. @@ -123,8 +141,11 @@ -- >>> encodeBase32Unpadded' "Sun" -- "KN2W4" -- -encodeBase32Unpadded' :: ByteString -> ByteString -encodeBase32Unpadded' = encodeBase32NoPad_ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# +-- @since 1.0 +-- +encodeBase32Unpadded' :: ByteString -> Base32 'StdUnpadded ByteString +encodeBase32Unpadded' = assertBase32 + . encodeBase32NoPad_ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# {-# INLINE encodeBase32Unpadded' #-} -- | Decode an unpadded Base32-encoded 'ByteString' value. @@ -133,24 +154,30 @@ -- -- === __Examples__: -- --- >>> decodeBase32Unpadded "KN2W4" +-- >>> decodeBase32UnpaddedUntyped "KN2W4" -- Right "Sun" -- --- >>> decodeBase32Unpadded "KN2W4===" +-- >>> decodeBase32UnpaddedUntyped "KN2W4===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32Unpadded :: ByteString -> Either Text ByteString -decodeBase32Unpadded bs@(BS _ !l) +-- @since 1.0 +-- +decodeBase32UnpaddedUntyped :: ByteString -> Either Text ByteString +decodeBase32UnpaddedUntyped bs@(BS _ !l) | l == 0 = Right bs | r == 0 = validateLastNPads 1 bs $ decodeBase32_ stdDecodeTable bs - | r == 2 = unsafeDupablePerformIO $ decodeBase32_ stdDecodeTable (BS.append bs "======") - | r == 4 = validateLastNPads 1 bs $ decodeBase32_ stdDecodeTable (BS.append bs "====") - | r == 5 = validateLastNPads 1 bs $ decodeBase32_ stdDecodeTable (BS.append bs "===") - | r == 7 = validateLastNPads 1 bs $ decodeBase32_ stdDecodeTable (BS.append bs "=") - | otherwise = Left "Base32-encoded bytestring has invalid size" + | r == 2 = unsafeDupablePerformIO $ + decodeBase32_ stdDecodeTable (BS.append bs (BS.replicate 6 0x3d)) + | r == 4 = validateLastNPads 1 bs $ + decodeBase32_ stdDecodeTable (BS.append bs (BS.replicate 4 0x3d)) + | r == 5 = validateLastNPads 1 bs $ + decodeBase32_ stdDecodeTable (BS.append bs (BS.replicate 3 0x3d)) + | r == 7 = validateLastNPads 1 bs $ + decodeBase32_ stdDecodeTable (BS.append bs (BS.replicate 1 0x3d)) + | otherwise = Left (Text.pack "Base32-encoded bytestring has invalid size") where !r = l `rem` 8 -{-# INLINE decodeBase32Unpadded #-} +{-# INLINE decodeBase32UnpaddedUntyped #-} -- | Decode a padded Base32-encoded 'ByteString' value. -- @@ -158,68 +185,109 @@ -- -- === __Examples__: -- --- >>> decodeBase32Padded "KN2W4===" +-- >>> decodeBase32PaddedUntyped "KN2W4===" -- Right "Sun" -- --- >>> decodeBase32Padded "KN2W4" +-- >>> decodeBase32PaddedUntyped "KN2W4" -- Left "Base32-encoded bytestring requires padding" -- -decodeBase32Padded :: ByteString -> Either Text ByteString -decodeBase32Padded bs@(BS _ !l) +-- @since 1.0 +-- +decodeBase32PaddedUntyped :: ByteString -> Either Text ByteString +decodeBase32PaddedUntyped bs@(BS _ !l) | l == 0 = Right bs - | r == 1 = Left "Base32-encoded bytestring has invalid size" - | r == 3 = Left "Base32-encoded bytestring has invalid size" - | r == 6 = Left "Base32-encoded bytestring has invalid size" - | r /= 0 = Left "Base32-encoded bytestring requires padding" + | r == 1 = Left (Text.pack "Base32-encoded bytestring has invalid size") + | r == 3 = Left (Text.pack "Base32-encoded bytestring has invalid size") + | r == 6 = Left (Text.pack "Base32-encoded bytestring has invalid size") + | r /= 0 = Left (Text.pack "Base32-encoded bytestring requires padding") | otherwise = unsafeDupablePerformIO $ decodeBase32_ stdDecodeTable bs where !r = l `rem` 8 -{-# INLINE decodeBase32Padded #-} +{-# INLINE decodeBase32PaddedUntyped #-} --- -- | Leniently decode an unpadded Base32-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. --- -- --- -- __Note:__ This is not RFC 4648-compliant. --- -- --- decodeBase32Lenient :: ByteString -> ByteString --- decodeBase32Lenient = decodeBase32Lenient_ decodeB32Table --- {-# INLINE decodeBase32Lenient #-} +-- | Decode a typed Base32-encoded 'ByteString' value. +-- +-- This function is padding-agnostic. +-- +-- >>> decodeBase32 (encodeBase32' "Sun") +-- "Sun" +-- +-- >>> decodeBase32 (encodeBase32Unpadded' "Sun") +-- "Sun" +-- +-- @since 1.0 +-- +decodeBase32 :: StdAlphabet k => Base32 k ByteString -> ByteString +decodeBase32 = decodeBase32Typed_ stdDecodeTable +{-# INLINE decodeBase32 #-} --- | Tell whether a 'ByteString' value is encoded in padded or unpadded Base32 format +-- | Decode a typed, padded Base32-encoded 'ByteString' value. -- --- === __Examples__: +-- >>> decodeBase32Padded (encodeBase32' "Sun") +-- "Sun" -- --- >>> isBase32 "KN2W4" --- True +-- @since 1.0 -- --- >>> isBase32 "KN2W4===" --- True +decodeBase32Padded :: Base32 'StdPadded ByteString -> ByteString +decodeBase32Padded = decodeBase32 +{-# INLINE decodeBase32Padded #-} + +-- | Parse and validate a base32-encoded value, assuming that it has padding. -- --- >>> isBase32 "KN2W4==" --- False +-- >>> parseBase32Padded "kn2w4===" +-- Right "kn2w4===" -- -isBase32 :: ByteString -> Bool -isBase32 bs = isValidBase32 bs && isRight (decodeBase32 bs) -{-# INLINE isBase32 #-} +-- >>> fmap decodeBase32Padded (parseBase32Padded "KN2W4===") +-- Right "Sun" +-- +-- >>> parseBase32Padded "" +-- Right "" +-- +-- >>> parseBase32Padded "KN2W4" +-- Left "Base32-encoded bytestring requires padding" +-- +-- @since 1.0 +-- +parseBase32Padded :: ByteString -> Either Text (Base32 'StdPadded ByteString) +parseBase32Padded value = assertBase32 value + <$ (decodeBase32PaddedUntyped) value +{-# INLINE parseBase32Padded #-} --- | Tell whether a 'ByteString' value is a valid Base32 format. +-- | Decode a typed, unpadded Base32-encoded value. -- --- This will not tell you whether or not this is a correct Base32 representation, --- only that it conforms to the correct shape (including padding/size etc.). --- To check whether it is a true Base32 encoded 'ByteString' value, use 'isBase32'. +-- >>> decodeBase32Unpadded (encodeBase32Unpadded' "Sun") +-- "Sun" -- --- === __Examples__: +-- @since 1.0 -- --- >>> isValidBase32 "KN2W4" --- True +decodeBase32Unpadded :: Base32 'StdUnpadded ByteString -> ByteString +decodeBase32Unpadded = decodeBase32 +{-# INLINE decodeBase32Unpadded #-} + +-- | Parse and validate a base32-encoded value, assuming that it is unpadded. -- --- >>> isValidBase32 "KN2W4=" --- False +-- >>> parseBase32Unpadded "kn2w4" +-- Right "kn2w4" -- --- >>> isValidBase32 "KN2W4%" --- False +-- >>> fmap decodeBase32Unpadded (parseBase32Unpadded "KN2W4") +-- Right "Sun" -- -isValidBase32 :: ByteString -> Bool -isValidBase32 = validateBase32 "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567" -{-# INLINE isValidBase32 #-} +-- >>> parseBase32Unpadded "" +-- Right "" +-- +-- >>> parseBase32Unpadded "KN2W4===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +-- >>> isLeft (parseBase32Unpadded "MZ") +-- True +-- +-- @since 1.0 +-- +parseBase32Unpadded :: ByteString -> Either Text (Base32 'StdUnpadded ByteString) +parseBase32Unpadded value = assertBase32 value + <$ (decodeBase32UnpaddedUntyped) value +{-# INLINE parseBase32Unpadded #-} + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> import Data.Either (isLeft) diff --git a/src/Data/ByteString/Base32/Hex.hs b/src/Data/ByteString/Base32/Hex.hs --- a/src/Data/ByteString/Base32/Hex.hs +++ b/src/Data/ByteString/Base32/Hex.hs @@ -1,10 +1,11 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE Trustworthy #-} -- | -- Module : Data.ByteString.Base32.Hex --- Copyright : (c) 2019-2023 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -23,22 +24,27 @@ , encodeBase32Unpadded , encodeBase32Unpadded' -- * Decoding +, decodeBase32Untyped +, decodeBase32UnpaddedUntyped +, decodeBase32PaddedUntyped + -- * Validation , decodeBase32 -, decodeBase32Unpadded , decodeBase32Padded --- , decodeBase32Lenient - -- * Validation -, isBase32Hex -, isValidBase32Hex +, decodeBase32Unpadded +, parseBase32Padded +, parseBase32Unpadded ) where +import Data.Base32.Types + import qualified Data.ByteString as BS import Data.ByteString.Internal (ByteString(..)) -import Data.ByteString.Base32.Internal +import Data.ByteString.Base32.Internal.Head import Data.ByteString.Base32.Internal.Tables -import Data.Either (isRight) +import Data.ByteString.Base32.Internal.Utils (validateLastNPads) import Data.Text (Text) +import qualified Data.Text as Text import qualified Data.Text.Encoding as T import System.IO.Unsafe (unsafeDupablePerformIO) @@ -53,8 +59,10 @@ -- >>> encodeBase32 "Sun" -- "ADQMS===" -- -encodeBase32 :: ByteString -> Text -encodeBase32 = T.decodeUtf8 . encodeBase32' +-- @since 1.0 +-- +encodeBase32 :: ByteString -> Base32 'HexPadded Text +encodeBase32 = fmap T.decodeUtf8 . encodeBase32' {-# INLINE encodeBase32 #-} -- | Encode a 'ByteString' value as a Base32hex 'ByteString' value with padding. @@ -66,8 +74,10 @@ -- >>> encodeBase32' "Sun" -- "ADQMS===" -- -encodeBase32' :: ByteString -> ByteString -encodeBase32' = encodeBase32_ "0123456789ABCDEFGHIJKLMNOPQRSTUV"# +-- @since 1.0 +-- +encodeBase32' :: ByteString -> Base32 'HexPadded ByteString +encodeBase32' = assertBase32 . encodeBase32_ "0123456789ABCDEFGHIJKLMNOPQRSTUV"# {-# INLINE encodeBase32' #-} -- | Decode an arbitrarily padded Base32hex-encoded 'ByteString' value. If its length @@ -79,27 +89,33 @@ -- -- === __Examples__: -- --- >>> decodeBase32 "ADQMS===" +-- >>> decodeBase32Untyped "ADQMS===" -- Right "Sun" -- --- >>> decodeBase32 "ADQMS" +-- >>> decodeBase32Untyped "ADQMS" -- Right "Sun" -- --- >>> decodeBase32 "ADQM===" +-- >>> decodeBase32Untyped "ADQM===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32 :: ByteString -> Either Text ByteString -decodeBase32 bs@(BS _ !l) +-- @since 1.0 +-- +decodeBase32Untyped :: ByteString -> Either Text ByteString +decodeBase32Untyped bs@(BS _ !l) | l == 0 = Right bs | r == 0 = unsafeDupablePerformIO $ decodeBase32_ hexDecodeTable bs - | r == 2 = unsafeDupablePerformIO $ decodeBase32_ hexDecodeTable (BS.append bs "======") - | r == 4 = validateLastNPads 2 bs $ decodeBase32_ hexDecodeTable (BS.append bs "====") - | r == 5 = validateLastNPads 3 bs $ decodeBase32_ hexDecodeTable (BS.append bs "===") - | r == 7 = validateLastNPads 5 bs $ decodeBase32_ hexDecodeTable (BS.append bs "=") - | otherwise = Left "Base32-encoded bytestring has invalid size" + | r == 2 = unsafeDupablePerformIO $ + decodeBase32_ hexDecodeTable (BS.append bs (BS.replicate 6 0x3d)) + | r == 4 = validateLastNPads 2 bs $ + decodeBase32_ hexDecodeTable (BS.append bs (BS.replicate 4 0x3d)) + | r == 5 = validateLastNPads 3 bs $ + decodeBase32_ hexDecodeTable (BS.append bs (BS.replicate 3 0x3d)) + | r == 7 = validateLastNPads 5 bs $ + decodeBase32_ hexDecodeTable (BS.append bs (BS.replicate 1 0x3d)) + | otherwise = Left (Text.pack "Base32-encoded bytestring has invalid size") where !r = l `rem` 8 -{-# INLINE decodeBase32 #-} +{-# INLINE decodeBase32Untyped #-} -- | Encode a 'ByteString' value as a Base32hex 'Text' value without padding. -- @@ -107,11 +123,13 @@ -- -- === __Examples__: -- --- >>> encodeBase32Unpadded' "Sun" +-- >>> encodeBase32Unpadded "Sun" -- "ADQMS" -- -encodeBase32Unpadded :: ByteString -> Text -encodeBase32Unpadded = T.decodeUtf8 . encodeBase32Unpadded' +-- @since 1.0 +-- +encodeBase32Unpadded :: ByteString -> Base32 'HexUnpadded Text +encodeBase32Unpadded = fmap T.decodeUtf8 . encodeBase32Unpadded' {-# INLINE encodeBase32Unpadded #-} -- | Encode a 'ByteString' value as a Base32hex 'ByteString' value without padding. @@ -123,8 +141,11 @@ -- >>> encodeBase32Unpadded' "Sun" -- "ADQMS" -- -encodeBase32Unpadded' :: ByteString -> ByteString -encodeBase32Unpadded' = encodeBase32NoPad_ "0123456789ABCDEFGHIJKLMNOPQRSTUV"# +-- @since 1.0 +-- +encodeBase32Unpadded' :: ByteString -> Base32 'HexUnpadded ByteString +encodeBase32Unpadded' = assertBase32 + . encodeBase32NoPad_ "0123456789ABCDEFGHIJKLMNOPQRSTUV"# {-# INLINE encodeBase32Unpadded' #-} -- | Decode an unpadded Base32hex-encoded 'ByteString' value. @@ -133,24 +154,30 @@ -- -- === __Examples__: -- --- >>> decodeBase32Unpadded "ADQMS" +-- >>> decodeBase32UnpaddedUntyped "ADQMS" -- Right "Sun" -- --- >>> decodeBase32Unpadded "ADQMS===" +-- >>> decodeBase32UnpaddedUntyped "ADQMS===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32Unpadded :: ByteString -> Either Text ByteString -decodeBase32Unpadded bs@(BS _ !l) +-- @since 1.0 +-- +decodeBase32UnpaddedUntyped :: ByteString -> Either Text ByteString +decodeBase32UnpaddedUntyped bs@(BS _ !l) | l == 0 = Right bs | r == 0 = validateLastNPads 1 bs $ decodeBase32_ hexDecodeTable bs - | r == 2 = unsafeDupablePerformIO $ decodeBase32_ hexDecodeTable (BS.append bs "======") - | r == 4 = validateLastNPads 1 bs $ decodeBase32_ hexDecodeTable (BS.append bs "====") - | r == 5 = validateLastNPads 1 bs $ decodeBase32_ hexDecodeTable (BS.append bs "===") - | r == 7 = validateLastNPads 1 bs $ decodeBase32_ hexDecodeTable (BS.append bs "=") - | otherwise = Left "Base32-encoded bytestring has invalid size" + | r == 2 = unsafeDupablePerformIO $ + decodeBase32_ hexDecodeTable (BS.append bs (BS.replicate 6 0x3d)) + | r == 4 = validateLastNPads 1 bs $ + decodeBase32_ hexDecodeTable (BS.append bs (BS.replicate 4 0x3d)) + | r == 5 = validateLastNPads 1 bs $ + decodeBase32_ hexDecodeTable (BS.append bs (BS.replicate 3 0x3d)) + | r == 7 = validateLastNPads 1 bs $ + decodeBase32_ hexDecodeTable (BS.append bs (BS.replicate 1 0x3d)) + | otherwise = Left (Text.pack "Base32-encoded bytestring has invalid size") where !r = l `rem` 8 -{-# INLINE decodeBase32Unpadded #-} +{-# INLINE decodeBase32UnpaddedUntyped #-} -- | Decode a padded Base32hex-encoded 'ByteString' value. -- @@ -158,58 +185,104 @@ -- -- === __Examples__: -- --- >>> decodeBase32Padded "ADQMS===" +-- >>> decodeBase32PaddedUntyped "ADQMS===" -- Right "Sun" -- --- >>> decodeBase32Padded "ADQMS" +-- >>> decodeBase32PaddedUntyped "ADQMS" -- Left "Base32-encoded bytestring requires padding" -- -decodeBase32Padded :: ByteString -> Either Text ByteString -decodeBase32Padded bs@(BS _ !l) +-- @since 1.0 +-- +decodeBase32PaddedUntyped :: ByteString -> Either Text ByteString +decodeBase32PaddedUntyped bs@(BS _ !l) | l == 0 = Right bs - | r == 1 = Left "Base32-encoded bytestring has invalid size" - | r == 3 = Left "Base32-encoded bytestring has invalid size" - | r == 6 = Left "Base32-encoded bytestring has invalid size" - | r /= 0 = Left "Base32-encoded bytestring requires padding" + | r == 1 = Left (Text.pack "Base32-encoded bytestring has invalid size") + | r == 3 = Left (Text.pack "Base32-encoded bytestring has invalid size") + | r == 6 = Left (Text.pack "Base32-encoded bytestring has invalid size") + | r /= 0 = Left (Text.pack "Base32-encoded bytestring requires padding") | otherwise = unsafeDupablePerformIO $ decodeBase32_ hexDecodeTable bs where !r = l `rem` 8 +{-# INLINE decodeBase32PaddedUntyped #-} + +-- | Decode a typed Base32hex-encoded 'ByteString' value. +-- +-- This function is padding-agnostic. +-- +-- >>> decodeBase32 (encodeBase32' "Sun") +-- "Sun" +-- >>> decodeBase32 (encodeBase32Unpadded' "Sun") +-- "Sun" +-- +-- @since 1.0 +-- +decodeBase32 :: HexAlphabet k => Base32 k ByteString -> ByteString +decodeBase32 = decodeBase32Typed_ hexDecodeTable +{-# INLINE decodeBase32 #-} + +-- | Decode a typed, padded Base32hex-encoded 'ByteString' value +-- +-- >>> decodeBase32Padded (encodeBase32' "Sun") +-- "Sun" +-- +-- @since 1.0 +-- +decodeBase32Padded :: Base32 'HexPadded ByteString -> ByteString +decodeBase32Padded = decodeBase32 {-# INLINE decodeBase32Padded #-} --- | Tell whether a 'ByteString' value is encoded in padded or unpadded Base32hex format +-- | Parse and validate a base32hex-encoded value, assuming that it has padding. -- --- === __Examples__: +-- >>> parseBase32Padded "adqms===" +-- Right "adqms===" -- --- >>> isBase32Hex "ADQMS" --- True +-- >>> fmap decodeBase32Padded (parseBase32Padded "ADQMS===") +-- Right "Sun" +-- +-- >>> parseBase32Padded "" +-- Right "" -- --- >>> isBase32Hex "ADQMS===" --- True +-- >>> parseBase32Padded "ADQMS" +-- Left "Base32-encoded bytestring requires padding" -- --- >>> isBase32Hex "ADQMS==" --- False +-- @since 1.0 -- -isBase32Hex :: ByteString -> Bool -isBase32Hex bs = isValidBase32Hex bs && isRight (decodeBase32 bs) -{-# INLINE isBase32Hex #-} +parseBase32Padded :: ByteString -> Either Text (Base32 'HexPadded ByteString) +parseBase32Padded value = assertBase32 value + <$ (decodeBase32PaddedUntyped) value +{-# INLINE parseBase32Padded #-} --- | Tell whether a 'ByteString' value is a valid Base32hex format. +-- | Decode a typed, unpadded Base32hex-encoded value. -- --- This will not tell you whether or not this is a correct Base32hex representation, --- only that it conforms to the correct shape (including padding/size etc.). --- To check whether it is a true Base32hex encoded 'ByteString' value, use 'isBase32'. +-- >>> decodeBase32Unpadded (encodeBase32Unpadded' "Sun") +-- "Sun" -- --- === __Examples__: +-- @since 1.0 -- --- >>> isValidBase32Hex "ADQMS" --- True +decodeBase32Unpadded :: Base32 'HexUnpadded ByteString -> ByteString +decodeBase32Unpadded = decodeBase32 +{-# INLINE decodeBase32Unpadded #-} + +-- | Parse and validate a base32hex-encoded value, assuming that is unpadded. -- --- >>> isValidBase32Hex "ADQMS=" --- False +-- >>> parseBase32Unpadded "adqms" +-- Right "adqms" +-- >>> fmap decodeBase32Unpadded (parseBase32Unpadded "ADQMS") +-- Right "Sun" +-- >>> parseBase32Unpadded "" +-- Right "" +-- >>> parseBase32Unpadded "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- >>> isLeft (parseBase32Unpadded "CP") +-- True -- --- >>> isValidBase32Hex "ADQMS%" --- False +-- @since 1.0 -- -isValidBase32Hex :: ByteString -> Bool -isValidBase32Hex = validateBase32 "0123456789ABCDEFGHIJKLMNOPQRSTUV" -{-# INLINE isValidBase32Hex #-} +parseBase32Unpadded :: ByteString -> Either Text (Base32 'HexUnpadded ByteString) +parseBase32Unpadded value = assertBase32 value + <$ (decodeBase32UnpaddedUntyped) value +{-# INLINE parseBase32Unpadded #-} + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> import Data.Either (isLeft) diff --git a/src/Data/ByteString/Base32/Internal.hs b/src/Data/ByteString/Base32/Internal.hs deleted file mode 100644 --- a/src/Data/ByteString/Base32/Internal.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE OverloadedStrings #-} --- | --- Module : Data.ByteString.Base32.Internal --- Copyright : (c) 2020 Emily Pillmore --- License : BSD-style --- --- Maintainer : Emily Pillmore --- Stability : Experimental --- Portability : portable --- --- Internal module defining the encoding and decoding --- processes and tables. --- -module Data.ByteString.Base32.Internal -( encodeBase32_ -, encodeBase32NoPad_ -, decodeBase32_ -, validateBase32 -, validateLastNPads -) where - - -import qualified Data.ByteString as BS -import Data.ByteString.Internal -import Data.ByteString.Base32.Internal.Head -import Data.Text (Text) - -import Foreign.ForeignPtr -import Foreign.Ptr -import Foreign.Storable - -import GHC.Word - -import System.IO.Unsafe - --- -------------------------------------------------------------------------- -- --- Validating Base32 - --- | Validate a base32-encoded bytestring against some alphabet. --- -validateBase32 :: ByteString -> ByteString -> Bool -validateBase32 !alphabet bs@(BS _ l) - | l == 0 = True - | r == 0 = f bs - | r == 2 = f (BS.append bs "======") - | r == 4 = f (BS.append bs "====") - | r == 5 = f (BS.append bs "===") - | r == 7 = f (BS.append bs "=") - | otherwise = False - where - r = l `rem` 8 - - f (BS fp l') = accursedUnutterablePerformIO $ withForeignPtr fp $ \p -> - go p (plusPtr p l') - - go !p !end - | p == end = return True - | otherwise = do - w <- peek p - - let check a - | a == 0x3d, plusPtr p 1 == end = True - | a == 0x3d, plusPtr p 2 == end = True - | a == 0x3d, plusPtr p 3 == end = True - | a == 0x3d, plusPtr p 4 == end = True - | a == 0x3d, plusPtr p 5 == end = True - | a == 0x3d, plusPtr p 6 == end = True - | a == 0x3d = False - | otherwise = BS.elem a alphabet - - if check w then go (plusPtr p 1) end else return False -{-# INLINE validateBase32 #-} - --- | This function checks that the last N-chars of a bytestring are '=' --- and, if true, fails with a message or completes some io action. --- --- This is necessary to check when decoding permissively (i.e. filling in padding chars). --- Consider the following 8 cases of a string of length l: --- --- - @l = 0 mod 8@: No pad chars are added, since the input is assumed to be good. --- - @l = 1 mod 8@: Never an admissible length in base32 --- - @l = 2 mod 8@: 6 padding chars are added. If padding chars are present in the string, they will fail as to decode as final quanta --- - @l = 3 mod 8@: Never an admissible length in base32 --- - @l = 4 mod 8@: 4 padding chars are added. If 2 padding chars are present in the string this can be "completed" in the sense that --- it now acts like a string `l == 2 mod 8` with 6 padding chars, and could potentially form corrupted data. --- - @l = 5 mod 8@: 3 padding chars are added. If 3 padding chars are present in the string, this could form corrupted data like in the --- previous case. --- - @l = 6 mod 8@: Never an admissible length in base32 --- - @l = 7 mod 8@: 1 padding char is added. If 5 padding chars are present in the string, this could form corrupted data like the --- previous cases. --- --- Hence, permissive decodes should only fill in padding chars when it makes sense to add them. That is, --- if an input is degenerate, it should never succeed when we add padding chars. We need the following invariant to hold: --- --- @ --- B32.decodeUnpadded <|> B32.decodePadded ~ B32.decode --- @ --- -validateLastNPads - :: Int - -> ByteString - -> IO (Either Text ByteString) - -> Either Text ByteString -validateLastNPads !n (BS !fp !l) io - | not valid = Left "Base32-encoded bytestring has invalid padding" - | otherwise = unsafeDupablePerformIO io - where - valid = accursedUnutterablePerformIO $ withForeignPtr fp $ \p -> do - let end = plusPtr p l - - let go :: Ptr Word8 -> IO Bool - go !q - | q == end = return True - | otherwise = do - a <- peek q - if a == 0x3d then return False else go (plusPtr q 1) - - go (plusPtr p (l - n)) -{-# INLINE validateLastNPads #-} diff --git a/src/Data/ByteString/Base32/Internal/Head.hs b/src/Data/ByteString/Base32/Internal/Head.hs --- a/src/Data/ByteString/Base32/Internal/Head.hs +++ b/src/Data/ByteString/Base32/Internal/Head.hs @@ -1,17 +1,37 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.ByteString.Base32.Internal.Head +-- Copyright : (c) 2020-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- Allocation and entry points for the strict encoding and decoding loops. +-- +-- @since 1.0 +-- module Data.ByteString.Base32.Internal.Head ( encodeBase32_ , encodeBase32NoPad_ , decodeBase32_ +, decodeBase32Typed_ ) where +import Prelude hiding (length, null) +import Data.Base32.Types (Base32, extractBase32) +import qualified Data.ByteString as BS +import Data.ByteString (length, null) import Data.ByteString.Internal +import Data.ByteString.Base32.Internal.Utils (encodedLength) import Data.ByteString.Base32.Internal.Loop import Data.ByteString.Base32.Internal.Tail import Data.Text (Text) +import qualified Data.Text as Text import Foreign.Ptr import Foreign.ForeignPtr @@ -29,6 +49,8 @@ -- allocates the correct number of bytes that will be written, and -- executes the inner encoding loop against that data. -- +-- @since 1.0 +-- encodeBase32_ :: Addr# -> ByteString -> ByteString encodeBase32_ !lut (BS !sfp !l) = unsafeDupablePerformIO $ do dfp <- mallocPlainForeignPtrBytes dlen @@ -39,7 +61,7 @@ (castPtr dptr) sptr end (loopTail lut dfp dptr end) where - !dlen = ceiling (fromIntegral @_ @Double l / 5) * 8 + !dlen = encodedLength l -- | Head of the unpadded base32 encoding loop. -- @@ -47,6 +69,8 @@ -- allocates the correct number of bytes that will be written, and -- executes the inner encoding loop against that data. -- +-- @since 1.0 +-- encodeBase32NoPad_ :: Addr# -> ByteString -> ByteString encodeBase32NoPad_ !lut (BS !sfp !l) = unsafeDupablePerformIO $ do !dfp <- mallocPlainForeignPtrBytes dlen @@ -57,7 +81,7 @@ (castPtr dptr) sptr end (loopTailNoPad lut dfp dptr end) where - !dlen = ceiling (fromIntegral @_ @Double l / 5) * 8 + !dlen = encodedLength l -- | Head of the base32 decoding loop. -- @@ -65,12 +89,37 @@ -- bytestring, allocates the correct number of bytes that will be written, -- and executes the inner decoding loop against that data. -- +-- @since 1.0 +-- decodeBase32_ :: Ptr Word8 -> ByteString -> IO (Either Text ByteString) -decodeBase32_ (Ptr !dtable) (BS !sfp !slen) = +decodeBase32_ table bs + | null bs = pure (Right bs) + | length bs `rem` 8 /= 0 = + pure (Left (Text.pack "Base32 input requires complete quanta")) + | otherwise = decodeComplete table bs + +decodeComplete :: Ptr Word8 -> ByteString -> IO (Either Text ByteString) +decodeComplete (Ptr !dtable) (BS !sfp !slen) = withForeignPtr sfp $ \sptr -> do dfp <- mallocPlainForeignPtrBytes dlen withForeignPtr dfp $ \dptr -> do let !end = plusPtr sptr slen decodeLoop dtable dfp dptr sptr end where - !dlen = ceiling (fromIntegral @_ @Double slen / 1.6) + !dlen = (slen `quot` 8) * 5 + +-- | Decode established Base32 provenance without validation. +-- Padding contributes no payload; partial final quanta need no copying. +-- +-- @since 1.0 +-- +decodeBase32Typed_ :: Ptr Word8 -> Base32 alphabet ByteString -> ByteString +decodeBase32Typed_ (Ptr table) encoded = unsafeDupablePerformIO $ do + dfp <- mallocPlainForeignPtrBytes dlen + withForeignPtr dfp $ \dst -> + withForeignPtr sfp $ \src -> decodeLoopTyped table dst src slen + pure (BS dfp dlen) + where + BS sfp slen = BS.dropWhileEnd (== 61) (extractBase32 encoded) + dlen = (slen `quot` 8) * 5 + (slen `rem` 8) * 5 `quot` 8 +{-# INLINE decodeBase32Typed_ #-} diff --git a/src/Data/ByteString/Base32/Internal/Loop.hs b/src/Data/ByteString/Base32/Internal/Loop.hs --- a/src/Data/ByteString/Base32/Internal/Loop.hs +++ b/src/Data/ByteString/Base32/Internal/Loop.hs @@ -1,11 +1,31 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.ByteString.Base32.Internal.Loop +-- Copyright : (c) 2020-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- Encoding loops, checked and typed decoding loops, and quantum validation. +-- +-- @since 1.0 +-- module Data.ByteString.Base32.Internal.Loop ( innerLoop , decodeLoop +, decodeLoopTyped +, decodeQuantum ) where +#ifdef BASE32_SIMD +import qualified Data.ByteString.Base32.Internal.SIMD as SIMD +#endif + import Data.Bits import Data.ByteString.Internal (ByteString(..)) import Data.ByteString.Base32.Internal.Utils @@ -16,6 +36,7 @@ import Foreign.ForeignPtr import Foreign.Storable +import GHC.ByteOrder import GHC.Exts import GHC.Word @@ -23,6 +44,10 @@ -- ------------------------------------------------------------------------ -- -- Encoding loops +-- | Encode complete quanta, then run the supplied tail handler. +-- +-- @since 1.0 +-- innerLoop :: Addr# -> Ptr Word64 @@ -30,7 +55,14 @@ -> Ptr Word8 -> (Ptr Word8 -> Ptr Word8 -> IO ByteString) -> IO ByteString -innerLoop !lut !dptr !sptr !end finish = go dptr sptr +innerLoop !lut !dptr !sptr !end finish = do +#ifdef BASE32_SIMD + consumed <- SIMD.encodePrefix lut sptr + (end `minusPtr` sptr) (castPtr dptr) + go (plusPtr dptr (consumed `quot` 5 * 8)) (plusPtr sptr consumed) +#else + go dptr sptr +#endif where lix a = w64 (aix (fromIntegral a .&. 0x1f) lut) {-# INLINE lix #-} @@ -59,13 +91,19 @@ .|. unsafeShiftL g 48 .|. unsafeShiftL h 56 - poke dst w + poke dst (case targetByteOrder of + LittleEndian -> w + BigEndian -> byteSwap64 w) go (plusPtr dst 8) (plusPtr src 5) {-# INLINE innerLoop #-} -- ------------------------------------------------------------------------ -- -- Decoding loops +-- | Decode and validate complete quanta, including the final padding. +-- +-- @since 1.0 +-- decodeLoop :: Addr# -> ForeignPtr Word8 @@ -73,132 +111,155 @@ -> Ptr Word8 -> Ptr Word8 -> IO (Either Text ByteString) -decodeLoop !lut !dfp !dptr !sptr !end = go dptr sptr +decodeLoop !lut !dfp !dptr !sptr !end = do +#ifdef BASE32_SIMD + consumed <- SIMD.decodePrefix lut sptr + (max 0 (end `minusPtr` sptr - 8)) dptr + go (plusPtr dptr (consumed `quot` 8 * 5)) (plusPtr sptr consumed) +#else + go dptr sptr +#endif where - lix a = w64 (aix (fromIntegral a) lut) - - err :: Ptr Word8 -> IO (Either Text ByteString) - err p = return . Left . T.pack - $ "invalid character at offset: " - ++ show (p `minusPtr` sptr) - - padErr :: Ptr Word8 -> IO (Either Text ByteString) - padErr p = return . Left . T.pack - $ "invalid padding at offset: " - ++ show (p `minusPtr` sptr) - - look :: Ptr Word8 -> IO Word64 - look !p = lix <$> peek @Word8 p - + look value = w64 (aix (fromIntegral value) lut) go !dst !src - | plusPtr src 8 >= end = do - - a <- look src - b <- look (plusPtr src 1) - c <- look (plusPtr src 2) - d <- look (plusPtr src 3) - e <- look (plusPtr src 4) - f <- look (plusPtr src 5) - g <- look (plusPtr src 6) - h <- look (plusPtr src 7) - finalChunk dst src a b c d e f g h - - | otherwise = do - !t <- peekWord64BE (castPtr src) - - let a = lix (unsafeShiftR t 56) - b = lix (unsafeShiftR t 48) - c = lix (unsafeShiftR t 40) - d = lix (unsafeShiftR t 32) - e = lix (unsafeShiftR t 24) - f = lix (unsafeShiftR t 16) - g = lix (unsafeShiftR t 8) - h = lix t - - decodeChunk dst src a b c d e f g h - - finalChunk !dst !src !a !b !c !d !e !f !g !h - | a == 0x63 = padErr src - | b == 0x63 = padErr (plusPtr src 1) - | a == 0xff = err src - | b == 0xff = err (plusPtr src 1) - | c == 0xff = err (plusPtr src 2) - | d == 0xff = err (plusPtr src 3) - | e == 0xff = err (plusPtr src 4) - | f == 0xff = err (plusPtr src 5) - | g == 0xff = err (plusPtr src 6) - | h == 0xff = err (plusPtr src 7) - | otherwise = do - - let !o1 = (fromIntegral a `unsafeShiftL` 3) .|. (fromIntegral b `unsafeShiftR` 2) - !o2 = (fromIntegral b `unsafeShiftL` 6) - .|. (fromIntegral c `unsafeShiftL` 1) - .|. (fromIntegral d `unsafeShiftR` 4) - !o3 = (fromIntegral d `unsafeShiftL` 4) .|. (fromIntegral e `unsafeShiftR` 1) - !o4 = (fromIntegral e `unsafeShiftL` 7) - .|. (fromIntegral f `unsafeShiftL` 2) - .|. (fromIntegral g `unsafeShiftR` 3) - !o5 = (fromIntegral g `unsafeShiftL` 5) .|. fromIntegral h - - poke @Word8 dst o1 - poke @Word8 (plusPtr dst 1) o2 - - case (c,d,e,f,g,h) of - (0x63,0x63,0x63,0x63,0x63,0x63) -> - return (Right (BS dfp (1 + minusPtr dst dptr))) - (0x63,_,_,_,_,_) -> padErr (plusPtr src 3) - (_,0x63,0x63,0x63,0x63,0x63) -> padErr (plusPtr src 3) - (_,0x63,_,_,_,_) -> padErr (plusPtr src 4) - (_,_,0x63,0x63,0x63,0x63) -> do - poke @Word8 (plusPtr dst 2) o3 - return (Right (BS dfp (2 + minusPtr dst dptr))) - (_,_,0x63,_,_,_) -> padErr (plusPtr src 5) - (_,_,_,0x63,0x63,0x63) -> do - poke @Word8 (plusPtr dst 2) o3 - poke @Word8 (plusPtr dst 3) o4 - return (Right (BS dfp (3 + minusPtr dst dptr))) - (_,_,_,0x63,_,_) -> padErr (plusPtr src 6) - (_,_,_,_,0x63,0x63) -> padErr (plusPtr src 6) - (_,_,_,_,0x63,_) -> padErr (plusPtr src 7) - (_,_,_,_,_,0x63) -> do - poke @Word8 (plusPtr dst 2) o3 - poke @Word8 (plusPtr dst 3) o4 - poke @Word8 (plusPtr dst 4) o5 - return (Right (BS dfp (4 + minusPtr dst dptr))) - (_,_,_,_,_,_) -> do - poke @Word8 (plusPtr dst 2) o3 - poke @Word8 (plusPtr dst 3) o4 - poke @Word8 (plusPtr dst 4) o5 - return (Right (BS dfp (5 + minusPtr dst dptr))) - - decodeChunk !dst !src !a !b !c !d !e !f !g !h - | a == 0x63 = padErr src - | b == 0x63 = padErr (plusPtr src 1) - | c == 0x63 = padErr (plusPtr src 2) - | d == 0x63 = padErr (plusPtr src 3) - | e == 0x63 = padErr (plusPtr src 4) - | f == 0x63 = padErr (plusPtr src 5) - | g == 0x63 = padErr (plusPtr src 6) - | h == 0x63 = padErr (plusPtr src 7) - | a == 0xff = err src - | b == 0xff = err (plusPtr src 1) - | c == 0xff = err (plusPtr src 2) - | d == 0xff = err (plusPtr src 3) - | e == 0xff = err (plusPtr src 4) - | f == 0xff = err (plusPtr src 5) - | g == 0xff = err (plusPtr src 6) - | h == 0xff = err (plusPtr src 7) + | src == end = pure (Right (BS dfp (dst `minusPtr` dptr))) | otherwise = do + t <- peekWord64BE (castPtr src) + let !a = look (unsafeShiftR t 56) + !b = look (unsafeShiftR t 48) + !c = look (unsafeShiftR t 40) + !d = look (unsafeShiftR t 32) + !e = look (unsafeShiftR t 24) + !f = look (unsafeShiftR t 16) + !g = look (unsafeShiftR t 8) + !h = look t + final = plusPtr src 8 == end + if not final && (a .|. b .|. c .|. d .|. e .|. f .|. g .|. h) < 32 + then do + writeFull dst (pack a b c d e f g h) + go (plusPtr dst 5) (plusPtr src 8) + else case decodeQuantum final (src `minusPtr` sptr) a b c d e f g h of + Left err -> pure (Left err) + Right count -> do + let clean v = if v == 0x63 then 0 else v + w = pack a b (clean c) (clean d) (clean e) + (clean f) (clean g) (clean h) + write i + | i == count = pure () + | otherwise = do + poke @Word8 (plusPtr dst i) + (fromIntegral (unsafeShiftR w (32 - 8 * i))) + write (i + 1) + write 0 + if final + then pure (Right (BS dfp (dst `minusPtr` dptr + count))) + else go (plusPtr dst 5) (plusPtr src 8) + pack a b c d e f g h = + unsafeShiftL a 35 .|. unsafeShiftL b 30 + .|. unsafeShiftL c 25 .|. unsafeShiftL d 20 + .|. unsafeShiftL e 15 .|. unsafeShiftL f 10 + .|. unsafeShiftL g 5 .|. h + writeFull dst w = do + let first = fromIntegral (w `unsafeShiftR` 8) :: Word32 + poke (castPtr dst) (case targetByteOrder of + LittleEndian -> byteSwap32 first + BigEndian -> first) + poke @Word8 (plusPtr dst 4) (fromIntegral w) +{-# INLINE decodeLoop #-} - let !w = (unsafeShiftL a 35 - .|. unsafeShiftL b 30 - .|. unsafeShiftL c 25 - .|. unsafeShiftL d 20 - .|. unsafeShiftL e 15 - .|. unsafeShiftL f 10 - .|. unsafeShiftL g 5 - .|. h) :: Word64 +-- | Validate a decoded quantum before any output is written. Return its +-- payload length. Both pointer and byte-array loops use the same rules. +-- +-- @since 1.0 +-- +decodeQuantum + :: Bool -> Int + -> Word64 -> Word64 -> Word64 -> Word64 + -> Word64 -> Word64 -> Word64 -> Word64 + -> Either Text Int +decodeQuantum !final !offset !a !b !c !d !e !f !g !h + | a == 0x63 = padErr 0 + | b == 0x63 = padErr 1 + | not final, c == 0x63 = padErr 2 + | not final, d == 0x63 = padErr 3 + | not final, e == 0x63 = padErr 4 + | not final, f == 0x63 = padErr 5 + | not final, g == 0x63 = padErr 6 + | not final, h == 0x63 = padErr 7 + | a == 0xff = charErr 0 + | b == 0xff = charErr 1 + | c == 0xff = charErr 2 + | d == 0xff = charErr 3 + | e == 0xff = charErr 4 + | f == 0xff = charErr 5 + | g == 0xff = charErr 6 + | h == 0xff = charErr 7 + | not final = Right 5 + | otherwise = case (c,d,e,f,g,h) of + (0x63,0x63,0x63,0x63,0x63,0x63) -> canonical b 3 1 1 + (0x63,_,_,_,_,_) -> padErr 3 + (_,0x63,0x63,0x63,0x63,0x63) -> padErr 3 + (_,0x63,_,_,_,_) -> padErr 4 + (_,_,0x63,0x63,0x63,0x63) -> canonical d 15 3 2 + (_,_,0x63,_,_,_) -> padErr 5 + (_,_,_,0x63,0x63,0x63) -> canonical e 1 4 3 + (_,_,_,0x63,_,_) -> padErr 6 + (_,_,_,_,0x63,0x63) -> padErr 6 + (_,_,_,_,0x63,_) -> padErr 7 + (_,_,_,_,_,0x63) -> canonical g 7 6 4 + _ -> Right 5 + where + failure message i = Left (T.pack (message ++ show (offset + i))) + padErr = failure "invalid padding at offset: " + charErr = failure "invalid character at offset: " + canonical value mask i count + | value .&. mask == 0 = Right count + | otherwise = failure "non-canonical encoding at offset: " i +{-# INLINE decodeQuantum #-} - poke @Word32 (castPtr dst) (byteSwap32 (fromIntegral (unsafeShiftR w 8))) - poke @Word8 (plusPtr dst 4) (fromIntegral w) - go (plusPtr dst 5) (plusPtr src 8) +-- | Decode known-valid symbols. Alphabet, size, padding placement and unused +-- bits have already been established by the producer of the typed value. +-- The caller excludes trailing padding from the source length. +-- +-- @since 1.0 +-- +decodeLoopTyped :: Addr# -> Ptr Word8 -> Ptr Word8 -> Int -> IO () +decodeLoopTyped table dptr sptr slen = do +#ifdef BASE32_SIMD + consumed <- SIMD.decodeTypedPrefix table sptr slen dptr +#else + let consumed = 0 +#endif + go (plusPtr dptr (consumed `quot` 8 * 5)) consumed + where + look value = w64 (aix (fromIntegral value) table) + go !dst !i + | slen - i >= 8 = do + t <- peekWord64BE (castPtr (plusPtr sptr i)) + let w = pack (look (t `unsafeShiftR` 56)) (look (t `unsafeShiftR` 48)) + (look (t `unsafeShiftR` 40)) (look (t `unsafeShiftR` 32)) + (look (t `unsafeShiftR` 24)) (look (t `unsafeShiftR` 16)) + (look (t `unsafeShiftR` 8)) (look t) + first = fromIntegral (w `unsafeShiftR` 8) :: Word32 + poke (castPtr dst) (case targetByteOrder of + LittleEndian -> byteSwap32 first + BigEndian -> first) + poke @Word8 (plusPtr dst 4) (fromIntegral w) + go (plusPtr dst 5) (i + 8) + | otherwise = tailBytes dst i 0 0 (0 :: Word16) + tailBytes !dst !i !bits !j !buffer + | bits >= 8 = do + let rest = bits - 8 + poke @Word8 (plusPtr dst j) (fromIntegral (buffer `unsafeShiftR` rest)) + tailBytes dst i rest (j + 1) buffer + | i < slen = do + symbol <- peek @Word8 (plusPtr sptr i) + tailBytes dst (i + 1) (bits + 5) j + (buffer `unsafeShiftL` 5 .|. fromIntegral (aix symbol table)) + | otherwise = pure () + pack a b c d e f g h = + a `unsafeShiftL` 35 .|. b `unsafeShiftL` 30 + .|. c `unsafeShiftL` 25 .|. d `unsafeShiftL` 20 + .|. e `unsafeShiftL` 15 .|. f `unsafeShiftL` 10 + .|. g `unsafeShiftL` 5 .|. h +{-# INLINE decodeLoopTyped #-} diff --git a/src/Data/ByteString/Base32/Internal/SIMD.hs b/src/Data/ByteString/Base32/Internal/SIMD.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base32/Internal/SIMD.hs @@ -0,0 +1,153 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE UnliftedFFITypes #-} +-- | +-- Module : Data.ByteString.Base32.Internal.SIMD +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- Bounded native prefixes. Callers retain pointer buffers with withForeignPtr. +-- Byte arrays are passed directly to unsafe FFI: GHC cannot collect during +-- the call, and the kernels retain no pointers and make no callbacks. +-- +-- @since 1.0 +-- +module Data.ByteString.Base32.Internal.SIMD + ( encodePrefix + , decodePrefix + , decodeTypedPrefix + , encodeByteArrayPrefix + , decodeByteArrayPrefix + , decodeByteArrayTypedPrefix + ) where + +import Control.Monad.ST (ST) +import Control.Monad.ST.Unsafe (unsafeIOToST) +import Data.ByteString.Base32.Internal.Tables (hexDecodeTable, stdDecodeTable) +import Data.ByteString.Base32.Internal.Utils (aix) +import Data.Primitive.ByteArray (ByteArray (..), MutableByteArray (..)) +import Data.Word (Word8) +import Foreign.C.Types (CInt (..), CSize (..)) +import GHC.Exts (Addr#, ByteArray#, MutableByteArray#) +import GHC.Ptr (Ptr (..)) + +foreign import ccall unsafe "hs_base32_simd_encode" + c_encode :: Ptr Word8 -> CSize -> Ptr Word8 -> CInt -> IO CSize +foreign import ccall unsafe "hs_base32_simd_decode" + c_decode :: Ptr Word8 -> CSize -> Ptr Word8 -> CInt -> IO CSize +foreign import ccall unsafe "hs_base32_simd_encode" + c_encodeArray :: ByteArray# -> CSize -> MutableByteArray# s -> CInt -> IO CSize +foreign import ccall unsafe "hs_base32_simd_decode" + c_decodeArray :: ByteArray# -> CSize -> MutableByteArray# s -> CInt -> IO CSize + +foreign import ccall unsafe "hs_base32_simd_decode_typed" + c_decodeTyped :: Ptr Word8 -> CSize -> Ptr Word8 -> CInt -> IO CSize +foreign import ccall unsafe "hs_base32_simd_decode_typed" + c_decodeArrayTyped :: ByteArray# -> CSize -> MutableByteArray# s -> CInt -> IO CSize + +-- | Encode complete quanta. Destination capacity must be at least len/5*8. +-- +-- @since 1.0 +-- +encodePrefix :: Addr# -> Ptr Word8 -> Int -> Ptr Word8 -> IO Int +encodePrefix alphabet src len dst + | len < 80 = pure 0 + | Just hex <- encodingAlphabet alphabet = + fromIntegral <$> c_encode src (fromIntegral len) dst hex + | otherwise = pure 0 +{-# INLINE encodePrefix #-} + +-- | Decode valid complete quanta; leave padding/invalid blocks for scalar code. +-- Destination capacity must be at least len/8*5. +-- +-- @since 1.0 +-- +decodePrefix :: Addr# -> Ptr Word8 -> Int -> Ptr Word8 -> IO Int +decodePrefix table src len dst + | len < 64 = pure 0 + | Just hex <- decodingAlphabet table = + fromIntegral <$> c_decode src (fromIntegral len) dst hex + | otherwise = pure 0 +{-# INLINE decodePrefix #-} + +-- | Decode known-valid symbols without validation; excludes trailing padding. +-- Destination capacity must be at least len/8*5. +-- +-- @since 1.0 +-- +decodeTypedPrefix :: Addr# -> Ptr Word8 -> Int -> Ptr Word8 -> IO Int +decodeTypedPrefix table src len dst + | len < 64 = pure 0 + | Just hex <- decodingAlphabet table = + fromIntegral <$> c_decodeTyped src (fromIntegral len) dst hex + | otherwise = pure 0 +{-# INLINE decodeTypedPrefix #-} + +-- | Direct unpinned-array encoding into a distinct mutable output buffer. +-- +-- @since 1.0 +-- +encodeByteArrayPrefix :: + Addr# -> ByteArray -> Int -> MutableByteArray s -> ST s Int +encodeByteArrayPrefix alphabet (ByteArray src) len (MutableByteArray dst) + | len < 40 = pure 0 + | Just hex <- encodingAlphabet alphabet = + unsafeIOToST $ + fromIntegral <$> c_encodeArray src (fromIntegral len) dst hex + | otherwise = pure 0 +{-# INLINE encodeByteArrayPrefix #-} + +-- | Direct unpinned-array decoding into a distinct mutable output buffer. +-- +-- @since 1.0 +-- +decodeByteArrayPrefix :: + Addr# -> ByteArray -> Int -> MutableByteArray s -> ST s Int +decodeByteArrayPrefix table (ByteArray src) len (MutableByteArray dst) + | len < 64 = pure 0 + | Just hex <- decodingAlphabet table = + unsafeIOToST $ + fromIntegral <$> c_decodeArray src (fromIntegral len) dst hex + | otherwise = pure 0 +{-# INLINE decodeByteArrayPrefix #-} + +-- | Unchecked array decoding of known-valid symbols, excluding padding. +-- +-- @since 1.0 +-- +decodeByteArrayTypedPrefix :: + Addr# -> ByteArray -> Int -> MutableByteArray s -> ST s Int +decodeByteArrayTypedPrefix table (ByteArray src) len (MutableByteArray dst) + | len < 64 = pure 0 + | Just hex <- decodingAlphabet table = + unsafeIOToST $ + fromIntegral <$> c_decodeArrayTyped src (fromIntegral len) dst hex + | otherwise = pure 0 +{-# INLINE decodeByteArrayTypedPrefix #-} + +-- Arbitrary alphabets are part of the exposed low-level API. Only exact +-- built-in alphabets can use these kernels; other alphabets stay scalar. +encodingAlphabet :: Addr# -> Maybe CInt +encodingAlphabet alphabet + | matches "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# = Just 0 + | matches "0123456789ABCDEFGHIJKLMNOPQRSTUV"# = Just 1 + | otherwise = Nothing + where + matches expected = go 0 + where + go i + | i == 32 = True + | aix i alphabet == aix i expected = go (i + 1) + | otherwise = False +{-# INLINE encodingAlphabet #-} + +decodingAlphabet :: Addr# -> Maybe CInt +decodingAlphabet table + | Ptr table == stdDecodeTable = Just 0 + | Ptr table == hexDecodeTable = Just 1 + | otherwise = Nothing +{-# INLINE decodingAlphabet #-} diff --git a/src/Data/ByteString/Base32/Internal/Short.hs b/src/Data/ByteString/Base32/Internal/Short.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base32/Internal/Short.hs @@ -0,0 +1,237 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE MagicHash #-} +-- | +-- Module : Data.ByteString.Base32.Internal.Short +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- Direct byte-array codecs; no conversion through strict ByteString. +-- +-- @since 1.0 +-- +module Data.ByteString.Base32.Internal.Short + ( encodeShort + , decodeShort + , decodeShortTyped + ) where + +import Control.Monad.ST (runST) +import Data.Base32.Types (Base32, extractBase32) +import Data.Bits +import Data.ByteString.Base32.Internal.Loop (decodeQuantum) +import Data.ByteString.Base32.Internal.Utils (aix, encodedLength) +import Data.ByteString.Short.Internal (ShortByteString(..)) +import qualified Data.ByteString.Short as SBS +import Data.Primitive.ByteArray +import Data.Text (Text) +import Data.Word +import GHC.Exts (Addr#) +import GHC.ByteOrder +import GHC.Ptr (Ptr(..)) + +#ifdef BASE32_SIMD +import qualified Data.ByteString.Base32.Internal.SIMD as SIMD +#endif + +-- | Encode with the supplied 32-character ASCII alphabet. +-- +-- @since 1.0 +-- +encodeShort :: Addr# -> Bool -> ShortByteString -> ShortByteString +encodeShort alphabet padded input@(SBS source) = runST $ do + dst <- newByteArray capacity +#ifdef BASE32_SIMD + consumed <- SIMD.encodeByteArrayPrefix alphabet src len dst +#else + let consumed = 0 +#endif + let emit !i !j !bits !buffer + | bits >= 5 = do + let next = bits - 5 + writeByteArray dst j + (aix (fromIntegral (buffer `unsafeShiftR` next) .&. 31) alphabet) + emit i (j + 1) next buffer + | i < len = emit (i + 1) j (bits + 8) + ((buffer `unsafeShiftL` 8) .|. fromIntegral (byte i)) + | bits > 0 = do + writeByteArray dst j + (aix (fromIntegral (buffer `unsafeShiftL` (5 - bits)) .&. 31) + alphabet) + finish (j + 1) + | otherwise = finish j + finish !j + | padded && j < capacity = do + writeByteArray dst j (61 :: Word8) + finish (j + 1) + | otherwise = do + shrinkMutableByteArray dst j + ByteArray result <- unsafeFreezeByteArray dst + pure (SBS result) + let full !i !j + | i + 5 > len = emit i j 0 (0 :: Word16) + | otherwise = do + let t = fromIntegral (byte i) `unsafeShiftL` 32 + .|. fromIntegral (byte (i + 1)) `unsafeShiftL` 24 + .|. fromIntegral (byte (i + 2)) `unsafeShiftL` 16 + .|. fromIntegral (byte (i + 3)) `unsafeShiftL` 8 + .|. fromIntegral (byte (i + 4)) :: Word64 + at shiftCount = fromIntegral + (aix (fromIntegral (t `unsafeShiftR` shiftCount) .&. 31) alphabet) + w = at 35 .|. at 30 `unsafeShiftL` 8 + .|. at 25 `unsafeShiftL` 16 .|. at 20 `unsafeShiftL` 24 + .|. at 15 `unsafeShiftL` 32 .|. at 10 `unsafeShiftL` 40 + .|. at 5 `unsafeShiftL` 48 .|. at 0 `unsafeShiftL` 56 :: Word64 + writeByteArray dst (j `quot` 8) (case targetByteOrder of + LittleEndian -> w + BigEndian -> byteSwap64 w) + full (i + 5) (j + 8) + full consumed (consumed `quot` 5 * 8) + where + src = ByteArray source + len = SBS.length input + capacity = encodedLength len + byte i = indexByteArray src i :: Word8 +{-# INLINE encodeShort #-} + +-- | Decode with an ASCII lookup table. The caller checks the input length +-- and final padding before entering the loop. +-- +-- @since 1.0 +-- +decodeShort + :: Ptr Word8 -> ShortByteString -> Either Text ShortByteString +decodeShort (Ptr table) input@(SBS source) = runST $ do + dst <- newByteArray capacity +#ifdef BASE32_SIMD + consumed <- SIMD.decodeByteArrayPrefix table + src (max 0 (len - 8)) dst +#else + let consumed = 0 +#endif + let go !i !j + | i + 8 >= len = final i j + | otherwise = do + let word = indexByteArray src (i `quot` 8) :: Word64 + t = case targetByteOrder of + LittleEndian -> byteSwap64 word + BigEndian -> word + from shiftCount = fromIntegral + (aix (fromIntegral (t `unsafeShiftR` shiftCount)) table) :: Word64 + !a = from 56 + !b = from 48 + !c = from 40 + !d = from 32 + !e = from 24 + !f = from 16 + !g = from 8 + !h = from 0 + if (a .|. b .|. c .|. d .|. e .|. f .|. g .|. h) < 32 + then do + writeFull j (pack a b c d e f g h) + go (i + 8) (j + 5) + else finishQuantum False i j a b c d e f g h + final !i !j + | i >= len = freeze j + | otherwise = finishQuantum True i j + (look i) (look (i + 1)) (look (i + 2)) (look (i + 3)) + (look (i + 4)) (look (i + 5)) (look (i + 6)) (look (i + 7)) + finishQuantum lastQuantum i j a b c d e f g h = + case decodeQuantum lastQuantum i a b c d e f g h of + Left err -> pure (Left err) + Right count -> do + let clean v = if v == 0x63 then 0 else v + w = pack a b (clean c) (clean d) (clean e) + (clean f) (clean g) (clean h) + write !k + | k == count = pure () + | otherwise = do + writeByteArray dst (j + k) + (fromIntegral (w `unsafeShiftR` (32 - 8 * k)) :: Word8) + write (k + 1) + write 0 + if lastQuantum then freeze (j + count) else go (i + 8) (j + count) + pack a b c d e f g h = + unsafeShiftL a 35 .|. unsafeShiftL b 30 + .|. unsafeShiftL c 25 .|. unsafeShiftL d 20 + .|. unsafeShiftL e 15 .|. unsafeShiftL f 10 + .|. unsafeShiftL g 5 .|. h + writeFull j w = do + writeByteArray dst j (fromIntegral (w `unsafeShiftR` 32) :: Word8) + writeByteArray dst (j + 1) (fromIntegral (w `unsafeShiftR` 24) :: Word8) + writeByteArray dst (j + 2) (fromIntegral (w `unsafeShiftR` 16) :: Word8) + writeByteArray dst (j + 3) (fromIntegral (w `unsafeShiftR` 8) :: Word8) + writeByteArray dst (j + 4) (fromIntegral w :: Word8) + freeze n = do + shrinkMutableByteArray dst n + ByteArray result <- unsafeFreezeByteArray dst + pure (Right (SBS result)) + go consumed (consumed `quot` 8 * 5) + where + src = ByteArray source + len = SBS.length input + remainder = len `rem` 8 + capacity = (len `quot` 8) * 5 + (remainder * 5 `quot` 8) + look i + | i >= len = 0x63 + | otherwise = fromIntegral (aix (indexByteArray src i) table) :: Word64 +{-# INLINE decodeShort #-} + +-- | Decode established provenance directly from a byte array, without +-- alphabet, size, padding-policy or canonical-bit validation. +-- +-- @since 1.0 +-- +decodeShortTyped + :: Ptr Word8 -> Base32 alphabet ShortByteString -> ShortByteString +decodeShortTyped (Ptr table) encoded = runST $ do + dst <- newByteArray capacity +#ifdef BASE32_SIMD + consumed <- SIMD.decodeByteArrayTypedPrefix table src len dst +#else + let consumed = 0 +#endif + let go !i !j + | len - i >= 8 = do + let word = indexByteArray src (i `quot` 8) :: Word64 + t = case targetByteOrder of + LittleEndian -> byteSwap64 word + BigEndian -> word + at n = fromIntegral + (aix (fromIntegral (t `unsafeShiftR` n)) table) :: Word64 + w = at 56 `unsafeShiftL` 35 .|. at 48 `unsafeShiftL` 30 + .|. at 40 `unsafeShiftL` 25 .|. at 32 `unsafeShiftL` 20 + .|. at 24 `unsafeShiftL` 15 .|. at 16 `unsafeShiftL` 10 + .|. at 8 `unsafeShiftL` 5 .|. at 0 + writeByteArray dst j (fromIntegral (w `unsafeShiftR` 32) :: Word8) + writeByteArray dst (j + 1) (fromIntegral (w `unsafeShiftR` 24) :: Word8) + writeByteArray dst (j + 2) (fromIntegral (w `unsafeShiftR` 16) :: Word8) + writeByteArray dst (j + 3) (fromIntegral (w `unsafeShiftR` 8) :: Word8) + writeByteArray dst (j + 4) (fromIntegral w :: Word8) + go (i + 8) (j + 5) + | otherwise = tailBytes i j 0 (0 :: Word16) + tailBytes !i !j !bits !buffer + | bits >= 8 = do + let rest = bits - 8 + writeByteArray dst j (fromIntegral (buffer `unsafeShiftR` rest) :: Word8) + tailBytes i (j + 1) rest buffer + | i < len = tailBytes (i + 1) j (bits + 5) + (buffer `unsafeShiftL` 5 .|. fromIntegral (aix (byte i) table)) + | otherwise = pure () + go consumed (consumed `quot` 8 * 5) + ByteArray result <- unsafeFreezeByteArray dst + pure (SBS result) + where + !input@(SBS source) = extractBase32 encoded + src = ByteArray source + byte i = indexByteArray src i :: Word8 + payloadEnd n + | n > 0 && byte (n - 1) == 61 = payloadEnd (n - 1) + | otherwise = n + len = payloadEnd (SBS.length input) + capacity = (len `quot` 8) * 5 + (len `rem` 8) * 5 `quot` 8 +{-# INLINE decodeShortTyped #-} diff --git a/src/Data/ByteString/Base32/Internal/Tables.hs b/src/Data/ByteString/Base32/Internal/Tables.hs --- a/src/Data/ByteString/Base32/Internal/Tables.hs +++ b/src/Data/ByteString/Base32/Internal/Tables.hs @@ -1,4 +1,17 @@ {-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.ByteString.Base32.Internal.Tables +-- Copyright : (c) 2020-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- Decoding tables for the standard and extended-hex alphabets. +-- +-- @since 1.0 +-- module Data.ByteString.Base32.Internal.Tables ( stdDecodeTable , hexDecodeTable @@ -11,6 +24,10 @@ import GHC.Ptr (Ptr) +-- | ASCII decoding table for the standard alphabet. +-- +-- @since 1.0 +-- stdDecodeTable :: Ptr Word8 stdDecodeTable = writeNPlainPtrBytes @Word8 256 [ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff @@ -32,6 +49,10 @@ ] {-# NOINLINE stdDecodeTable #-} +-- | ASCII decoding table for the extended-hex alphabet. +-- +-- @since 1.0 +-- hexDecodeTable :: Ptr Word8 hexDecodeTable = writeNPlainPtrBytes @Word8 256 [ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff diff --git a/src/Data/ByteString/Base32/Internal/Tail.hs b/src/Data/ByteString/Base32/Internal/Tail.hs --- a/src/Data/ByteString/Base32/Internal/Tail.hs +++ b/src/Data/ByteString/Base32/Internal/Tail.hs @@ -1,5 +1,18 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} +-- | +-- Module : Data.ByteString.Base32.Internal.Tail +-- Copyright : (c) 2020-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- Final quantum encoding for padded and unpadded output. +-- +-- @since 1.0 +-- module Data.ByteString.Base32.Internal.Tail ( loopTail , loopTailNoPad @@ -20,6 +33,8 @@ -- | Unroll final quantum encoding for base32 -- +-- @since 1.0 +-- loopTail :: Addr# -> ForeignPtr Word8 @@ -108,6 +123,8 @@ {-# INLINE loopTail #-} -- | Unroll final quantum encoding for base32 +-- +-- @since 1.0 -- loopTailNoPad :: Addr# diff --git a/src/Data/ByteString/Base32/Internal/Utils.hs b/src/Data/ByteString/Base32/Internal/Utils.hs --- a/src/Data/ByteString/Base32/Internal/Utils.hs +++ b/src/Data/ByteString/Base32/Internal/Utils.hs @@ -1,5 +1,18 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} +-- | +-- Module : Data.ByteString.Base32.Internal.Utils +-- Copyright : (c) 2020-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- Shared allocation, byte-order, table lookup, rechunking, and padding utilities. +-- +-- @since 1.0 +-- module Data.ByteString.Base32.Internal.Utils ( aix , peekWord32BE @@ -8,12 +21,16 @@ , w32 , w64 , w64_32 +, encodedLength , writeNPlainPtrBytes +, validateLastNPads ) where import Data.ByteString (ByteString) import qualified Data.ByteString as BS +import Data.Text (Text) +import qualified Data.Text as Text import Foreign.Ptr import Foreign.Storable @@ -28,26 +45,42 @@ -- | Read 'Word8' index off alphabet addr -- +-- @since 1.0 +-- aix :: Word8 -> Addr# -> Word8 aix w8 alpha = W8# (indexWord8OffAddr# alpha i) where !(I# i) = fromIntegral w8 {-# INLINE aix #-} +-- | Widen a 'Word8' to a 'Word32'. +-- +-- @since 1.0 +-- w32 :: Word8 -> Word32 w32 = fromIntegral {-# INLINE w32 #-} +-- | Widen a 'Word32' to a 'Word64'. +-- +-- @since 1.0 +-- w64_32 :: Word32 -> Word64 w64_32 = fromIntegral {-# INLINE w64_32 #-} +-- | Widen a 'Word8' to a 'Word64'. +-- +-- @since 1.0 +-- w64 :: Word8 -> Word64 w64 = fromIntegral {-# INLINE w64 #-} -- | Allocate and fill @n@ bytes with some data -- +-- @since 1.0 +-- writeNPlainPtrBytes :: Storable a => Int @@ -62,12 +95,20 @@ go !p (x:xs) = poke p x >> go (plusPtr p 1) xs {-# INLINE writeNPlainPtrBytes #-} +-- | Read a 32-bit word in big-endian byte order. +-- +-- @since 1.0 +-- peekWord32BE :: Ptr Word32 -> IO Word32 peekWord32BE p = case targetByteOrder of LittleEndian -> byteSwap32 <$> peek p BigEndian -> peek p {-# inline peekWord32BE #-} +-- | Read a 64-bit word in big-endian byte order. +-- +-- @since 1.0 +-- peekWord64BE :: Ptr Word64 -> IO Word64 peekWord64BE p = case targetByteOrder of LittleEndian -> byteSwap64 <$> peek p @@ -76,6 +117,8 @@ -- | Rechunk a list of bytestrings in multiples of @n@ -- +-- @since 1.0 +-- reChunkN :: Int -> [ByteString] -> [ByteString] reChunkN n = go where @@ -96,3 +139,32 @@ in acc' : go cs' else accum acc' cs {-# INLINE reChunkN #-} + +-- | Padded output capacity, using checked integer arithmetic. +-- +-- @since 1.0 +-- +encodedLength :: Int -> Int +encodedLength n + | n < 0 || blocks > maxBound `quot` 8 = error "Base32 output is too large" + | otherwise = blocks * 8 + where + blocks = n `quot` 5 + if n `rem` 5 == 0 then 0 else 1 +{-# INLINE encodedLength #-} + +-- | Reject '=' in the final @n@ bytes before running the decoder. +-- The caller selects @n@ from the input length and padding policy, preventing +-- existing padding from being accepted when missing padding is added. +-- +-- @since 1.0 +-- +validateLastNPads + :: Int + -> ByteString + -> IO (Either Text ByteString) + -> Either Text ByteString +validateLastNPads n bs io + | BS.elem 0x3d (BS.drop (BS.length bs - n) bs) = + Left (Text.pack "Base32-encoded bytestring has invalid padding") + | otherwise = unsafeDupablePerformIO io +{-# INLINE validateLastNPads #-} diff --git a/src/Data/ByteString/Lazy/Base32.hs b/src/Data/ByteString/Lazy/Base32.hs --- a/src/Data/ByteString/Lazy/Base32.hs +++ b/src/Data/ByteString/Lazy/Base32.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} -- | -- Module : Data.ByteString.Lazy.Base32 --- Copyright : (c) 2019-2023 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -21,30 +23,32 @@ , encodeBase32Unpadded , encodeBase32Unpadded' -- * Decoding +, decodeBase32Untyped +, decodeBase32UnpaddedUntyped +, decodeBase32PaddedUntyped + -- * Validation , decodeBase32 -, decodeBase32Unpadded , decodeBase32Padded ---, decodeBase32Lenient - -- * Validation -, isBase32 -, isValidBase32 +, decodeBase32Unpadded +, parseBase32Padded +, parseBase32Unpadded ) where -import Prelude hiding (all, elem) +import Data.Base32.Types + import qualified Data.ByteString as BS import qualified Data.ByteString.Base32 as B32 import Data.ByteString.Base32.Internal.Utils (reChunkN) -import Data.ByteString.Lazy (elem, fromChunks, toChunks) +import Data.ByteString.Lazy (fromChunks, toChunks) 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 --- | Encode a 'ByteString' value as a Base32 'Text' value with padding. +-- | Encode a 'ByteString' value as a Base32 'TL.Text' value with padding. -- -- See: -- @@ -53,8 +57,10 @@ -- >>> encodeBase32 "Sun" -- "KN2W4===" -- -encodeBase32 :: ByteString -> TL.Text -encodeBase32 = TL.decodeUtf8 . encodeBase32' +-- @since 1.0 +-- +encodeBase32 :: ByteString -> Base32 'StdPadded TL.Text +encodeBase32 = fmap TL.decodeUtf8 . encodeBase32' {-# INLINE encodeBase32 #-} -- | Encode a 'ByteString' as a Base32 'ByteString' value with padding. @@ -63,40 +69,46 @@ -- -- === __Examples__: -- --- >>> encodeBase32 "Sun" +-- >>> encodeBase32' "Sun" -- "KN2W4===" -- -encodeBase32' :: ByteString -> ByteString -encodeBase32' = fromChunks - . fmap B32.encodeBase32' +-- @since 1.0 +-- +encodeBase32' :: ByteString -> Base32 'StdPadded ByteString +encodeBase32' = assertBase32 . fromChunks + . fmap (extractBase32 . B32.encodeBase32') . reChunkN 5 . toChunks --- | Decode an arbitrarily padded Base32 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 Base32-encoded values are optionally padded. +-- | Decode an arbitrarily padded Base32 encoded 'ByteString' value. If its length is not +-- a multiple +-- of 8, then padding chars will be added to fill out the input to a multiple of +-- 8 for safe decoding as Base32-encoded values are optionally padded. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32 "KN2W4===" +-- >>> decodeBase32Untyped "KN2W4===" -- Right "Sun" -- --- >>> decodeBase32 "KN2W4" +-- >>> decodeBase32Untyped "KN2W4" -- Right "Sun" -- --- >>> decodeBase32 "KN2W===" +-- >>> decodeBase32Untyped "KN2W===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32 :: ByteString -> Either T.Text ByteString -decodeBase32 = fmap (fromChunks . (:[])) - . B32.decodeBase32 +-- @since 1.0 +-- +decodeBase32Untyped :: ByteString -> Either T.Text ByteString +decodeBase32Untyped = fmap (fromChunks . (:[])) + . B32.decodeBase32Untyped . BS.concat . toChunks -{-# INLINE decodeBase32 #-} +{-# INLINE decodeBase32Untyped #-} --- | Encode a 'ByteString' value as Base32 'Text' without padding. Note that for Base32, +-- | Encode a 'ByteString' value as Base32 'TL.Text' without padding. +-- Note that for Base32, -- padding is optional. If you call this function, you will simply be encoding -- as Base32 and stripping padding chars from the output. -- @@ -107,8 +119,10 @@ -- >>> encodeBase32Unpadded "Sun" -- "KN2W4" -- -encodeBase32Unpadded :: ByteString -> TL.Text -encodeBase32Unpadded = TL.decodeUtf8 . encodeBase32Unpadded' +-- @since 1.0 +-- +encodeBase32Unpadded :: ByteString -> Base32 'StdUnpadded TL.Text +encodeBase32Unpadded = fmap TL.decodeUtf8 . encodeBase32Unpadded' {-# INLINE encodeBase32Unpadded #-} -- | Encode a 'ByteString' value as Base32 without padding. Note that for Base32, @@ -122,9 +136,11 @@ -- >>> encodeBase32Unpadded' "Sun" -- "KN2W4" -- -encodeBase32Unpadded' :: ByteString -> ByteString -encodeBase32Unpadded' = fromChunks - . fmap B32.encodeBase32Unpadded' +-- @since 1.0 +-- +encodeBase32Unpadded' :: ByteString -> Base32 'StdUnpadded ByteString +encodeBase32Unpadded' = assertBase32 . fromChunks + . fmap (extractBase32 . B32.encodeBase32Unpadded') . reChunkN 5 . toChunks @@ -133,111 +149,139 @@ -- confirm. -- -- In general, unless unpadded Base32 is explicitly required, it is --- safer to call 'decodeBase32'. +-- safer to call 'decodeBase32Untyped'. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Unpadded "KN2W4" +-- >>> decodeBase32UnpaddedUntyped "KN2W4" -- Right "Sun" -- --- >>> decodeBase32Unpadded "KN2W4===" +-- >>> decodeBase32UnpaddedUntyped "KN2W4===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32Unpadded :: ByteString -> Either T.Text ByteString -decodeBase32Unpadded = fmap (fromChunks . (:[])) - . B32.decodeBase32Unpadded +-- @since 1.0 +-- +decodeBase32UnpaddedUntyped :: ByteString -> Either T.Text ByteString +decodeBase32UnpaddedUntyped = fmap (fromChunks . (:[])) + . B32.decodeBase32UnpaddedUntyped . BS.concat . toChunks -{-# INLINE decodeBase32Unpadded #-} +{-# INLINE decodeBase32UnpaddedUntyped #-} -- | Decode a padded Base32-encoded 'ByteString' value. Input strings are -- required to be correctly padded, and will be validated prior to decoding -- to confirm. -- -- In general, unless padded Base32 is explicitly required, it is --- safer to call 'decodeBase32'. +-- safer to call 'decodeBase32Untyped'. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Padded "KN2W4===" +-- >>> decodeBase32PaddedUntyped "KN2W4===" -- Right "Sun" -- --- >>> decodeBase32Padded "KN2W4" +-- >>> decodeBase32PaddedUntyped "KN2W4" -- Left "Base32-encoded bytestring requires padding" -- -decodeBase32Padded :: ByteString -> Either T.Text ByteString -decodeBase32Padded = fmap (fromChunks . (:[])) - . B32.decodeBase32Padded +-- @since 1.0 +-- +decodeBase32PaddedUntyped :: ByteString -> Either T.Text ByteString +decodeBase32PaddedUntyped = fmap (fromChunks . (:[])) + . B32.decodeBase32PaddedUntyped . BS.concat . toChunks -{-# INLINE decodeBase32Padded #-} +{-# INLINE decodeBase32PaddedUntyped #-} --- -- | Leniently decode an unpadded Base32-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. --- -- --- -- __Note:__ This is not RFC 4648-compliant. --- -- --- -- === __Examples__: --- -- --- -- >>> decodeBase32Lenient "PDw_Pj4=" --- -- "<>" --- -- --- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" --- -- "<>" --- -- --- decodeBase32Lenient :: ByteString -> ByteString --- decodeBase32Lenient = fromChunks --- . fmap B32.decodeBase32Lenient --- . reChunkN 8 --- . fmap (BS.filter (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567=")) --- . toChunks --- {-# INLINE decodeBase32Lenient #-} +-- | Decode a typed Base32-encoded 'ByteString' value. +-- +-- This function is padding-agnostic. +-- +-- >>> decodeBase32 (encodeBase32' "Sun") +-- "Sun" +-- +-- >>> decodeBase32 (encodeBase32Unpadded' "Sun") +-- "Sun" +-- +-- @since 1.0 +-- +decodeBase32 :: forall k. StdAlphabet k => Base32 k ByteString -> ByteString +decodeBase32 = fromChunks + . fmap (B32.decodeBase32 + . (assertBase32 :: BS.ByteString -> Base32 k BS.ByteString)) + . reChunkN 8 . toChunks . extractBase32 +{-# INLINE decodeBase32 #-} --- | Tell whether a 'ByteString' is Base32-encoded. +-- | Decode a typed, padded Base32-encoded 'ByteString' value. -- --- === __Examples__: +-- >>> decodeBase32Padded (encodeBase32' "Sun") +-- "Sun" -- --- >>> isBase32 "KN2W4" --- True +-- @since 1.0 -- --- >>> isBase32 "KN2W4===" --- True +decodeBase32Padded :: Base32 'StdPadded ByteString -> ByteString +decodeBase32Padded = decodeBase32 +{-# INLINE decodeBase32Padded #-} + +-- | Parse and validate a base32-encoded value, assuming that it has padding. -- --- >>> isBase32 "KN2W4==" --- False +-- >>> parseBase32Padded "kn2w4===" +-- Right "kn2w4===" -- -isBase32 :: ByteString -> Bool -isBase32 bs = isValidBase32 bs && isRight (decodeBase32 bs) -{-# INLINE isBase32 #-} +-- >>> fmap decodeBase32Padded (parseBase32Padded "KN2W4===") +-- Right "Sun" +-- +-- >>> parseBase32Padded "" +-- Right "" +-- +-- >>> parseBase32Padded "KN2W4" +-- Left "Base32-encoded bytestring requires padding" +-- +-- @since 1.0 +-- +parseBase32Padded :: ByteString -> Either T.Text (Base32 'StdPadded ByteString) +parseBase32Padded value = assertBase32 value + <$ (decodeBase32PaddedUntyped) value +{-# INLINE parseBase32Padded #-} --- | Tell whether a 'ByteString' is a valid Base32 format. +-- | Decode a typed, unpadded Base32-encoded value. -- --- This will not tell you whether or not this is a correct Base32 representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base32 encoded 'ByteString' value, use 'isBase32'. +-- >>> decodeBase32Unpadded (encodeBase32Unpadded' "Sun") +-- "Sun" -- --- === __Examples__: +-- @since 1.0 -- --- >>> isValidBase32 "KN2W4" --- True +decodeBase32Unpadded :: Base32 'StdUnpadded ByteString -> ByteString +decodeBase32Unpadded = decodeBase32 +{-# INLINE decodeBase32Unpadded #-} + +-- | Parse and validate a base32-encoded value, assuming that it is unpadded. -- --- >>> isValidBase32 "KN2W4=" --- False +-- >>> parseBase32Unpadded "kn2w4" +-- Right "kn2w4" -- --- >>> isValidBase32 "KN2W4%" --- False +-- >>> fmap decodeBase32Unpadded (parseBase32Unpadded "KN2W4") +-- Right "Sun" -- -isValidBase32 :: ByteString -> Bool -isValidBase32 = go . toChunks - where - go [] = True - go [c] = B32.isValidBase32 c - go (c:cs) = -- note the lack of padding char - BS.all (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567") c - && go cs -{-# INLINE isValidBase32 #-} +-- >>> parseBase32Unpadded "" +-- Right "" +-- +-- >>> parseBase32Unpadded "KN2W4===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +-- >>> isLeft (parseBase32Unpadded "MZ") +-- True +-- +-- @since 1.0 +-- +parseBase32Unpadded :: ByteString -> Either T.Text (Base32 'StdUnpadded ByteString) +parseBase32Unpadded value = assertBase32 value + <$ (decodeBase32UnpaddedUntyped) value +{-# INLINE parseBase32Unpadded #-} + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> import Data.Either (isLeft) diff --git a/src/Data/ByteString/Lazy/Base32/Hex.hs b/src/Data/ByteString/Lazy/Base32/Hex.hs --- a/src/Data/ByteString/Lazy/Base32/Hex.hs +++ b/src/Data/ByteString/Lazy/Base32/Hex.hs @@ -1,8 +1,10 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE Trustworthy #-} -- | -- Module : Data.ByteString.Lazy.Base32.Hex --- Copyright : (c) 2019-2023 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -21,30 +23,32 @@ , encodeBase32Unpadded , encodeBase32Unpadded' -- * Decoding +, decodeBase32Untyped +, decodeBase32UnpaddedUntyped +, decodeBase32PaddedUntyped + -- * Validation , decodeBase32 -, decodeBase32Unpadded , decodeBase32Padded ---, decodeBase32Lenient - -- * Validation -, isBase32Hex -, isValidBase32Hex +, decodeBase32Unpadded +, parseBase32Padded +, parseBase32Unpadded ) where -import Prelude hiding (all, elem) +import Data.Base32.Types + import qualified Data.ByteString as BS import qualified Data.ByteString.Base32.Hex as B32H import Data.ByteString.Base32.Internal.Utils (reChunkN) -import Data.ByteString.Lazy (elem, fromChunks, toChunks) +import Data.ByteString.Lazy (fromChunks, toChunks) 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 --- | Encode a 'ByteString' value as a Base32hex 'Text' value with padding. +-- | Encode a 'ByteString' value as a Base32hex 'TL.Text' value with padding. -- -- See: -- @@ -53,8 +57,10 @@ -- >>> encodeBase32 "Sun" -- "ADQMS===" -- -encodeBase32 :: ByteString -> TL.Text -encodeBase32 = TL.decodeUtf8 . encodeBase32' +-- @since 1.0 +-- +encodeBase32 :: ByteString -> Base32 'HexPadded TL.Text +encodeBase32 = fmap TL.decodeUtf8 . encodeBase32' {-# INLINE encodeBase32 #-} -- | Encode a 'ByteString' as a Base32hex 'ByteString' value with padding. @@ -66,37 +72,43 @@ -- >>> encodeBase32' "Sun" -- "ADQMS===" -- -encodeBase32' :: ByteString -> ByteString -encodeBase32' = fromChunks - . fmap B32H.encodeBase32' +-- @since 1.0 +-- +encodeBase32' :: ByteString -> Base32 'HexPadded ByteString +encodeBase32' = assertBase32 . fromChunks + . fmap (extractBase32 . B32H.encodeBase32') . reChunkN 5 . toChunks --- | Decode an arbitrarily padded Base32hex 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 Base32hex-encoded values are optionally padded. +-- | Decode an arbitrarily padded Base32hex encoded 'ByteString' value. If its length is +-- not a multiple +-- of 8, then padding chars will be added to fill out the input to a multiple of +-- 8 for safe decoding as Base32hex-encoded values are optionally padded. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32 "ADQMS===" +-- >>> decodeBase32Untyped "ADQMS===" -- Right "Sun" -- --- >>> decodeBase32 "ADQMS" +-- >>> decodeBase32Untyped "ADQMS" -- Right "Sun" -- --- >>> decodeBase32 "ADQMS===" +-- >>> decodeBase32Untyped "ADQM===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32 :: ByteString -> Either T.Text ByteString -decodeBase32 = fmap (fromChunks . (:[])) - . B32H.decodeBase32 +-- @since 1.0 +-- +decodeBase32Untyped :: ByteString -> Either T.Text ByteString +decodeBase32Untyped = fmap (fromChunks . (:[])) + . B32H.decodeBase32Untyped . BS.concat . toChunks -{-# INLINE decodeBase32 #-} +{-# INLINE decodeBase32Untyped #-} --- | Encode a 'ByteString' value as Base32hex 'Text' without padding. Note that for Base32hex, +-- | Encode a 'ByteString' value as Base32hex 'TL.Text' without padding. Note that for +-- Base32hex, -- padding is optional. If you call this function, you will simply be encoding -- as Base32hex and stripping padding chars from the output. -- @@ -107,8 +119,10 @@ -- >>> encodeBase32Unpadded "Sun" -- "ADQMS" -- -encodeBase32Unpadded :: ByteString -> TL.Text -encodeBase32Unpadded = TL.decodeUtf8 . encodeBase32Unpadded' +-- @since 1.0 +-- +encodeBase32Unpadded :: ByteString -> Base32 'HexUnpadded TL.Text +encodeBase32Unpadded = fmap TL.decodeUtf8 . encodeBase32Unpadded' {-# INLINE encodeBase32Unpadded #-} -- | Encode a 'ByteString' value as Base32hex without padding. Note that for Base32hex, @@ -122,9 +136,11 @@ -- >>> encodeBase32Unpadded' "Sun" -- "ADQMS" -- -encodeBase32Unpadded' :: ByteString -> ByteString -encodeBase32Unpadded' = fromChunks - . fmap B32H.encodeBase32Unpadded' +-- @since 1.0 +-- +encodeBase32Unpadded' :: ByteString -> Base32 'HexUnpadded ByteString +encodeBase32Unpadded' = assertBase32 . fromChunks + . fmap (extractBase32 . B32H.encodeBase32Unpadded') . reChunkN 5 . toChunks @@ -133,112 +149,139 @@ -- confirm. -- -- In general, unless unpadded Base32hex is explicitly required, it is --- safer to call 'decodeBase32'. +-- safer to call 'decodeBase32Untyped'. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Unpadded "ADQMS" +-- >>> decodeBase32UnpaddedUntyped "ADQMS" -- Right "Sun" -- --- >>> decodeBase32Unpadded "ADQMS===" +-- >>> decodeBase32UnpaddedUntyped "ADQMS===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32Unpadded :: ByteString -> Either T.Text ByteString -decodeBase32Unpadded = fmap (fromChunks . (:[])) - . B32H.decodeBase32Unpadded +-- @since 1.0 +-- +decodeBase32UnpaddedUntyped :: ByteString -> Either T.Text ByteString +decodeBase32UnpaddedUntyped = fmap (fromChunks . (:[])) + . B32H.decodeBase32UnpaddedUntyped . BS.concat . toChunks -{-# INLINE decodeBase32Unpadded #-} +{-# INLINE decodeBase32UnpaddedUntyped #-} -- | Decode a padded Base32hex-encoded 'ByteString' value. Input strings are -- required to be correctly padded, and will be validated prior to decoding -- to confirm. -- -- In general, unless padded Base32hex is explicitly required, it is --- safer to call 'decodeBase32'. +-- safer to call 'decodeBase32Untyped'. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Padded "ADQMS===" +-- >>> decodeBase32PaddedUntyped "ADQMS===" -- Right "Sun" -- --- >>> decodeBase32Padded "ADQMS" +-- >>> decodeBase32PaddedUntyped "ADQMS" -- Left "Base32-encoded bytestring requires padding" -- -decodeBase32Padded :: ByteString -> Either T.Text ByteString -decodeBase32Padded = fmap (fromChunks . (:[])) - . B32H.decodeBase32Padded +-- @since 1.0 +-- +decodeBase32PaddedUntyped :: ByteString -> Either T.Text ByteString +decodeBase32PaddedUntyped = fmap (fromChunks . (:[])) + . B32H.decodeBase32PaddedUntyped . BS.concat . toChunks -{-# INLINE decodeBase32Padded #-} +{-# INLINE decodeBase32PaddedUntyped #-} --- -- | Leniently decode an unpadded Base32hex-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. --- -- --- -- __Note:__ This is not RFC 4648-compliant. --- -- --- -- === __Examples__: --- -- --- -- >>> decodeBase32Lenient "PDw_Pj4=" --- -- "<>" --- -- --- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" --- -- "<>" --- -- --- decodeBase32Lenient :: ByteString -> ByteString --- decodeBase32Lenient = fromChunks --- . fmap B32H.decodeBase32Lenient --- . reChunkN 8 --- . fmap (BS.filter (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567=")) --- . toChunks --- {-# INLINE decodeBase32Lenient #-} +-- | Decode a typed Base32hex-encoded 'ByteString' value. +-- +-- This function is padding-agnostic. +-- +-- >>> decodeBase32 (encodeBase32' "Sun") +-- "Sun" +-- +-- >>> decodeBase32 (encodeBase32Unpadded' "Sun") +-- "Sun" +-- +-- @since 1.0 +-- +decodeBase32 :: forall k. HexAlphabet k => Base32 k ByteString -> ByteString +decodeBase32 = fromChunks + . fmap (B32H.decodeBase32 + . (assertBase32 :: BS.ByteString -> Base32 k BS.ByteString)) + . reChunkN 8 . toChunks . extractBase32 +{-# INLINE decodeBase32 #-} --- | Tell whether a 'ByteString' is Base32hex-encoded. +-- | Decode a typed, padded Base32hex-encoded 'ByteString' value. -- --- === __Examples__: +-- >>> decodeBase32Padded (encodeBase32' "Sun") +-- "Sun" -- --- >>> isBase32Hex "ADQMS" --- True +-- @since 1.0 -- --- >>> isBase32Hex "ADQMS===" --- True +decodeBase32Padded :: Base32 'HexPadded ByteString -> ByteString +decodeBase32Padded = decodeBase32 +{-# INLINE decodeBase32Padded #-} + +-- | Parse and validate a base32hex-encoded value, assuming that it has padding. -- --- >>> isBase32Hex "ADQMS==" --- False +-- >>> parseBase32Padded "adqms===" +-- Right "adqms===" -- -isBase32Hex :: ByteString -> Bool -isBase32Hex bs = isValidBase32Hex bs && isRight (decodeBase32 bs) -{-# INLINE isBase32Hex #-} +-- >>> fmap decodeBase32Padded (parseBase32Padded "ADQMS===") +-- Right "Sun" +-- +-- >>> parseBase32Padded "" +-- Right "" +-- +-- >>> parseBase32Padded "ADQMS" +-- Left "Base32-encoded bytestring requires padding" +-- +-- @since 1.0 +-- +parseBase32Padded :: ByteString -> Either T.Text (Base32 'HexPadded ByteString) +parseBase32Padded value = assertBase32 value + <$ (decodeBase32PaddedUntyped) value +{-# INLINE parseBase32Padded #-} --- | Tell whether a 'ByteString' is a valid Base32hex format. +-- | Decode a typed, unpadded Base32hex-encoded value. -- --- This will not tell you whether or not this is a correct Base32hex representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base32hex encoded 'ByteString' value, use 'isBase32Hex'. +-- >>> decodeBase32Unpadded (encodeBase32Unpadded' "Sun") +-- "Sun" -- --- === __Examples__: +-- @since 1.0 -- +decodeBase32Unpadded :: Base32 'HexUnpadded ByteString -> ByteString +decodeBase32Unpadded = decodeBase32 +{-# INLINE decodeBase32Unpadded #-} + +-- | Parse and validate a base32hex-encoded value, assuming that it is unpadded. -- --- >>> isValidBase32Hex "ADQMS" --- True +-- >>> parseBase32Unpadded "adqms" +-- Right "adqms" -- --- >>> isValidBase32Hex "ADQMS=" --- False +-- >>> fmap decodeBase32Unpadded (parseBase32Unpadded "ADQMS") +-- Right "Sun" -- --- >>> isValidBase32Hex "ADQMS%" --- False +-- >>> parseBase32Unpadded "" +-- Right "" -- -isValidBase32Hex :: ByteString -> Bool -isValidBase32Hex = go . toChunks - where - go [] = True - go [c] = B32H.isValidBase32Hex c - go (c:cs) = -- note the lack of padding char - BS.all (flip elem "0123456789ABCDEFGHIJKLMNOPQRSTUV") c - && go cs -{-# INLINE isValidBase32Hex #-} +-- >>> parseBase32Unpadded "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +-- >>> isLeft (parseBase32Unpadded "CP") +-- True +-- +-- @since 1.0 +-- +parseBase32Unpadded :: ByteString -> Either T.Text (Base32 'HexUnpadded ByteString) +parseBase32Unpadded value = assertBase32 value + <$ (decodeBase32UnpaddedUntyped) value +{-# INLINE parseBase32Unpadded #-} + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> import Data.Either (isLeft) diff --git a/src/Data/ByteString/Short/Base32.hs b/src/Data/ByteString/Short/Base32.hs --- a/src/Data/ByteString/Short/Base32.hs +++ b/src/Data/ByteString/Short/Base32.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Trustworthy #-} -- | -- Module : Data.ByteString.Short.Base32 --- Copyright : (c) 2019-2023 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -20,19 +23,26 @@ , encodeBase32Unpadded , encodeBase32Unpadded' -- * Decoding +, decodeBase32Untyped +, decodeBase32UnpaddedUntyped +, decodeBase32PaddedUntyped + -- * Validation , decodeBase32 -, decodeBase32Unpadded , decodeBase32Padded ---, decodeBase32Lenient - -- * Validation -, isBase32 -, isValidBase32 +, decodeBase32Unpadded +, parseBase32Padded +, parseBase32Unpadded ) where -import qualified Data.ByteString.Base32 as B32 -import Data.ByteString.Short (ShortByteString, fromShort, toShort) +import Data.ByteString.Base32.Internal.Short +import Data.ByteString.Base32.Internal.Tables +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as SBS +import Data.Base32.Types + import Data.Text (Text) +import qualified Data.Text as Text import Data.Text.Short (ShortText) import Data.Text.Short.Unsafe (fromShortByteStringUnsafe) @@ -46,8 +56,10 @@ -- >>> encodeBase32 "Sun" -- "KN2W4===" -- -encodeBase32 :: ShortByteString -> ShortText -encodeBase32 = fromShortByteStringUnsafe . encodeBase32' +-- @since 1.0 +-- +encodeBase32 :: ShortByteString -> Base32 'StdPadded ShortText +encodeBase32 = fmap fromShortByteStringUnsafe . encodeBase32' {-# INLINE encodeBase32 #-} -- | Encode a 'ShortByteString' as a Base32 'ShortByteString' value with padding. @@ -59,32 +71,53 @@ -- >>> encodeBase32' "Sun" -- "KN2W4===" -- -encodeBase32' :: ShortByteString -> ShortByteString -encodeBase32' = toShort . B32.encodeBase32' . fromShort +-- @since 1.0 +-- +encodeBase32' :: ShortByteString -> Base32 'StdPadded ShortByteString +encodeBase32' = + assertBase32 + . encodeShort + "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# + True --- | Decode an arbitrarily padded Base32 encoded 'ShortByteString' 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 Base32-encoded values are optionally padded. +-- | Decode an arbitrarily padded Base32 encoded 'ShortByteString' value. If its length is +-- not a multiple +-- of 8, then padding chars will be added to fill out the input to a multiple of +-- 8 for safe decoding as Base32-encoded values are optionally padded. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32 "KN2W4===" +-- >>> decodeBase32Untyped "KN2W4===" -- Right "Sun" -- --- >>> decodeBase32 "KN2W4" +-- >>> decodeBase32Untyped "KN2W4" -- Right "Sun" -- --- >>> decodeBase32 "KN2W===" +-- >>> decodeBase32Untyped "KN2W===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32 :: ShortByteString -> Either Text ShortByteString -decodeBase32 = fmap toShort . B32.decodeBase32 . fromShort - -{-# INLINE decodeBase32 #-} +-- @since 1.0 +-- +decodeBase32Untyped :: ShortByteString -> Either Text ShortByteString +decodeBase32Untyped bs + | l == 0 = Right bs + | r == 1 || r == 3 || r == 6 = + Left (Text.pack "Base32-encoded bytestring has invalid size") + | r == 4 && any isPad [1 .. 2] + || r == 5 && any isPad [1 .. 3] + || r == 7 && any isPad [1 .. 5] = + Left (Text.pack "Base32-encoded bytestring has invalid padding") + | otherwise = decodeShort stdDecodeTable bs + where + l = SBS.length bs + r = l `rem` 8 + isPad i = SBS.index bs (l - i) == 0x3d +{-# INLINE decodeBase32Untyped #-} --- | Encode a 'ShortByteString' value as Base32 'Text' without padding. Note that for Base32, +-- | Encode a 'ShortByteString' value as Base32 'Text' without padding. Note that for +-- Base32, -- padding is optional. If you call this function, you will simply be encoding -- as Base32 and stripping padding chars from the output. -- @@ -95,8 +128,10 @@ -- >>> encodeBase32Unpadded "Sun" -- "KN2W4" -- -encodeBase32Unpadded :: ShortByteString -> ShortText -encodeBase32Unpadded = fromShortByteStringUnsafe . encodeBase32Unpadded' +-- @since 1.0 +-- +encodeBase32Unpadded :: ShortByteString -> Base32 'StdUnpadded ShortText +encodeBase32Unpadded = fmap fromShortByteStringUnsafe . encodeBase32Unpadded' {-# INLINE encodeBase32Unpadded #-} -- | Encode a 'ShortByteString' value as Base32 without padding. Note that for Base32, @@ -110,103 +145,162 @@ -- >>> encodeBase32Unpadded' "Sun" -- "KN2W4" -- -encodeBase32Unpadded' :: ShortByteString -> ShortByteString -encodeBase32Unpadded' = toShort . B32.encodeBase32Unpadded' . fromShort +-- @since 1.0 +-- +encodeBase32Unpadded' :: ShortByteString -> Base32 'StdUnpadded ShortByteString +encodeBase32Unpadded' = + assertBase32 + . encodeShort + "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# + False -- | Decode an unpadded Base32-encoded 'ShortByteString' value. Input strings are -- required to be unpadded, and will undergo validation prior to decoding to -- confirm. -- -- In general, unless unpadded Base32 is explicitly required, it is --- safer to call 'decodeBase32'. +-- safer to call 'decodeBase32Untyped'. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Unpadded "KN2W4" +-- >>> decodeBase32UnpaddedUntyped "KN2W4" -- Right "Sun" -- --- >>> decodeBase32Unpadded "KN2W4===" +-- >>> decodeBase32UnpaddedUntyped "KN2W4===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32Unpadded :: ShortByteString -> Either Text ShortByteString -decodeBase32Unpadded = fmap toShort . B32.decodeBase32Unpadded . fromShort -{-# INLINE decodeBase32Unpadded #-} +-- @since 1.0 +-- +decodeBase32UnpaddedUntyped :: ShortByteString -> Either Text ShortByteString +decodeBase32UnpaddedUntyped bs + | l == 0 = Right bs + | r == 1 || r == 3 || r == 6 = + Left (Text.pack "Base32-encoded bytestring has invalid size") + | r /= 2 && SBS.index bs (l - 1) == 0x3d = + Left (Text.pack "Base32-encoded bytestring has invalid padding") + | otherwise = decodeShort stdDecodeTable bs + where + l = SBS.length bs + r = l `rem` 8 +{-# INLINE decodeBase32UnpaddedUntyped #-} -- | Decode a padded Base32-encoded 'ShortByteString' value. Input strings are -- required to be correctly padded, and will be validated prior to decoding -- to confirm. -- -- In general, unless padded Base32 is explicitly required, it is --- safer to call 'decodeBase32'. +-- safer to call 'decodeBase32Untyped'. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Padded "KN2W4===" +-- >>> decodeBase32PaddedUntyped "KN2W4===" -- Right "Sun" -- --- >>> decodeBase32Padded "KN2W4" +-- >>> decodeBase32PaddedUntyped "KN2W4" -- Left "Base32-encoded bytestring requires padding" -- -decodeBase32Padded :: ShortByteString -> Either Text ShortByteString -decodeBase32Padded = fmap toShort . B32.decodeBase32Padded . fromShort -{-# INLINE decodeBase32Padded #-} +-- @since 1.0 +-- +decodeBase32PaddedUntyped :: ShortByteString -> Either Text ShortByteString +decodeBase32PaddedUntyped bs + | l == 0 = Right bs + | r == 1 || r == 3 || r == 6 = + Left (Text.pack "Base32-encoded bytestring has invalid size") + | r /= 0 = Left (Text.pack "Base32-encoded bytestring requires padding") + | otherwise = decodeShort stdDecodeTable bs + where + l = SBS.length bs + r = l `rem` 8 +{-# INLINE decodeBase32PaddedUntyped #-} --- -- | Leniently decode an unpadded Base32-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. --- -- --- -- __Note:__ This is not RFC 4648-compliant. --- -- --- -- === __Examples__: --- -- --- -- >>> decodeBase32Lenient "PDw_Pj4=" --- -- "<>" --- -- --- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" --- -- "<>" --- -- --- decodeBase32Lenient :: ShortByteString -> ShortByteString --- decodeBase32Lenient = toShort . B32.decodeBase32Lenient . fromShort --- {-# INLINE decodeBase32Lenient #-} +-- | Decode a typed Base32-encoded 'ShortByteString' value. +-- +-- This function is padding-agnostic. +-- +-- >>> decodeBase32 (encodeBase32' "Sun") +-- "Sun" +-- +-- >>> decodeBase32 (encodeBase32Unpadded' "Sun") +-- "Sun" +-- +-- @since 1.0 +-- +decodeBase32 :: StdAlphabet k => Base32 k ShortByteString -> ShortByteString +decodeBase32 = decodeShortTyped stdDecodeTable +{-# INLINE decodeBase32 #-} --- | Tell whether a 'ShortByteString' is Base32-encoded. +-- | Decode a typed, padded Base32-encoded 'ShortByteString' value. -- --- === __Examples__: +-- >>> decodeBase32Padded (encodeBase32' "Sun") +-- "Sun" -- --- >>> isBase32 "KN2W4" --- True +-- @since 1.0 -- --- >>> isBase32 "KN2W4===" --- True +decodeBase32Padded :: Base32 'StdPadded ShortByteString -> ShortByteString +decodeBase32Padded = decodeBase32 +{-# INLINE decodeBase32Padded #-} + +-- | Parse and validate a base32-encoded value, assuming that it has padding. -- --- >>> isBase32 "KN2W4==" --- False +-- >>> parseBase32Padded "kn2w4===" +-- Right "kn2w4===" -- -isBase32 :: ShortByteString -> Bool -isBase32 = B32.isBase32 . fromShort -{-# INLINE isBase32 #-} +-- >>> fmap decodeBase32Padded (parseBase32Padded "KN2W4===") +-- Right "Sun" +-- +-- >>> parseBase32Padded "" +-- Right "" +-- +-- >>> parseBase32Padded "KN2W4" +-- Left "Base32-encoded bytestring requires padding" +-- +-- @since 1.0 +-- +parseBase32Padded :: ShortByteString -> Either Text (Base32 'StdPadded ShortByteString) +parseBase32Padded value = assertBase32 value + <$ (decodeBase32PaddedUntyped) value +{-# INLINE parseBase32Padded #-} --- | Tell whether a 'ShortByteString' is a valid Base32 format. +-- | Decode a typed, unpadded Base32-encoded value. -- --- This will not tell you whether or not this is a correct Base32 representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base32 encoded 'ShortByteString' value, use 'isBase32'. +-- >>> decodeBase32Unpadded (encodeBase32Unpadded' "Sun") +-- "Sun" -- --- === __Examples__: +-- @since 1.0 -- --- >>> isValidBase32 "KN2W4" --- True +decodeBase32Unpadded :: Base32 'StdUnpadded ShortByteString -> ShortByteString +decodeBase32Unpadded = decodeBase32 +{-# INLINE decodeBase32Unpadded #-} + +-- | Parse and validate a base32-encoded value, assuming that it is unpadded. -- --- >>> isValidBase32 "KN2W4=" --- False +-- >>> parseBase32Unpadded "kn2w4" +-- Right "kn2w4" -- --- >>> isValidBase32 "KN2W4%" --- False +-- >>> fmap decodeBase32Unpadded (parseBase32Unpadded "KN2W4") +-- Right "Sun" -- -isValidBase32 :: ShortByteString -> Bool -isValidBase32 = B32.isValidBase32 . fromShort -{-# INLINE isValidBase32 #-} +-- >>> parseBase32Unpadded "" +-- Right "" +-- +-- >>> parseBase32Unpadded "KN2W4===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +-- >>> isLeft (parseBase32Unpadded "MZ") +-- True +-- +-- @since 1.0 +-- +parseBase32Unpadded + :: ShortByteString -> Either Text (Base32 'StdUnpadded ShortByteString) +parseBase32Unpadded value = assertBase32 value + <$ (decodeBase32UnpaddedUntyped) value +{-# INLINE parseBase32Unpadded #-} + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> import Data.Either (isLeft) diff --git a/src/Data/ByteString/Short/Base32/Hex.hs b/src/Data/ByteString/Short/Base32/Hex.hs --- a/src/Data/ByteString/Short/Base32/Hex.hs +++ b/src/Data/ByteString/Short/Base32/Hex.hs @@ -1,7 +1,10 @@ +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Trustworthy #-} -- | -- Module : Data.ByteString.Short.Base32.Hex --- Copyright : (c) 2019-2023 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -20,19 +23,26 @@ , encodeBase32Unpadded , encodeBase32Unpadded' -- * Decoding +, decodeBase32Untyped +, decodeBase32UnpaddedUntyped +, decodeBase32PaddedUntyped + -- * Validation , decodeBase32 -, decodeBase32Unpadded , decodeBase32Padded ---, decodeBase32Lenient - -- * Validation -, isBase32Hex -, isValidBase32Hex +, decodeBase32Unpadded +, parseBase32Padded +, parseBase32Unpadded ) where -import qualified Data.ByteString.Base32.Hex as B32H -import Data.ByteString.Short (ShortByteString, fromShort, toShort) +import Data.ByteString.Base32.Internal.Short +import Data.ByteString.Base32.Internal.Tables +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as SBS +import Data.Base32.Types + import Data.Text (Text) +import qualified Data.Text as Text import Data.Text.Short (ShortText) import Data.Text.Short.Unsafe (fromShortByteStringUnsafe) @@ -45,8 +55,10 @@ -- >>> encodeBase32 "Sun" -- "ADQMS===" -- -encodeBase32 :: ShortByteString -> ShortText -encodeBase32 = fromShortByteStringUnsafe . encodeBase32' +-- @since 1.0 +-- +encodeBase32 :: ShortByteString -> Base32 'HexPadded ShortText +encodeBase32 = fmap fromShortByteStringUnsafe . encodeBase32' {-# INLINE encodeBase32 #-} -- | Encode a 'ShortByteString' as a Base32hex 'ShortByteString' value with padding. @@ -58,31 +70,53 @@ -- >>> encodeBase32' "Sun" -- "ADQMS===" -- -encodeBase32' :: ShortByteString -> ShortByteString -encodeBase32' = toShort . B32H.encodeBase32' . fromShort +-- @since 1.0 +-- +encodeBase32' :: ShortByteString -> Base32 'HexPadded ShortByteString +encodeBase32' = + assertBase32 + . encodeShort + "0123456789ABCDEFGHIJKLMNOPQRSTUV"# + True --- | Decode an arbitrarily padded Base32hex encoded 'ShortByteString' 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 Base32hex-encoded values are optionally padded. +-- | Decode an arbitrarily padded Base32hex encoded 'ShortByteString' value. If its length +-- is not a multiple +-- of 8, then padding chars will be added to fill out the input to a multiple of +-- 8 for safe decoding as Base32hex-encoded values are optionally padded. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32 "ADQMS===" +-- >>> decodeBase32Untyped "ADQMS===" -- Right "Sun" -- --- >>> decodeBase32 "ADQMS" +-- >>> decodeBase32Untyped "ADQMS" -- Right "Sun" -- --- >>> decodeBase32 "ADQM===" +-- >>> decodeBase32Untyped "ADQM===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32 :: ShortByteString -> Either Text ShortByteString -decodeBase32 = fmap toShort . B32H.decodeBase32 . fromShort -{-# INLINE decodeBase32 #-} +-- @since 1.0 +-- +decodeBase32Untyped :: ShortByteString -> Either Text ShortByteString +decodeBase32Untyped bs + | l == 0 = Right bs + | r == 1 || r == 3 || r == 6 = + Left (Text.pack "Base32-encoded bytestring has invalid size") + | r == 4 && any isPad [1 .. 2] + || r == 5 && any isPad [1 .. 3] + || r == 7 && any isPad [1 .. 5] = + Left (Text.pack "Base32-encoded bytestring has invalid padding") + | otherwise = decodeShort hexDecodeTable bs + where + l = SBS.length bs + r = l `rem` 8 + isPad i = SBS.index bs (l - i) == 0x3d +{-# INLINE decodeBase32Untyped #-} --- | Encode a 'ShortByteString' value as Base32hex 'Text' without padding. Note that for Base32hex, +-- | Encode a 'ShortByteString' value as Base32hex 'Text' without padding. Note that for +-- Base32hex, -- padding is optional. If you call this function, you will simply be encoding -- as Base32hex and stripping padding chars from the output. -- @@ -90,14 +124,17 @@ -- -- === __Examples__: -- --- >>> encodeBase32Unpadded' "Sun" +-- >>> encodeBase32Unpadded "Sun" -- "ADQMS" -- -encodeBase32Unpadded :: ShortByteString -> ShortText -encodeBase32Unpadded = fromShortByteStringUnsafe . encodeBase32Unpadded' +-- @since 1.0 +-- +encodeBase32Unpadded :: ShortByteString -> Base32 'HexUnpadded ShortText +encodeBase32Unpadded = fmap fromShortByteStringUnsafe . encodeBase32Unpadded' {-# INLINE encodeBase32Unpadded #-} --- | Encode a 'ShortByteString' value as Base32hex without padding. Note that for Base32hex, +-- | Encode a 'ShortByteString' value as Base32hex without padding. Note that for +-- Base32hex, -- padding is optional. If you call this function, you will simply be encoding -- as Base32hex and stripping padding chars from the output. -- @@ -108,103 +145,162 @@ -- >>> encodeBase32Unpadded' "Sun" -- "ADQMS" -- -encodeBase32Unpadded' :: ShortByteString -> ShortByteString -encodeBase32Unpadded' = toShort . B32H.encodeBase32Unpadded' . fromShort +-- @since 1.0 +-- +encodeBase32Unpadded' :: ShortByteString -> Base32 'HexUnpadded ShortByteString +encodeBase32Unpadded' = + assertBase32 + . encodeShort + "0123456789ABCDEFGHIJKLMNOPQRSTUV"# + False -- | Decode an unpadded Base32hex-encoded 'ShortByteString' value. Input strings are -- required to be unpadded, and will undergo validation prior to decoding to -- confirm. -- -- In general, unless unpadded Base32hex is explicitly required, it is --- safer to call 'decodeBase32'. +-- safer to call 'decodeBase32Untyped'. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Unpadded "ADQMS" +-- >>> decodeBase32UnpaddedUntyped "ADQMS" -- Right "Sun" -- --- >>> decodeBase32Unpadded "ADQMS===" +-- >>> decodeBase32UnpaddedUntyped "ADQMS===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32Unpadded :: ShortByteString -> Either Text ShortByteString -decodeBase32Unpadded = fmap toShort . B32H.decodeBase32Unpadded . fromShort -{-# INLINE decodeBase32Unpadded #-} +-- @since 1.0 +-- +decodeBase32UnpaddedUntyped :: ShortByteString -> Either Text ShortByteString +decodeBase32UnpaddedUntyped bs + | l == 0 = Right bs + | r == 1 || r == 3 || r == 6 = + Left (Text.pack "Base32-encoded bytestring has invalid size") + | r /= 2 && SBS.index bs (l - 1) == 0x3d = + Left (Text.pack "Base32-encoded bytestring has invalid padding") + | otherwise = decodeShort hexDecodeTable bs + where + l = SBS.length bs + r = l `rem` 8 +{-# INLINE decodeBase32UnpaddedUntyped #-} -- | Decode a padded Base32hex-encoded 'ShortByteString' value. Input strings are -- required to be correctly padded, and will be validated prior to decoding -- to confirm. -- -- In general, unless padded Base32hex is explicitly required, it is --- safer to call 'decodeBase32'. +-- safer to call 'decodeBase32Untyped'. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Padded "ADQMS===" +-- >>> decodeBase32PaddedUntyped "ADQMS===" -- Right "Sun" -- --- >>> decodeBase32Padded "ADQMS" +-- >>> decodeBase32PaddedUntyped "ADQMS" -- Left "Base32-encoded bytestring requires padding" -- -decodeBase32Padded :: ShortByteString -> Either Text ShortByteString -decodeBase32Padded = fmap toShort . B32H.decodeBase32Padded . fromShort -{-# INLINE decodeBase32Padded #-} +-- @since 1.0 +-- +decodeBase32PaddedUntyped :: ShortByteString -> Either Text ShortByteString +decodeBase32PaddedUntyped bs + | l == 0 = Right bs + | r == 1 || r == 3 || r == 6 = + Left (Text.pack "Base32-encoded bytestring has invalid size") + | r /= 0 = Left (Text.pack "Base32-encoded bytestring requires padding") + | otherwise = decodeShort hexDecodeTable bs + where + l = SBS.length bs + r = l `rem` 8 +{-# INLINE decodeBase32PaddedUntyped #-} --- -- | Leniently decode an unpadded Base32hex-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. --- -- --- -- __Note:__ This is not RFC 4648-compliant. --- -- --- -- === __Examples__: --- -- --- -- >>> decodeBase32Lenient "PDw_Pj4=" --- -- "<>" --- -- --- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" --- -- "<>" --- -- --- decodeBase32Lenient :: ShortByteString -> ShortByteString --- decodeBase32Lenient = toShort . B32H.decodeBase32Lenient . fromShort --- {-# INLINE decodeBase32Lenient #-} +-- | Decode a typed Base32hex-encoded 'ShortByteString' value. +-- +-- This function is padding-agnostic. +-- +-- >>> decodeBase32 (encodeBase32' "Sun") +-- "Sun" +-- +-- >>> decodeBase32 (encodeBase32Unpadded' "Sun") +-- "Sun" +-- +-- @since 1.0 +-- +decodeBase32 :: HexAlphabet k => Base32 k ShortByteString -> ShortByteString +decodeBase32 = decodeShortTyped hexDecodeTable +{-# INLINE decodeBase32 #-} --- | Tell whether a 'ShortByteString' is Base32hex-encoded. +-- | Decode a typed, padded Base32hex-encoded 'ShortByteString' value. -- --- === __Examples__: +-- >>> decodeBase32Padded (encodeBase32' "Sun") +-- "Sun" -- --- >>> isBase32Hex "ADQMS" --- True +-- @since 1.0 -- --- >>> isBase32Hex "ADQMS===" --- True +decodeBase32Padded :: Base32 'HexPadded ShortByteString -> ShortByteString +decodeBase32Padded = decodeBase32 +{-# INLINE decodeBase32Padded #-} + +-- | Parse and validate a base32hex-encoded value, assuming that it has padding. -- --- >>> isBase32Hex "ADQMS==" --- False +-- >>> parseBase32Padded "adqms===" +-- Right "adqms===" -- -isBase32Hex :: ShortByteString -> Bool -isBase32Hex = B32H.isBase32Hex . fromShort -{-# INLINE isBase32Hex #-} +-- >>> fmap decodeBase32Padded (parseBase32Padded "ADQMS===") +-- Right "Sun" +-- +-- >>> parseBase32Padded "" +-- Right "" +-- +-- >>> parseBase32Padded "ADQMS" +-- Left "Base32-encoded bytestring requires padding" +-- +-- @since 1.0 +-- +parseBase32Padded :: ShortByteString -> Either Text (Base32 'HexPadded ShortByteString) +parseBase32Padded value = assertBase32 value + <$ (decodeBase32PaddedUntyped) value +{-# INLINE parseBase32Padded #-} --- | Tell whether a 'ShortByteString' is a valid Base32hex format. +-- | Decode a typed, unpadded Base32hex-encoded value. -- --- This will not tell you whether or not this is a correct Base32hex representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base32 encoded 'ShortByteString' value, use 'isBase32Hex'. +-- >>> decodeBase32Unpadded (encodeBase32Unpadded' "Sun") +-- "Sun" -- --- === __Examples__: +-- @since 1.0 -- --- >>> isValidBase32Hex "ADQMS" --- True +decodeBase32Unpadded :: Base32 'HexUnpadded ShortByteString -> ShortByteString +decodeBase32Unpadded = decodeBase32 +{-# INLINE decodeBase32Unpadded #-} + +-- | Parse and validate a base32hex-encoded value, assuming that it is unpadded. -- --- >>> isValidBase32Hex "ADQMS=" --- False +-- >>> parseBase32Unpadded "adqms" +-- Right "adqms" -- --- >>> isValidBase32Hex "ADQMS%" --- False +-- >>> fmap decodeBase32Unpadded (parseBase32Unpadded "ADQMS") +-- Right "Sun" -- -isValidBase32Hex :: ShortByteString -> Bool -isValidBase32Hex = B32H.isValidBase32Hex . fromShort -{-# INLINE isValidBase32Hex #-} +-- >>> parseBase32Unpadded "" +-- Right "" +-- +-- >>> parseBase32Unpadded "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +-- >>> isLeft (parseBase32Unpadded "CP") +-- True +-- +-- @since 1.0 +-- +parseBase32Unpadded + :: ShortByteString -> Either Text (Base32 'HexUnpadded ShortByteString) +parseBase32Unpadded value = assertBase32 value + <$ (decodeBase32UnpaddedUntyped) value +{-# INLINE parseBase32Unpadded #-} + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> import Data.Either (isLeft) diff --git a/src/Data/Text/Encoding/Base32.hs b/src/Data/Text/Encoding/Base32.hs --- a/src/Data/Text/Encoding/Base32.hs +++ b/src/Data/Text/Encoding/Base32.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Safe #-} -- | -- Module : Data.Text.Encoding.Base32 --- Copyright : (c) 2019-2023 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -15,19 +17,24 @@ -- module Data.Text.Encoding.Base32 ( encodeBase32 -, decodeBase32 +, decodeBase32Untyped , decodeBase32With , encodeBase32Unpadded -, decodeBase32Unpadded +, decodeBase32UnpaddedUntyped , decodeBase32UnpaddedWith -, decodeBase32Padded +, decodeBase32PaddedUntyped , decodeBase32PaddedWith --- , decodeBase32Lenient -, isBase32 -, isValidBase32 +, decodeBase32 +, decodeBase32Padded +, decodeBase32Unpadded +, parseBase32Padded +, parseBase32Unpadded ) where +import Data.Base32.Types +import qualified Data.Text as ErrorText + import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString.Base32 as B32 @@ -45,59 +52,65 @@ -- >>> encodeBase32 "Sun" -- "KN2W4===" -- -encodeBase32 :: Text -> Text +-- @since 1.0 +-- +encodeBase32 :: Text -> Base32 'StdPadded Text encodeBase32 = B32.encodeBase32 . T.encodeUtf8 {-# INLINE encodeBase32 #-} --- | Decode an arbitrarily padded Base32-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 base32 encodings are optionally padded. +-- | Decode an arbitrarily padded Base32-encoded 'Text' value. If its length is not a +-- multiple +-- of 8, then padding chars will be added to fill out the input to a multiple of +-- 8 for safe decoding as base32 encodings are optionally padded. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32With` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32 "KN2W4===" +-- >>> decodeBase32Untyped "KN2W4===" -- Right "Sun" -- --- >>> decodeBase32 "KN2W4" +-- >>> decodeBase32Untyped "KN2W4" -- Right "Sun" -- --- >>> decodeBase32 "KN2W===" +-- >>> decodeBase32Untyped "KN2W===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32 :: Text -> Either Text Text -decodeBase32 = fmap T.decodeUtf8 - . B32.decodeBase32 - . T.encodeUtf8 -{-# INLINE decodeBase32 #-} +-- @since 1.0 +-- +decodeBase32Untyped :: Text -> Either Text Text +decodeBase32Untyped value = B32.decodeBase32Untyped (T.encodeUtf8 value) + >>= first (ErrorText.pack . show) . T.decodeUtf8' +{-# INLINE decodeBase32Untyped #-} -- | Attempt to decode a 'Text' value as Base32, converting from -- 'ByteString' to 'Text' according to some encoding function. In practice, --- This is something like 'decodeUtf8'', which may produce an error. +-- This is something like 'T.decodeUtf8'', which may produce an error. -- -- See: -- -- === __Example__: -- --- @ --- 'decodeBase32With' 'T.decodeUtf8'' --- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' --- @ +-- >>> decodeBase32With UTF8.decodeUtf8' "KN2W4===" +-- Right "Sun" -- +-- >>> decodeBase32With UTF8.decodeUtf8' "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32With (const (Left "unsupported encoding")) "KN2W4===" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32With :: (ByteString -> Either err Text) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base32Error err) Text -decodeBase32With f t = case B32.decodeBase32 t of +decodeBase32With f t = case B32.decodeBase32Untyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32With #-} @@ -111,54 +124,59 @@ -- >>> encodeBase32Unpadded "Sun" -- "KN2W4" -- -encodeBase32Unpadded :: Text -> Text +-- @since 1.0 +-- +encodeBase32Unpadded :: Text -> Base32 'StdUnpadded Text encodeBase32Unpadded = B32.encodeBase32Unpadded . T.encodeUtf8 {-# INLINE encodeBase32Unpadded #-} -- | Decode an unpadded Base32 encoded 'Text' value. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32WUnpaddedWith` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Unpadded "KN2W4" +-- >>> decodeBase32UnpaddedUntyped "KN2W4" -- Right "Sun" -- --- >>> decodeBase32Unpadded "KN2W4===" +-- >>> decodeBase32UnpaddedUntyped "KN2W4===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32Unpadded :: Text -> Either Text Text -decodeBase32Unpadded = fmap T.decodeUtf8 - . B32.decodeBase32Unpadded - . T.encodeUtf8 -{-# INLINE decodeBase32Unpadded #-} +-- @since 1.0 +-- +decodeBase32UnpaddedUntyped :: Text -> Either Text Text +decodeBase32UnpaddedUntyped value = B32.decodeBase32UnpaddedUntyped (T.encodeUtf8 value) + >>= first (ErrorText.pack . show) . T.decodeUtf8' +{-# INLINE decodeBase32UnpaddedUntyped #-} -- | Attempt to decode an unpadded 'ByteString' value as Base32, converting from -- 'ByteString' to 'Text' according to some encoding function. In practice, --- This is something like 'decodeUtf8'', which may produce an error. +-- This is something like 'T.decodeUtf8'', which may produce an error. -- -- See: -- -- === __Example__: -- --- @ --- 'decodeBase32UnpaddedWith' 'T.decodeUtf8'' --- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' --- @ +-- >>> decodeBase32UnpaddedWith UTF8.decodeUtf8' "KN2W4" +-- Right "Sun" -- +-- >>> decodeBase32UnpaddedWith UTF8.decodeUtf8' "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32UnpaddedWith (const (Left "unsupported encoding")) "KN2W4" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32UnpaddedWith :: (ByteString -> Either err Text) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base32Error err) Text -decodeBase32UnpaddedWith f t = case B32.decodeBase32Unpadded t of +decodeBase32UnpaddedWith f t = case B32.decodeBase32UnpaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32UnpaddedWith #-} @@ -166,98 +184,144 @@ -- | Decode an padded Base32 encoded 'Text' value -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32PaddedWith` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Padded "KN2W4===" +-- >>> decodeBase32PaddedUntyped "KN2W4===" -- Right "Sun" -- --- >>> decodeBase32Padded "KN2W4" +-- >>> decodeBase32PaddedUntyped "KN2W4" -- Left "Base32-encoded bytestring requires padding" -- -decodeBase32Padded :: Text -> Either Text Text -decodeBase32Padded = fmap T.decodeUtf8 - . B32.decodeBase32Padded - . T.encodeUtf8 -{-# INLINE decodeBase32Padded #-} +-- @since 1.0 +-- +decodeBase32PaddedUntyped :: Text -> Either Text Text +decodeBase32PaddedUntyped value = B32.decodeBase32PaddedUntyped (T.encodeUtf8 value) + >>= first (ErrorText.pack . show) . T.decodeUtf8' +{-# INLINE decodeBase32PaddedUntyped #-} -- | Attempt to decode a padded 'ByteString' value as Base32, converting from -- 'ByteString' to 'Text' according to some encoding function. In practice, --- This is something like 'decodeUtf8'', which may produce an error. +-- This is something like 'T.decodeUtf8'', which may produce an error. -- -- See: -- -- === __Example__: -- --- @ --- 'decodeBase32PaddedWith' 'T.decodeUtf8'' --- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' --- @ +-- >>> decodeBase32PaddedWith UTF8.decodeUtf8' "KN2W4===" +-- Right "Sun" -- +-- >>> decodeBase32PaddedWith UTF8.decodeUtf8' "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32PaddedWith (const (Left "unsupported encoding")) "KN2W4===" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32PaddedWith :: (ByteString -> Either err Text) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base32Error err) Text -decodeBase32PaddedWith f t = case B32.decodeBase32Padded t of +decodeBase32PaddedWith f t = case B32.decodeBase32PaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32PaddedWith #-} --- -- | Leniently decode a Base32-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. --- -- --- -- __Note:__ This is not RFC 4648-compliant. --- -- --- decodeBase32Lenient :: Text -> Text --- decodeBase32Lenient = T.decodeUtf8 --- . B32.decodeBase32Lenient --- . T.encodeUtf8 --- {-# INLINE decodeBase32Lenient #-} +-- | Decode a typed Base32-encoded 'Text' value. +-- +-- This function is padding-agnostic. +-- The decoded payload must be valid UTF-8. +-- +-- >>> decodeBase32 (encodeBase32 "Sun") +-- "Sun" +-- +-- >>> decodeBase32 (encodeBase32Unpadded "Sun") +-- "Sun" +-- +-- @since 1.0 +-- +decodeBase32 :: StdAlphabet k => Base32 k Text -> Text +decodeBase32 = T.decodeUtf8 . B32.decodeBase32 . fmap T.encodeUtf8 +{-# INLINE decodeBase32 #-} --- | Tell whether a 'Text' value is Base32-encoded +-- | Decode a typed, padded Base32-encoded 'Text' value. -- --- === __Examples__: +-- The decoded payload must be valid UTF-8. -- --- >>> isBase32 "KN2W4" --- True +-- >>> decodeBase32Padded (encodeBase32 "Sun") +-- "Sun" -- --- >>> isBase32 "KN2W4===" --- True +-- @since 1.0 -- --- >>> isBase32 "KN2W4==" --- False +decodeBase32Padded :: Base32 'StdPadded Text -> Text +decodeBase32Padded = decodeBase32 +{-# INLINE decodeBase32Padded #-} + +-- | Parse and validate a base32-encoded value, assuming that it has padding. -- -isBase32 :: Text -> Bool -isBase32 = B32.isBase32 . T.encodeUtf8 -{-# INLINE isBase32 #-} +-- >>> parseBase32Padded "kn2w4===" +-- Right "kn2w4===" +-- +-- >>> fmap decodeBase32Padded (parseBase32Padded "KN2W4===") +-- Right "Sun" +-- +-- >>> parseBase32Padded "" +-- Right "" +-- +-- >>> parseBase32Padded "KN2W4" +-- Left "Base32-encoded bytestring requires padding" +-- +-- @since 1.0 +-- +parseBase32Padded :: Text -> Either Text (Base32 'StdPadded Text) +parseBase32Padded value = assertBase32 value + <$ (B32.decodeBase32PaddedUntyped . T.encodeUtf8) value +{-# INLINE parseBase32Padded #-} --- | Tell whether a 'Text' value is a valid Base32 format. +-- | Decode a typed, unpadded Base32-encoded value. -- --- This will not tell you whether or not this is a correct Base32 representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base32 encoded 'Text' value, use 'isBase32'. +-- The decoded payload must be valid UTF-8. -- --- === __Examples__: +-- >>> decodeBase32Unpadded (encodeBase32Unpadded "Sun") +-- "Sun" -- --- >>> isValidBase32 "KN2W4" --- True +-- @since 1.0 -- --- >>> isValidBase32 "KN2W4=" --- False +decodeBase32Unpadded :: Base32 'StdUnpadded Text -> Text +decodeBase32Unpadded = decodeBase32 +{-# INLINE decodeBase32Unpadded #-} + +-- | Parse and validate a base32-encoded value, assuming that it is unpadded. -- --- >>> isValidBase32 "KN2W4%" --- False +-- >>> parseBase32Unpadded "kn2w4" +-- Right "kn2w4" -- -isValidBase32 :: Text -> Bool -isValidBase32 = B32.isValidBase32 . T.encodeUtf8 -{-# INLINE isValidBase32 #-} +-- >>> fmap decodeBase32Unpadded (parseBase32Unpadded "KN2W4") +-- Right "Sun" +-- +-- >>> parseBase32Unpadded "" +-- Right "" +-- +-- >>> parseBase32Unpadded "KN2W4===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +-- >>> isLeft (parseBase32Unpadded "MZ") +-- True +-- +-- @since 1.0 +-- +parseBase32Unpadded :: Text -> Either Text (Base32 'StdUnpadded Text) +parseBase32Unpadded value = assertBase32 value + <$ (B32.decodeBase32UnpaddedUntyped . T.encodeUtf8) value +{-# INLINE parseBase32Unpadded #-} + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> import Data.Either (isLeft) +-- >>> import qualified Data.Text.Encoding as UTF8 diff --git a/src/Data/Text/Encoding/Base32/Error.hs b/src/Data/Text/Encoding/Base32/Error.hs --- a/src/Data/Text/Encoding/Base32/Error.hs +++ b/src/Data/Text/Encoding/Base32/Error.hs @@ -2,7 +2,7 @@ {-# LANGUAGE Safe #-} -- | -- Module : Data.Text.Encoding.Base32.Error --- Copyright : (c) 2019-2023 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -29,6 +29,11 @@ -- Namely, to distinguish between decoding errors from opaque -- unicode exceptions caught in the unicode decoding process. -- +-- >>> DecodeError "invalid padding" :: Base32Error String +-- DecodeError "invalid padding" +-- >>> ConversionError "invalid UTF-8" :: Base32Error String +-- ConversionError "invalid UTF-8" +-- data Base32Error e = DecodeError Text -- ^ The error associated with decoding failure @@ -54,3 +59,4 @@ -- @since 0.2.0.0 -- instance NFData e => NFData (Base32Error e) + diff --git a/src/Data/Text/Encoding/Base32/Hex.hs b/src/Data/Text/Encoding/Base32/Hex.hs --- a/src/Data/Text/Encoding/Base32/Hex.hs +++ b/src/Data/Text/Encoding/Base32/Hex.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Safe #-} -- | -- Module : Data.Text.Encoding.Base32.Hex --- Copyright : (c) 2019-2023 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -16,19 +18,24 @@ -- module Data.Text.Encoding.Base32.Hex ( encodeBase32 -, decodeBase32 +, decodeBase32Untyped , decodeBase32With , encodeBase32Unpadded -, decodeBase32Unpadded +, decodeBase32UnpaddedUntyped , decodeBase32UnpaddedWith -, decodeBase32Padded +, decodeBase32PaddedUntyped , decodeBase32PaddedWith --- , decodeBase32Lenient -, isBase32Hex -, isValidBase32Hex +, decodeBase32 +, decodeBase32Padded +, decodeBase32Unpadded +, parseBase32Padded +, parseBase32Unpadded ) where +import Data.Base32.Types +import qualified Data.Text as ErrorText + import Data.Bifunctor (first) import Data.ByteString (ByteString) import qualified Data.ByteString.Base32.Hex as B32H @@ -46,36 +53,39 @@ -- >>> encodeBase32 "Sun" -- "ADQMS===" -- -encodeBase32 :: Text -> Text +-- @since 1.0 +-- +encodeBase32 :: Text -> Base32 'HexPadded Text encodeBase32 = B32H.encodeBase32 . T.encodeUtf8 {-# INLINE encodeBase32 #-} -- | Decode a padded Base32hex-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 base32hex encodings are optionally padded. +-- of 8, then padding chars will be added to fill out the input to a multiple of +-- 8 for safe decoding as base32hex encodings are optionally padded. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32With` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32 "ADQMS===" +-- >>> decodeBase32Untyped "ADQMS===" -- Right "Sun" -- --- >>> decodeBase32 "ADQMS" +-- >>> decodeBase32Untyped "ADQMS" -- Right "Sun" -- --- >>> decodeBase32 "ADQMS===" +-- >>> decodeBase32Untyped "ADQM===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32 :: Text -> Either Text Text -decodeBase32 = fmap T.decodeUtf8 . B32H.decodeBase32 . T.encodeUtf8 -{-# INLINE decodeBase32 #-} +-- @since 1.0 +-- +decodeBase32Untyped :: Text -> Either Text Text +decodeBase32Untyped value = B32H.decodeBase32Untyped (T.encodeUtf8 value) + >>= first (ErrorText.pack . show) . T.decodeUtf8' +{-# INLINE decodeBase32Untyped #-} -- | Attempt to decode a 'ByteString' value as Base32hex, converting from -- 'ByteString' to 'Text' according to some encoding function. In practice, @@ -85,18 +95,22 @@ -- -- === __Examples__: -- --- @ --- 'decodeBase32With' 'T.decodeUtf8'' --- :: 'Text' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' --- @ +-- >>> decodeBase32With UTF8.decodeUtf8' "ADQMS===" +-- Right "Sun" -- +-- >>> decodeBase32With UTF8.decodeUtf8' "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32With (const (Left "unsupported encoding")) "ADQMS===" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32With :: (ByteString -> Either err Text) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base32Error err) Text -decodeBase32With f t = case B32H.decodeBase32 t of +decodeBase32With f t = case B32H.decodeBase32Untyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32With #-} @@ -112,56 +126,61 @@ -- >>> encodeBase32Unpadded "Sun" -- "ADQMS" -- -encodeBase32Unpadded :: Text -> Text +-- @since 1.0 +-- +encodeBase32Unpadded :: Text -> Base32 'HexUnpadded Text encodeBase32Unpadded = B32H.encodeBase32Unpadded . T.encodeUtf8 {-# INLINE encodeBase32Unpadded #-} -- | Decode an unpadded Base32hex encoded 'Text' value. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32WUnpaddedWith` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Unpadded "ADQMS" +-- >>> decodeBase32UnpaddedUntyped "ADQMS" -- Right "Sun" -- --- >>> decodeBase32Unpadded "ADQMS===" +-- >>> decodeBase32UnpaddedUntyped "ADQMS===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32Unpadded :: Text -> Either Text Text -decodeBase32Unpadded = fmap T.decodeUtf8 - . B32H.decodeBase32Unpadded - . T.encodeUtf8 -{-# INLINE decodeBase32Unpadded #-} +-- @since 1.0 +-- +decodeBase32UnpaddedUntyped :: Text -> Either Text Text +decodeBase32UnpaddedUntyped value = B32H.decodeBase32UnpaddedUntyped (T.encodeUtf8 value) + >>= first (ErrorText.pack . show) . T.decodeUtf8' +{-# INLINE decodeBase32UnpaddedUntyped #-} -- | Attempt to decode an unpadded 'ByteString' value as Base32hex, converting from -- 'ByteString' to 'Text' according to some encoding function. In practice, --- This is something like 'decodeUtf8'', which may produce an error. +-- This is something like 'T.decodeUtf8'', which may produce an error. -- -- See: -- -- === __Example__: -- --- @ --- 'decodeBase32UnpaddedWith' 'T.decodeUtf8'' --- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' --- @ +-- >>> decodeBase32UnpaddedWith UTF8.decodeUtf8' "ADQMS" +-- Right "Sun" -- +-- >>> decodeBase32UnpaddedWith UTF8.decodeUtf8' "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32UnpaddedWith (const (Left "unsupported encoding")) "ADQMS" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32UnpaddedWith :: (ByteString -> Either err Text) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base32Error err) Text -decodeBase32UnpaddedWith f t = case B32H.decodeBase32Unpadded t of +decodeBase32UnpaddedWith f t = case B32H.decodeBase32UnpaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32UnpaddedWith #-} @@ -169,27 +188,26 @@ -- | Decode an padded Base32hex encoded 'Text' value -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32PaddedWith` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Padded "ADQMS===" +-- >>> decodeBase32PaddedUntyped "ADQMS===" -- Right "Sun" -- --- >>> decodeBase32Padded "ADQMS" +-- >>> decodeBase32PaddedUntyped "ADQMS" -- Left "Base32-encoded bytestring requires padding" -- -decodeBase32Padded :: Text -> Either Text Text -decodeBase32Padded = fmap T.decodeUtf8 - . B32H.decodeBase32Padded - . T.encodeUtf8 -{-# INLINE decodeBase32Padded #-} +-- @since 1.0 +-- +decodeBase32PaddedUntyped :: Text -> Either Text Text +decodeBase32PaddedUntyped value = B32H.decodeBase32PaddedUntyped (T.encodeUtf8 value) + >>= first (ErrorText.pack . show) . T.decodeUtf8' +{-# INLINE decodeBase32PaddedUntyped #-} -- | Attempt to decode a padded 'ByteString' value as Base32hex, converting from -- 'ByteString' to 'Text' according to some encoding function. In practice, @@ -199,68 +217,115 @@ -- -- === __Example__: -- --- @ --- 'decodeBase32PaddedWith' 'T.decodeUtf8'' --- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' --- @ +-- >>> decodeBase32PaddedWith UTF8.decodeUtf8' "ADQMS===" +-- Right "Sun" -- +-- >>> decodeBase32PaddedWith UTF8.decodeUtf8' "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32PaddedWith (const (Left "unsupported encoding")) "ADQMS===" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32PaddedWith :: (ByteString -> Either err Text) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base32Error err) Text -decodeBase32PaddedWith f t = case B32H.decodeBase32Padded t of +decodeBase32PaddedWith f t = case B32H.decodeBase32PaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32PaddedWith #-} --- -- -- | Leniently decode an unpadded Base32hex-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. --- -- -- --- -- -- __Note:__ This is not RFC 4648-compliant. --- -- -- --- -- decodeBase32Lenient :: Text -> Text --- -- decodeBase32Lenient = T.decodeUtf8 --- -- . B32H.decodeBase32Lenient --- -- . T.encodeUtf8 --- -- {-# INLINE decodeBase32Lenient #-} +-- | Decode a typed Base32hex-encoded 'Text' value. +-- +-- This function is padding-agnostic. +-- The decoded payload must be valid UTF-8. +-- +-- >>> decodeBase32 (encodeBase32 "Sun") +-- "Sun" +-- +-- >>> decodeBase32 (encodeBase32Unpadded "Sun") +-- "Sun" +-- +-- @since 1.0 +-- +decodeBase32 :: HexAlphabet k => Base32 k Text -> Text +decodeBase32 = T.decodeUtf8 . B32H.decodeBase32 . fmap T.encodeUtf8 +{-# INLINE decodeBase32 #-} --- | Tell whether a 'Text' value is Base32hex-encoded. +-- | Decode a typed, padded Base32hex-encoded 'Text' value. -- --- === __Examples__: +-- The decoded payload must be valid UTF-8. -- --- >>> isBase32Hex "ADQMS" --- True +-- >>> decodeBase32Padded (encodeBase32 "Sun") +-- "Sun" -- --- >>> isBase32Hex "ADQMS===" --- True +-- @since 1.0 -- --- >>> isBase32Hex "ADQMS==" --- False +decodeBase32Padded :: Base32 'HexPadded Text -> Text +decodeBase32Padded = decodeBase32 +{-# INLINE decodeBase32Padded #-} + +-- | Parse and validate a base32hex-encoded value, assuming that it has padding. -- -isBase32Hex :: Text -> Bool -isBase32Hex = B32H.isBase32Hex . T.encodeUtf8 -{-# INLINE isBase32Hex #-} +-- >>> parseBase32Padded "adqms===" +-- Right "adqms===" +-- +-- >>> fmap decodeBase32Padded (parseBase32Padded "ADQMS===") +-- Right "Sun" +-- +-- >>> parseBase32Padded "" +-- Right "" +-- +-- >>> parseBase32Padded "ADQMS" +-- Left "Base32-encoded bytestring requires padding" +-- +-- @since 1.0 +-- +parseBase32Padded :: Text -> Either Text (Base32 'HexPadded Text) +parseBase32Padded value = assertBase32 value + <$ (B32H.decodeBase32PaddedUntyped . T.encodeUtf8) value +{-# INLINE parseBase32Padded #-} --- | Tell whether a 'Text' value is a valid Base32hex format. +-- | Decode a typed, unpadded Base32hex-encoded value. -- --- This will not tell you whether or not this is a correct Base32hex representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base32 encoded 'Text' value, use 'isBase32Hex'. +-- The decoded payload must be valid UTF-8. -- --- === __Examples__: +-- >>> decodeBase32Unpadded (encodeBase32Unpadded "Sun") +-- "Sun" -- --- >>> isValidBase32Hex "ADQMS" --- True +-- @since 1.0 -- --- >>> isValidBase32Hex "ADQMS=" --- False +decodeBase32Unpadded :: Base32 'HexUnpadded Text -> Text +decodeBase32Unpadded = decodeBase32 +{-# INLINE decodeBase32Unpadded #-} + +-- | Parse and validate a base32hex-encoded value, assuming that it is unpadded. -- --- >>> isValidBase32Hex "ADQMS%" --- False +-- >>> parseBase32Unpadded "adqms" +-- Right "adqms" -- -isValidBase32Hex :: Text -> Bool -isValidBase32Hex = B32H.isValidBase32Hex . T.encodeUtf8 -{-# INLINE isValidBase32Hex #-} +-- >>> fmap decodeBase32Unpadded (parseBase32Unpadded "ADQMS") +-- Right "Sun" +-- +-- >>> parseBase32Unpadded "" +-- Right "" +-- +-- >>> parseBase32Unpadded "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +-- >>> isLeft (parseBase32Unpadded "CP") +-- True +-- +-- @since 1.0 +-- +parseBase32Unpadded :: Text -> Either Text (Base32 'HexUnpadded Text) +parseBase32Unpadded value = assertBase32 value + <$ (B32H.decodeBase32UnpaddedUntyped . T.encodeUtf8) value +{-# INLINE parseBase32Unpadded #-} + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> import Data.Either (isLeft) +-- >>> import qualified Data.Text.Encoding as UTF8 diff --git a/src/Data/Text/Lazy/Encoding/Base32.hs b/src/Data/Text/Lazy/Encoding/Base32.hs --- a/src/Data/Text/Lazy/Encoding/Base32.hs +++ b/src/Data/Text/Lazy/Encoding/Base32.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Safe #-} -- | -- Module : Data.Text.Lazy.Encoding.Base32 --- Copyright : (c) 2019-2023 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -18,19 +20,24 @@ encodeBase32 , encodeBase32Unpadded -- * Decoding -, decodeBase32 +, decodeBase32Untyped , decodeBase32With -, decodeBase32Unpadded +, decodeBase32UnpaddedUntyped , decodeBase32UnpaddedWith -, decodeBase32Padded +, decodeBase32PaddedUntyped , decodeBase32PaddedWith ---, decodeBase32Lenient -- * Validation -, isBase32 -, isValidBase32 +, decodeBase32 +, decodeBase32Padded +, decodeBase32Unpadded +, parseBase32Padded +, parseBase32Unpadded ) where +import Data.Base32.Types +import qualified Data.Text as ErrorText + import Data.Bifunctor (first) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Base32 as BL32 @@ -49,36 +56,40 @@ -- >>> encodeBase32 "Sun" -- "KN2W4===" -- -encodeBase32 :: TL.Text -> TL.Text +-- @since 1.0 +-- +encodeBase32 :: TL.Text -> Base32 'StdPadded TL.Text encodeBase32 = BL32.encodeBase32 . TL.encodeUtf8 {-# INLINE encodeBase32 #-} --- | Decode an arbitrarily padded Base32-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 base32 encodings are optionally padded. +-- | Decode an arbitrarily padded Base32-encoded 'TL.Text' value. If its length is not a +-- multiple +-- of 8, then padding chars will be added to fill out the input to a multiple of +-- 8 for safe decoding as base32 encodings are optionally padded. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'TL.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32With` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32 "KN2W4===" +-- >>> decodeBase32Untyped "KN2W4===" -- Right "Sun" -- --- >>> decodeBase32 "KN2W4" +-- >>> decodeBase32Untyped "KN2W4" -- Right "Sun" -- --- >>> decodeBase32 "KN2W===" +-- >>> decodeBase32Untyped "KN2W===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32 :: TL.Text -> Either T.Text TL.Text -decodeBase32 = fmap TL.decodeUtf8 . BL32.decodeBase32 . TL.encodeUtf8 -{-# INLINE decodeBase32 #-} +-- @since 1.0 +-- +decodeBase32Untyped :: TL.Text -> Either T.Text TL.Text +decodeBase32Untyped value = BL32.decodeBase32Untyped (TL.encodeUtf8 value) + >>= first (ErrorText.pack . show) . TL.decodeUtf8' +{-# INLINE decodeBase32Untyped #-} -- | Attempt to decode a lazy 'ByteString' value as Base32, converting from -- 'ByteString' to 'TL.Text' according to some encoding function. In practice, @@ -88,18 +99,22 @@ -- -- === __Examples__: -- --- @ --- 'decodeBase32With' 'TL.decodeUtf8'' --- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'TL.Text' --- @ +-- >>> decodeBase32With UTF8.decodeUtf8' "KN2W4===" +-- Right "Sun" -- +-- >>> decodeBase32With UTF8.decodeUtf8' "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32With (const (Left "unsupported encoding")) "KN2W4===" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32With :: (ByteString -> Either err TL.Text) -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base32Error err) TL.Text -decodeBase32With f t = case BL32.decodeBase32 t of +decodeBase32With f t = case BL32.decodeBase32Untyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32With #-} @@ -115,33 +130,34 @@ -- >>> encodeBase32Unpadded "Sun" -- "KN2W4" -- -encodeBase32Unpadded :: TL.Text -> TL.Text +-- @since 1.0 +-- +encodeBase32Unpadded :: TL.Text -> Base32 'StdUnpadded TL.Text encodeBase32Unpadded = BL32.encodeBase32Unpadded . TL.encodeUtf8 {-# INLINE encodeBase32Unpadded #-} -- | Decode an unpadded Base32 encoded 'TL.Text' value. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'TL.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32WUnpaddedWith` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Unpadded "KN2W4" +-- >>> decodeBase32UnpaddedUntyped "KN2W4" -- Right "Sun" -- --- >>> decodeBase32Unpadded "KN2W4===" +-- >>> decodeBase32UnpaddedUntyped "KN2W4===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32Unpadded :: TL.Text -> Either T.Text TL.Text -decodeBase32Unpadded = fmap TL.decodeUtf8 - . BL32.decodeBase32Unpadded - . TL.encodeUtf8 -{-# INLINE decodeBase32Unpadded #-} +-- @since 1.0 +-- +decodeBase32UnpaddedUntyped :: TL.Text -> Either T.Text TL.Text +decodeBase32UnpaddedUntyped value = BL32.decodeBase32UnpaddedUntyped (TL.encodeUtf8 value) + >>= first (ErrorText.pack . show) . TL.decodeUtf8' +{-# INLINE decodeBase32UnpaddedUntyped #-} -- | Attempt to decode an unpadded lazy 'ByteString' value as Base32, converting from -- 'ByteString' to 'TL.Text' according to some encoding function. In practice, @@ -151,45 +167,48 @@ -- -- === __Examples__: -- --- @ --- 'decodeBase32UnpaddedWith' 'TL.decodeUtf8'' --- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'TL.Text' --- @ +-- >>> decodeBase32UnpaddedWith UTF8.decodeUtf8' "KN2W4" +-- Right "Sun" -- +-- >>> decodeBase32UnpaddedWith UTF8.decodeUtf8' "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32UnpaddedWith (const (Left "unsupported encoding")) "KN2W4" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32UnpaddedWith :: (ByteString -> Either err TL.Text) -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base32Error err) TL.Text -decodeBase32UnpaddedWith f t = case BL32.decodeBase32Unpadded t of +decodeBase32UnpaddedWith f t = case BL32.decodeBase32UnpaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32UnpaddedWith #-} -- | Decode an padded Base32 encoded 'TL.Text' value -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'TL.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32PaddedWith` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Padded "KN2W4===" +-- >>> decodeBase32PaddedUntyped "KN2W4===" -- Right "Sun" -- --- >>> decodeBase32Padded "KN2W4" +-- >>> decodeBase32PaddedUntyped "KN2W4" -- Left "Base32-encoded bytestring requires padding" -- -decodeBase32Padded :: TL.Text -> Either T.Text TL.Text -decodeBase32Padded = fmap TL.decodeUtf8 - . BL32.decodeBase32Padded - . TL.encodeUtf8 -{-# INLINE decodeBase32Padded #-} +-- @since 1.0 +-- +decodeBase32PaddedUntyped :: TL.Text -> Either T.Text TL.Text +decodeBase32PaddedUntyped value = BL32.decodeBase32PaddedUntyped (TL.encodeUtf8 value) + >>= first (ErrorText.pack . show) . TL.decodeUtf8' +{-# INLINE decodeBase32PaddedUntyped #-} -- | Attempt to decode a padded lazy 'ByteString' value as Base32, converting from -- 'ByteString' to 'TL.Text' according to some encoding function. In practice, @@ -199,76 +218,115 @@ -- -- === __Example__: -- --- @ --- 'decodeBase32PaddedWith' 'TL.decodeUtf8'' --- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' --- @ +-- >>> decodeBase32PaddedWith UTF8.decodeUtf8' "KN2W4===" +-- Right "Sun" -- +-- >>> decodeBase32PaddedWith UTF8.decodeUtf8' "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32PaddedWith (const (Left "unsupported encoding")) "KN2W4===" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32PaddedWith :: (ByteString -> Either err TL.Text) -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base32Error err) TL.Text -decodeBase32PaddedWith f t = case BL32.decodeBase32Padded t of +decodeBase32PaddedWith f t = case BL32.decodeBase32PaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32PaddedWith #-} --- -- | Leniently decode an unpadded Base32-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. --- -- --- -- __Note:__ This is not RFC 4648-compliant. --- -- --- -- === __Examples__: --- -- --- -- >>> decodeBase32Lenient "PDw_Pj4=" --- -- "<>" --- -- --- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" --- -- "<>" --- -- --- decodeBase32Lenient :: TL.Text -> TL.Text --- decodeBase32Lenient = TL.decodeUtf8 --- . BL32.decodeBase32Lenient --- . TL.encodeUtf8 --- {-# INLINE decodeBase32Lenient #-} +-- | Decode a typed Base32-encoded 'TL.Text' value. +-- +-- This function is padding-agnostic. +-- The decoded payload must be valid UTF-8. +-- +-- >>> decodeBase32 (encodeBase32 "Sun") +-- "Sun" +-- +-- >>> decodeBase32 (encodeBase32Unpadded "Sun") +-- "Sun" +-- +-- @since 1.0 +-- +decodeBase32 :: StdAlphabet k => Base32 k TL.Text -> TL.Text +decodeBase32 = TL.decodeUtf8 . BL32.decodeBase32 . fmap TL.encodeUtf8 +{-# INLINE decodeBase32 #-} --- | Tell whether a 'TL.Text' value is Base32-encoded +-- | Decode a typed, padded Base32-encoded 'TL.Text' value. -- --- === __Examples__: +-- The decoded payload must be valid UTF-8. -- --- >>> isBase32 "KN2W4" --- True +-- >>> decodeBase32Padded (encodeBase32 "Sun") +-- "Sun" -- --- >>> isBase32 "KN2W4===" --- True +-- @since 1.0 -- --- >>> isBase32 "KN2W4==" --- False +decodeBase32Padded :: Base32 'StdPadded TL.Text -> TL.Text +decodeBase32Padded = decodeBase32 +{-# INLINE decodeBase32Padded #-} + +-- | Parse and validate a base32-encoded value, assuming that it has padding. -- -isBase32 :: TL.Text -> Bool -isBase32 = BL32.isBase32 . TL.encodeUtf8 -{-# INLINE isBase32 #-} +-- >>> parseBase32Padded "kn2w4===" +-- Right "kn2w4===" +-- +-- >>> fmap decodeBase32Padded (parseBase32Padded "KN2W4===") +-- Right "Sun" +-- +-- >>> parseBase32Padded "" +-- Right "" +-- +-- >>> parseBase32Padded "KN2W4" +-- Left "Base32-encoded bytestring requires padding" +-- +-- @since 1.0 +-- +parseBase32Padded :: TL.Text -> Either T.Text (Base32 'StdPadded TL.Text) +parseBase32Padded value = assertBase32 value + <$ (BL32.decodeBase32PaddedUntyped . TL.encodeUtf8) value +{-# INLINE parseBase32Padded #-} --- | Tell whether a 'TL.Text' value is a valid Base32 format. +-- | Decode a typed, unpadded Base32-encoded value. -- --- This will not tell you whether or not this is a correct Base32 representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base32 encoded 'TL.Text' value, use 'isBase32'. +-- The decoded payload must be valid UTF-8. -- --- === __Examples__: +-- >>> decodeBase32Unpadded (encodeBase32Unpadded "Sun") +-- "Sun" -- --- >>> isValidBase32 "KN2W4" --- True +-- @since 1.0 -- --- >>> isValidBase32 "KN2W4=" --- False +decodeBase32Unpadded :: Base32 'StdUnpadded TL.Text -> TL.Text +decodeBase32Unpadded = decodeBase32 +{-# INLINE decodeBase32Unpadded #-} + +-- | Parse and validate a base32-encoded value, assuming that it is unpadded. -- --- >>> isValidBase32 "KN2W4%" --- False +-- >>> parseBase32Unpadded "kn2w4" +-- Right "kn2w4" -- -isValidBase32 :: TL.Text -> Bool -isValidBase32 = BL32.isValidBase32 . TL.encodeUtf8 -{-# INLINE isValidBase32 #-} +-- >>> fmap decodeBase32Unpadded (parseBase32Unpadded "KN2W4") +-- Right "Sun" +-- +-- >>> parseBase32Unpadded "" +-- Right "" +-- +-- >>> parseBase32Unpadded "KN2W4===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +-- >>> isLeft (parseBase32Unpadded "MZ") +-- True +-- +-- @since 1.0 +-- +parseBase32Unpadded :: TL.Text -> Either T.Text (Base32 'StdUnpadded TL.Text) +parseBase32Unpadded value = assertBase32 value + <$ (BL32.decodeBase32UnpaddedUntyped . TL.encodeUtf8) value +{-# INLINE parseBase32Unpadded #-} + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> import Data.Either (isLeft) +-- >>> import qualified Data.Text.Lazy.Encoding as UTF8 diff --git a/src/Data/Text/Lazy/Encoding/Base32/Hex.hs b/src/Data/Text/Lazy/Encoding/Base32/Hex.hs --- a/src/Data/Text/Lazy/Encoding/Base32/Hex.hs +++ b/src/Data/Text/Lazy/Encoding/Base32/Hex.hs @@ -1,7 +1,9 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE Safe #-} -- | -- Module : Data.Text.Lazy.Encoding.Base32.Hex --- Copyright : (c) 2019-2023 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -18,19 +20,24 @@ encodeBase32 , encodeBase32Unpadded -- * Decoding -, decodeBase32 +, decodeBase32Untyped , decodeBase32With -, decodeBase32Unpadded +, decodeBase32UnpaddedUntyped , decodeBase32UnpaddedWith -, decodeBase32Padded +, decodeBase32PaddedUntyped , decodeBase32PaddedWith ---, decodeBase32Lenient -- * Validation -, isBase32Hex -, isValidBase32Hex +, decodeBase32 +, decodeBase32Padded +, decodeBase32Unpadded +, parseBase32Padded +, parseBase32Unpadded ) where +import Data.Base32.Types +import qualified Data.Text as ErrorText + import Data.Bifunctor (first) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Base32.Hex as BL32H @@ -49,36 +56,39 @@ -- >>> encodeBase32 "Sun" -- "ADQMS===" -- -encodeBase32 :: TL.Text -> TL.Text +-- @since 1.0 +-- +encodeBase32 :: TL.Text -> Base32 'HexPadded TL.Text encodeBase32 = BL32H.encodeBase32 . TL.encodeUtf8 {-# INLINE encodeBase32 #-} -- | Decode a padded Base32hex-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 base32hex encodings are optionally padded. +-- of 8, then padding chars will be added to fill out the input to a multiple of +-- 8 for safe decoding as base32hex encodings are optionally padded. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'TL.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32With` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32 "ADQMS===" +-- >>> decodeBase32Untyped "ADQMS===" -- Right "Sun" -- --- >>> decodeBase32 "ADQMS" +-- >>> decodeBase32Untyped "ADQMS" -- Right "Sun" -- --- >>> decodeBase32 "ADQMS===" +-- >>> decodeBase32Untyped "ADQM===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32 :: TL.Text -> Either T.Text TL.Text -decodeBase32 = fmap TL.decodeUtf8 . BL32H.decodeBase32 . TL.encodeUtf8 -{-# INLINE decodeBase32 #-} +-- @since 1.0 +-- +decodeBase32Untyped :: TL.Text -> Either T.Text TL.Text +decodeBase32Untyped value = BL32H.decodeBase32Untyped (TL.encodeUtf8 value) + >>= first (ErrorText.pack . show) . TL.decodeUtf8' +{-# INLINE decodeBase32Untyped #-} -- | Attempt to decode a lazy 'ByteString' value as Base32hex, converting from -- 'ByteString' to 'TL.Text' according to some encoding function. In practice, @@ -88,18 +98,22 @@ -- -- === __Examples__: -- --- @ --- 'decodeBase32With' 'TL.decodeUtf8'' --- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'TL.Text' --- @ +-- >>> decodeBase32With UTF8.decodeUtf8' "ADQMS===" +-- Right "Sun" -- +-- >>> decodeBase32With UTF8.decodeUtf8' "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32With (const (Left "unsupported encoding")) "ADQMS===" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32With :: (ByteString -> Either err TL.Text) -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base32Error err) TL.Text -decodeBase32With f t = case BL32H.decodeBase32 t of +decodeBase32With f t = case BL32H.decodeBase32Untyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32With #-} @@ -115,33 +129,35 @@ -- >>> encodeBase32Unpadded "Sun" -- "ADQMS" -- -encodeBase32Unpadded :: TL.Text -> TL.Text +-- @since 1.0 +-- +encodeBase32Unpadded :: TL.Text -> Base32 'HexUnpadded TL.Text encodeBase32Unpadded = BL32H.encodeBase32Unpadded . TL.encodeUtf8 {-# INLINE encodeBase32Unpadded #-} -- | Decode an unpadded Base32hex encoded 'TL.Text' value. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'TL.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32WUnpaddedWith` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Unpadded "ADQMS" +-- >>> decodeBase32UnpaddedUntyped "ADQMS" -- Right "Sun" -- --- >>> decodeBase32Unpadded "ADQMS===" +-- >>> decodeBase32UnpaddedUntyped "ADQMS===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32Unpadded :: TL.Text -> Either T.Text TL.Text -decodeBase32Unpadded = fmap TL.decodeUtf8 - . BL32H.decodeBase32Unpadded - . TL.encodeUtf8 -{-# INLINE decodeBase32Unpadded #-} +-- @since 1.0 +-- +decodeBase32UnpaddedUntyped :: TL.Text -> Either T.Text TL.Text +decodeBase32UnpaddedUntyped value = + BL32H.decodeBase32UnpaddedUntyped (TL.encodeUtf8 value) + >>= first (ErrorText.pack . show) . TL.decodeUtf8' +{-# INLINE decodeBase32UnpaddedUntyped #-} -- | Attempt to decode an unpadded lazy 'ByteString' value as Base32hex, converting from -- 'ByteString' to 'TL.Text' according to some encoding function. In practice, @@ -151,45 +167,48 @@ -- -- === __Examples__: -- --- @ --- 'decodeBase32UnpaddedWith' 'TL.decodeUtf8'' --- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'TL.Text' --- @ +-- >>> decodeBase32UnpaddedWith UTF8.decodeUtf8' "ADQMS" +-- Right "Sun" -- +-- >>> decodeBase32UnpaddedWith UTF8.decodeUtf8' "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32UnpaddedWith (const (Left "unsupported encoding")) "ADQMS" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32UnpaddedWith :: (ByteString -> Either err TL.Text) -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base32Error err) TL.Text -decodeBase32UnpaddedWith f t = case BL32H.decodeBase32Unpadded t of +decodeBase32UnpaddedWith f t = case BL32H.decodeBase32UnpaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32UnpaddedWith #-} -- | Decode an padded Base32hex encoded 'TL.Text' value -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'TL.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32PaddedWith` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Padded "ADQMS===" +-- >>> decodeBase32PaddedUntyped "ADQMS===" -- Right "Sun" -- --- >>> decodeBase32Padded "ADQMS" +-- >>> decodeBase32PaddedUntyped "ADQMS" -- Left "Base32-encoded bytestring requires padding" -- -decodeBase32Padded :: TL.Text -> Either T.Text TL.Text -decodeBase32Padded = fmap TL.decodeUtf8 - . BL32H.decodeBase32Padded - . TL.encodeUtf8 -{-# INLINE decodeBase32Padded #-} +-- @since 1.0 +-- +decodeBase32PaddedUntyped :: TL.Text -> Either T.Text TL.Text +decodeBase32PaddedUntyped value = BL32H.decodeBase32PaddedUntyped (TL.encodeUtf8 value) + >>= first (ErrorText.pack . show) . TL.decodeUtf8' +{-# INLINE decodeBase32PaddedUntyped #-} -- | Attempt to decode a padded lazy 'ByteString' value as Base32hex, converting from -- 'ByteString' to 'TL.Text' according to some encoding function. In practice, @@ -199,76 +218,115 @@ -- -- === __Example__: -- --- @ --- 'decodeBase32PaddedWith' 'TL.decodeUtf8'' --- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' --- @ +-- >>> decodeBase32PaddedWith UTF8.decodeUtf8' "ADQMS===" +-- Right "Sun" -- +-- >>> decodeBase32PaddedWith UTF8.decodeUtf8' "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32PaddedWith (const (Left "unsupported encoding")) "ADQMS===" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32PaddedWith :: (ByteString -> Either err TL.Text) -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') -> ByteString -- ^ Input text to decode -> Either (Base32Error err) TL.Text -decodeBase32PaddedWith f t = case BL32H.decodeBase32Padded t of +decodeBase32PaddedWith f t = case BL32H.decodeBase32PaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32PaddedWith #-} --- -- | Leniently decode an unpadded Base32hex-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. --- -- --- -- __Note:__ This is not RFC 4648-compliant. --- -- --- -- === __Examples__: --- -- --- -- >>> decodeBase32Lenient "PDw_Pj4=" --- -- "<>" --- -- --- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" --- -- "<>" --- -- --- decodeBase32Lenient :: TL.Text -> TL.Text --- decodeBase32Lenient = TL.decodeUtf8 --- . BL32H.decodeBase32Lenient --- . TL.encodeUtf8 --- {-# INLINE decodeBase32Lenient #-} +-- | Decode a typed Base32hex-encoded 'TL.Text' value. +-- +-- This function is padding-agnostic. +-- The decoded payload must be valid UTF-8. +-- +-- >>> decodeBase32 (encodeBase32 "Sun") +-- "Sun" +-- +-- >>> decodeBase32 (encodeBase32Unpadded "Sun") +-- "Sun" +-- +-- @since 1.0 +-- +decodeBase32 :: HexAlphabet k => Base32 k TL.Text -> TL.Text +decodeBase32 = TL.decodeUtf8 . BL32H.decodeBase32 . fmap TL.encodeUtf8 +{-# INLINE decodeBase32 #-} --- | Tell whether a 'TL.Text' value is Base32hex-encoded +-- | Decode a typed, padded Base32hex-encoded 'TL.Text' value. -- --- === __Examples__: +-- The decoded payload must be valid UTF-8. -- --- >>> isBase32Hex "ADQMS" --- True +-- >>> decodeBase32Padded (encodeBase32 "Sun") +-- "Sun" -- --- >>> isBase32Hex "ADQMS===" --- True +-- @since 1.0 -- --- >>> isBase32Hex "ADQMS==" --- False +decodeBase32Padded :: Base32 'HexPadded TL.Text -> TL.Text +decodeBase32Padded = decodeBase32 +{-# INLINE decodeBase32Padded #-} + +-- | Parse and validate a base32hex-encoded value, assuming that it has padding. -- -isBase32Hex :: TL.Text -> Bool -isBase32Hex = BL32H.isBase32Hex . TL.encodeUtf8 -{-# INLINE isBase32Hex #-} +-- >>> parseBase32Padded "adqms===" +-- Right "adqms===" +-- +-- >>> fmap decodeBase32Padded (parseBase32Padded "ADQMS===") +-- Right "Sun" +-- +-- >>> parseBase32Padded "" +-- Right "" +-- +-- >>> parseBase32Padded "ADQMS" +-- Left "Base32-encoded bytestring requires padding" +-- +-- @since 1.0 +-- +parseBase32Padded :: TL.Text -> Either T.Text (Base32 'HexPadded TL.Text) +parseBase32Padded value = assertBase32 value + <$ (BL32H.decodeBase32PaddedUntyped . TL.encodeUtf8) value +{-# INLINE parseBase32Padded #-} --- | Tell whether a 'TL.Text' value is a valid Base32hex format. +-- | Decode a typed, unpadded Base32hex-encoded value. -- --- This will not tell you whether or not this is a correct Base32hex representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base32 encoded 'TL.Text' value, use 'isBase32Hex'. +-- The decoded payload must be valid UTF-8. -- --- === __Examples__: +-- >>> decodeBase32Unpadded (encodeBase32Unpadded "Sun") +-- "Sun" -- --- >>> isValidBase32Hex "ADQMS" --- True +-- @since 1.0 -- --- >>> isValidBase32Hex "ADQMS=" --- False +decodeBase32Unpadded :: Base32 'HexUnpadded TL.Text -> TL.Text +decodeBase32Unpadded = decodeBase32 +{-# INLINE decodeBase32Unpadded #-} + +-- | Parse and validate a base32hex-encoded value, assuming that it is unpadded. -- --- >>> isValidBase32Hex "ADQMS%" --- False +-- >>> parseBase32Unpadded "adqms" +-- Right "adqms" -- -isValidBase32Hex :: TL.Text -> Bool -isValidBase32Hex = BL32H.isValidBase32Hex . TL.encodeUtf8 -{-# INLINE isValidBase32Hex #-} +-- >>> fmap decodeBase32Unpadded (parseBase32Unpadded "ADQMS") +-- Right "Sun" +-- +-- >>> parseBase32Unpadded "" +-- Right "" +-- +-- >>> parseBase32Unpadded "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +-- >>> isLeft (parseBase32Unpadded "CP") +-- True +-- +-- @since 1.0 +-- +parseBase32Unpadded :: TL.Text -> Either T.Text (Base32 'HexUnpadded TL.Text) +parseBase32Unpadded value = assertBase32 value + <$ (BL32H.decodeBase32UnpaddedUntyped . TL.encodeUtf8) value +{-# INLINE parseBase32Unpadded #-} + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> import Data.Either (isLeft) +-- >>> import qualified Data.Text.Lazy.Encoding as UTF8 diff --git a/src/Data/Text/Short/Encoding/Base32.hs b/src/Data/Text/Short/Encoding/Base32.hs --- a/src/Data/Text/Short/Encoding/Base32.hs +++ b/src/Data/Text/Short/Encoding/Base32.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + -- | -- Module : Data.Text.Short.Encoding.Base32 --- Copyright : (c) 2019-2023 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -18,91 +21,107 @@ encodeBase32 , encodeBase32Unpadded -- * Decoding -, decodeBase32 +, decodeBase32Untyped , decodeBase32With -, decodeBase32Unpadded +, decodeBase32UnpaddedUntyped , decodeBase32UnpaddedWith -, decodeBase32Padded +, decodeBase32PaddedUntyped , decodeBase32PaddedWith ---, decodeBase32Lenient -- * Validation -, isBase32 -, isValidBase32 +, decodeBase32 +, decodeBase32Padded +, decodeBase32Unpadded +, parseBase32Padded +, parseBase32Unpadded ) where +import Data.Base32.Types +import qualified Data.Text as ErrorText + import Data.Bifunctor (first) -import qualified Data.ByteString.Base32 as B32 import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as SBS import qualified Data.ByteString.Short.Base32 as BS32 import Data.Text (Text) -import qualified Data.Text.Encoding.Base32 as B32T +import qualified Data.Text.Encoding as TE import Data.Text.Encoding.Base32.Error import Data.Text.Short -import Data.Text.Short.Unsafe + -- | Encode a 'ShortText' value in Base32 with padding. -- --- See: +-- See: -- -- === __Examples__: -- -- >>> encodeBase32 "Sun" -- "KN2W4===" -- -encodeBase32 :: ShortText -> ShortText -encodeBase32 = fromByteStringUnsafe - . B32.encodeBase32' - . toByteString +-- @since 1.0 +-- +encodeBase32 :: ShortText -> Base32 'StdPadded ShortText +encodeBase32 = + BS32.encodeBase32 + . toShortByteString {-# INLINE encodeBase32 #-} --- | Decode an arbitrarily padded Base32-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 base32 encodings are optionally padded. +-- | Decode an arbitrarily padded Base32-encoded 'ShortText' value. If its length is not a +-- multiple +-- of 8, then padding chars will be added to fill out the input to a multiple of +-- 8 for safe decoding as base32 encodings are optionally padded. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'Data.Text.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32With` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- --- See: +-- See: -- -- === __Examples__: -- --- >>> decodeBase32 "KN2W4===" +-- >>> decodeBase32Untyped "KN2W4===" -- Right "Sun" -- --- >>> decodeBase32 "KN2W4" +-- >>> decodeBase32Untyped "KN2W4" -- Right "Sun" -- --- >>> decodeBase32 "KN2W===" +-- >>> decodeBase32Untyped "KN2W===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32 :: ShortText -> Either Text ShortText -decodeBase32 = fmap fromText . B32T.decodeBase32 . toText -{-# INLINE decodeBase32 #-} +-- @since 1.0 +-- +decodeBase32Untyped :: ShortText -> Either Text ShortText +decodeBase32Untyped value = + BS32.decodeBase32Untyped (toShortByteString value) + >>= maybe (Left (ErrorText.pack "invalid UTF-8 payload")) Right + . fromShortByteString +{-# INLINE decodeBase32Untyped #-} -- | Attempt to decode a 'ShortByteString' value as Base32, converting from --- 'ByteString' to 'ShortText' according to some encoding function. In practice, --- This is something like 'decodeUtf8'', which may produce an error. +-- 'ShortByteString' to 'ShortText' according to some encoding function. In practice, +-- The conversion can report a character-encoding error. -- --- See: +-- See: -- -- === __Examples__: -- --- @ --- 'decodeBase32With' '(fmap fromText . T.decodeUtf8' . toText)' --- :: 'ShortByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'ShortText' --- @ +-- >>> let utf8 = maybe (Left "invalid UTF-8") Right . Text.fromShortByteString +-- >>> decodeBase32With utf8 "KN2W4===" +-- Right "Sun" -- +-- >>> decodeBase32With utf8 "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32With (const (Left "unsupported encoding")) "KN2W4===" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32With :: (ShortByteString -> Either err ShortText) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ShortByteString -- ^ Input text to decode -> Either (Base32Error err) ShortText -decodeBase32With f t = case BS32.decodeBase32 t of +decodeBase32With f t = case BS32.decodeBase32Untyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32With #-} @@ -111,163 +130,219 @@ -- padding is optional. If you call this function, you will simply be encoding -- as Base32 and stripping padding chars from the output. -- --- See: +-- See: -- -- === __Examples__: -- -- >>> encodeBase32Unpadded "Sun" -- "KN2W4" -- -encodeBase32Unpadded :: ShortText -> ShortText -encodeBase32Unpadded = fromByteStringUnsafe - . B32.encodeBase32Unpadded' - . toByteString +-- @since 1.0 +-- +encodeBase32Unpadded :: ShortText -> Base32 'StdUnpadded ShortText +encodeBase32Unpadded = + BS32.encodeBase32Unpadded + . toShortByteString {-# INLINE encodeBase32Unpadded #-} -- | Decode an unpadded Base32 encoded 'ShortText' value. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32UnpaddedWith` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- --- See: +-- See: -- -- === __Examples__: -- --- >>> decodeBase32Unpadded "KN2W4" +-- >>> decodeBase32UnpaddedUntyped "KN2W4" -- Right "Sun" -- --- >>> decodeBase32Unpadded "KN2W4===" +-- >>> decodeBase32UnpaddedUntyped "KN2W4===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32Unpadded :: ShortText -> Either Text ShortText -decodeBase32Unpadded = fmap fromText . B32T.decodeBase32Unpadded . toText -{-# INLINE decodeBase32Unpadded #-} +-- @since 1.0 +-- +decodeBase32UnpaddedUntyped :: ShortText -> Either Text ShortText +decodeBase32UnpaddedUntyped value = + BS32.decodeBase32UnpaddedUntyped (toShortByteString value) + >>= maybe (Left (ErrorText.pack "invalid UTF-8 payload")) Right + . fromShortByteString +{-# INLINE decodeBase32UnpaddedUntyped #-} -- | Attempt to decode an unpadded 'ShortByteString' value as Base32, converting from -- 'ShortByteString' to 'ShortText' according to some encoding function. In practice, --- This is something like 'decodeUtf8'', which may produce an error. +-- The conversion can report a character-encoding error. -- --- See: +-- See: -- -- === __Examples__: -- --- @ --- 'decodeBase32UnpaddedWith' '(fmap fromText . T.decodeUtf8' . toText)' --- :: 'ShortByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'ShortText' --- @ +-- >>> let utf8 = maybe (Left "invalid UTF-8") Right . Text.fromShortByteString +-- >>> decodeBase32UnpaddedWith utf8 "KN2W4" +-- Right "Sun" -- +-- >>> decodeBase32UnpaddedWith utf8 "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32UnpaddedWith (const (Left "unsupported encoding")) "KN2W4" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32UnpaddedWith :: (ShortByteString -> Either err ShortText) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ShortByteString -- ^ Input text to decode -> Either (Base32Error err) ShortText -decodeBase32UnpaddedWith f t = case BS32.decodeBase32Unpadded t of +decodeBase32UnpaddedWith f t = case BS32.decodeBase32UnpaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32UnpaddedWith #-} -- | Decode an padded Base32 encoded 'ShortText' value -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'T.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32PaddedWith` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- --- See: +-- See: -- -- === __Examples__: -- --- >>> decodeBase32Padded "KN2W4===" +-- >>> decodeBase32PaddedUntyped "KN2W4===" -- Right "Sun" -- --- >>> decodeBase32Padded "KN2W4" +-- >>> decodeBase32PaddedUntyped "KN2W4" -- Left "Base32-encoded bytestring requires padding" -- -decodeBase32Padded :: ShortText -> Either Text ShortText -decodeBase32Padded = fmap fromText . B32T.decodeBase32Padded . toText -{-# INLINE decodeBase32Padded #-} +-- @since 1.0 +-- +decodeBase32PaddedUntyped :: ShortText -> Either Text ShortText +decodeBase32PaddedUntyped value = + BS32.decodeBase32PaddedUntyped (toShortByteString value) + >>= maybe (Left (ErrorText.pack "invalid UTF-8 payload")) Right + . fromShortByteString +{-# INLINE decodeBase32PaddedUntyped #-} -- | Attempt to decode a padded 'ShortByteString' value as Base32, converting from --- 'ByteString' to 'ShortText' according to some encoding function. In practice, --- This is something like 'decodeUtf8'', which may produce an error. +-- 'ShortByteString' to 'ShortText' according to some encoding function. In practice, +-- The conversion can report a character-encoding error. -- --- See: +-- See: -- -- === __Examples__: -- --- @ --- 'decodeBase32With' '(fmap fromText . T.decodeUtf8' . toText)' --- :: 'ShortByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'ShortText' --- @ +-- >>> let utf8 = maybe (Left "invalid UTF-8") Right . Text.fromShortByteString +-- >>> decodeBase32PaddedWith utf8 "KN2W4===" +-- Right "Sun" -- +-- >>> decodeBase32PaddedWith utf8 "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32PaddedWith (const (Left "unsupported encoding")) "KN2W4===" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32PaddedWith :: (ShortByteString -> Either err ShortText) -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') -> ShortByteString -- ^ Input text to decode -> Either (Base32Error err) ShortText -decodeBase32PaddedWith f t = case BS32.decodeBase32Padded t of +decodeBase32PaddedWith f t = case BS32.decodeBase32PaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32PaddedWith #-} --- -- | Leniently decode an unpadded Base32-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. --- -- --- -- __Note:__ This is not RFC 4328-compliant. --- -- --- -- === __Examples__: --- -- --- -- >>> decodeBase32Lenient "PDw_Pj4=" --- -- "<>" --- -- --- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" --- -- "<>" --- -- --- decodeBase32Lenient :: ShortText -> ShortText --- decodeBase32Lenient = fromText . B32T.decodeBase32Lenient . toText --- {-# INLINE decodeBase32Lenient #-} +-- | Decode a typed Base32-encoded 'ShortText' value. +-- +-- This function is padding-agnostic. +-- The decoded payload must be valid UTF-8. +-- +-- >>> decodeBase32 (encodeBase32 "Sun") +-- "Sun" +-- +-- >>> decodeBase32 (encodeBase32Unpadded "Sun") +-- "Sun" +-- +-- @since 1.0 +-- +decodeBase32 :: StdAlphabet k => Base32 k ShortText -> ShortText +decodeBase32 = fromText . TE.decodeUtf8 . SBS.fromShort + . BS32.decodeBase32 . fmap toShortByteString +{-# INLINE decodeBase32 #-} --- | Tell whether a 'ShortText' value is Base32-encoded. +-- | Decode a typed, padded Base32-encoded 'ShortText' value. -- --- === __Examples__: +-- The decoded payload must be valid UTF-8. -- --- >>> isBase32 "KN2W4" --- True +-- >>> decodeBase32Padded (encodeBase32 "Sun") +-- "Sun" -- --- >>> isBase32 "KN2W4===" --- True +-- @since 1.0 -- --- >>> isBase32 "KN2W4==" --- False +decodeBase32Padded :: Base32 'StdPadded ShortText -> ShortText +decodeBase32Padded = decodeBase32 +{-# INLINE decodeBase32Padded #-} + +-- | Parse and validate a base32-encoded value, assuming that it has padding. -- -isBase32 :: ShortText -> Bool -isBase32 = B32.isBase32 . toByteString -{-# INLINE isBase32 #-} +-- >>> parseBase32Padded "kn2w4===" +-- Right "kn2w4===" +-- +-- >>> fmap decodeBase32Padded (parseBase32Padded "KN2W4===") +-- Right "Sun" +-- +-- >>> parseBase32Padded "" +-- Right "" +-- +-- >>> parseBase32Padded "KN2W4" +-- Left "Base32-encoded bytestring requires padding" +-- +-- @since 1.0 +-- +parseBase32Padded :: ShortText -> Either Text (Base32 'StdPadded ShortText) +parseBase32Padded value = assertBase32 value + <$ (BS32.decodeBase32PaddedUntyped . toShortByteString) value +{-# INLINE parseBase32Padded #-} --- | Tell whether a 'ShortText' value is a valid Base32 format. +-- | Decode a typed, unpadded Base32-encoded value. -- --- This will not tell you whether or not this is a correct Base32 representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base32 encoded 'ShortText' value, use 'isBase32'. +-- The decoded payload must be valid UTF-8. -- --- === __Examples__: +-- >>> decodeBase32Unpadded (encodeBase32Unpadded "Sun") +-- "Sun" -- --- >>> isValidBase32 "KN2W4" --- True +-- @since 1.0 -- --- >>> isValidBase32 "KN2W4=" --- False +decodeBase32Unpadded :: Base32 'StdUnpadded ShortText -> ShortText +decodeBase32Unpadded = decodeBase32 +{-# INLINE decodeBase32Unpadded #-} + +-- | Parse and validate a base32-encoded value, assuming that it is unpadded. -- --- >>> isValidBase32 "KN2W4%" --- False +-- >>> parseBase32Unpadded "kn2w4" +-- Right "kn2w4" -- -isValidBase32 :: ShortText -> Bool -isValidBase32 = B32.isValidBase32 . toByteString -{-# INLINE isValidBase32 #-} +-- >>> fmap decodeBase32Unpadded (parseBase32Unpadded "KN2W4") +-- Right "Sun" +-- +-- >>> parseBase32Unpadded "" +-- Right "" +-- +-- >>> parseBase32Unpadded "KN2W4===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +-- >>> isLeft (parseBase32Unpadded "MZ") +-- True +-- +-- @since 1.0 +-- +parseBase32Unpadded :: ShortText -> Either Text (Base32 'StdUnpadded ShortText) +parseBase32Unpadded value = assertBase32 value + <$ (BS32.decodeBase32UnpaddedUntyped . toShortByteString) value +{-# INLINE parseBase32Unpadded #-} + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> import qualified Data.Text.Short as Text +-- >>> import Data.Either (isLeft) diff --git a/src/Data/Text/Short/Encoding/Base32/Hex.hs b/src/Data/Text/Short/Encoding/Base32/Hex.hs --- a/src/Data/Text/Short/Encoding/Base32/Hex.hs +++ b/src/Data/Text/Short/Encoding/Base32/Hex.hs @@ -1,7 +1,10 @@ -{-# LANGUAGE Trustworthy #-} +{-# LANGUAGE Safe #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + -- | -- Module : Data.Text.Short.Encoding.Base32.Hex --- Copyright : (c) 2019-2023 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -18,29 +21,34 @@ encodeBase32 , encodeBase32Unpadded -- * Decoding -, decodeBase32 +, decodeBase32Untyped , decodeBase32With -, decodeBase32Unpadded +, decodeBase32UnpaddedUntyped , decodeBase32UnpaddedWith -, decodeBase32Padded +, decodeBase32PaddedUntyped , decodeBase32PaddedWith ---, decodeBase32Lenient -- * Validation -, isBase32Hex -, isValidBase32Hex +, decodeBase32 +, decodeBase32Padded +, decodeBase32Unpadded +, parseBase32Padded +, parseBase32Unpadded ) where +import Data.Base32.Types +import qualified Data.Text as ErrorText + import Data.Bifunctor (first) -import qualified Data.ByteString.Base32.Hex as B32H import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short as SBS import qualified Data.ByteString.Short.Base32.Hex as BS32H import Data.Text (Text) -import qualified Data.Text.Encoding.Base32.Hex as B32TH +import qualified Data.Text.Encoding as TE import Data.Text.Encoding.Base32.Error import Data.Text.Short -import Data.Text.Short.Unsafe + -- | Encode a 'ShortText' value in Base32hex with padding. -- -- See: @@ -50,59 +58,71 @@ -- >>> encodeBase32 "Sun" -- "ADQMS===" -- -encodeBase32 :: ShortText -> ShortText -encodeBase32 = fromByteStringUnsafe - . B32H.encodeBase32' - . toByteString +-- @since 1.0 +-- +encodeBase32 :: ShortText -> Base32 'HexPadded ShortText +encodeBase32 = + BS32H.encodeBase32 + . toShortByteString {-# INLINE encodeBase32 #-} --- | Decode an arbitrarily padded Base32hex-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 base32hex encodings are optionally padded. +-- | Decode an arbitrarily padded Base32hex-encoded 'ShortText' value. If its length is +-- not a multiple +-- of 8, then padding chars will be added to fill out the input to a multiple of +-- 8 for safe decoding as base32hex encodings are optionally padded. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'Data.Text.Encoding.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32With` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32 "ADQMS===" +-- >>> decodeBase32Untyped "ADQMS===" -- Right "Sun" -- --- >>> decodeBase32 "ADQMS" +-- >>> decodeBase32Untyped "ADQMS" -- Right "Sun" -- --- >>> decodeBase32 "ADQMS===" +-- >>> decodeBase32Untyped "ADQM===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32 :: ShortText -> Either Text ShortText -decodeBase32 = fmap fromText . B32TH.decodeBase32 . toText -{-# INLINE decodeBase32 #-} +-- @since 1.0 +-- +decodeBase32Untyped :: ShortText -> Either Text ShortText +decodeBase32Untyped value = + BS32H.decodeBase32Untyped (toShortByteString value) + >>= maybe (Left (ErrorText.pack "invalid UTF-8 payload")) Right + . fromShortByteString +{-# INLINE decodeBase32Untyped #-} -- | Attempt to decode a 'ShortByteString' value as Base32hex, converting from --- 'ByteString' to 'ShortText' according to some encoding function. In practice, --- This is something like 'decodeUtf8'', which may produce an error. +-- 'ShortByteString' to 'ShortText' according to some encoding function. In practice, +-- The conversion can report a character-encoding error. -- -- See: -- -- === __Examples__: -- --- @ --- 'decodeBase32With' '(fmap fromText . Data.Text.Encoding.decodeUtf8' . toText)' --- :: 'ShortByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'ShortText' --- @ +-- >>> let utf8 = maybe (Left "invalid UTF-8") Right . Text.fromShortByteString +-- >>> decodeBase32With utf8 "ADQMS===" +-- Right "Sun" -- +-- >>> decodeBase32With utf8 "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32With (const (Left "unsupported encoding")) "ADQMS===" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32With :: (ShortByteString -> Either err ShortText) - -- ^ convert a bytestring to text (e.g. '(fmap fromText . Data.Text.Encoding.decodeUtf8' . toText)') + -- ^ convert a bytestring to text (e.g. '(fmap fromText . + -- Data.Text.Encoding.decodeUtf8' . toText)') -> ShortByteString -- ^ Input text to decode -> Either (Base32Error err) ShortText -decodeBase32With f t = case BS32H.decodeBase32 t of +decodeBase32With f t = case BS32H.decodeBase32Untyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32With #-} @@ -118,156 +138,213 @@ -- >>> encodeBase32Unpadded "Sun" -- "ADQMS" -- -encodeBase32Unpadded :: ShortText -> ShortText -encodeBase32Unpadded = fromByteStringUnsafe - . B32H.encodeBase32Unpadded' - . toByteString +-- @since 1.0 +-- +encodeBase32Unpadded :: ShortText -> Base32 'HexUnpadded ShortText +encodeBase32Unpadded = + BS32H.encodeBase32Unpadded + . toShortByteString {-# INLINE encodeBase32Unpadded #-} -- | Decode an unpadded Base32hex encoded 'ShortText' value. -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'Data.Text.Encoding.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32UnpaddedWith` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Unpadded "ADQMS" +-- >>> decodeBase32UnpaddedUntyped "ADQMS" -- Right "Sun" -- --- >>> decodeBase32Unpadded "ADQMS===" +-- >>> decodeBase32UnpaddedUntyped "ADQMS===" -- Left "Base32-encoded bytestring has invalid padding" -- -decodeBase32Unpadded :: ShortText -> Either Text ShortText -decodeBase32Unpadded = fmap fromText . B32TH.decodeBase32Unpadded . toText -{-# INLINE decodeBase32Unpadded #-} +-- @since 1.0 +-- +decodeBase32UnpaddedUntyped :: ShortText -> Either Text ShortText +decodeBase32UnpaddedUntyped value = + BS32H.decodeBase32UnpaddedUntyped (toShortByteString value) + >>= maybe (Left (ErrorText.pack "invalid UTF-8 payload")) Right + . fromShortByteString +{-# INLINE decodeBase32UnpaddedUntyped #-} -- | Attempt to decode an unpadded 'ShortByteString' value as Base32hex, converting from -- 'ShortByteString' to 'ShortText' according to some encoding function. In practice, --- This is something like 'decodeUtf8'', which may produce an error. +-- The conversion can report a character-encoding error. -- -- See: -- -- === __Examples__: -- --- @ --- 'decodeBase32UnpaddedWith' '(fmap fromText . Data.Text.Encoding.decodeUtf8' . toText)' --- :: 'ShortByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'ShortText' --- @ +-- >>> let utf8 = maybe (Left "invalid UTF-8") Right . Text.fromShortByteString +-- >>> decodeBase32UnpaddedWith utf8 "ADQMS" +-- Right "Sun" -- +-- >>> decodeBase32UnpaddedWith utf8 "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32UnpaddedWith (const (Left "unsupported encoding")) "ADQMS" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32UnpaddedWith :: (ShortByteString -> Either err ShortText) - -- ^ convert a bytestring to text (e.g. '(fmap fromText . Data.Text.Encoding.decodeUtf8' . toText)') + -- ^ convert a bytestring to text (e.g. '(fmap fromText . + -- Data.Text.Encoding.decodeUtf8' . toText)') -> ShortByteString -- ^ Input text to decode -> Either (Base32Error err) ShortText -decodeBase32UnpaddedWith f t = case BS32H.decodeBase32Unpadded t of +decodeBase32UnpaddedWith f t = case BS32H.decodeBase32UnpaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32UnpaddedWith #-} -- | Decode an padded Base32hex encoded 'ShortText' value -- --- /Note:/ This function makes sure that decoding is total by deferring to --- 'Data.Text.Encoding.decodeUtf8'. This will always round trip for any valid Base32-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 `decodeBase32PaddedWith` --- and pass in a custom decode function. +-- Decoded bytes are interpreted as UTF-8. Invalid Base32 or UTF-8 +-- returns 'Left'. Use the corresponding @decode*With@ function +-- to choose a different character encoding. -- -- See: -- -- === __Examples__: -- --- >>> decodeBase32Padded "ADQMS===" +-- >>> decodeBase32PaddedUntyped "ADQMS===" -- Right "Sun" -- --- >>> decodeBase32Padded "ADQMS" +-- >>> decodeBase32PaddedUntyped "ADQMS" -- Left "Base32-encoded bytestring requires padding" -- -decodeBase32Padded :: ShortText -> Either Text ShortText -decodeBase32Padded = fmap fromText . B32TH.decodeBase32Padded . toText -{-# INLINE decodeBase32Padded #-} +-- @since 1.0 +-- +decodeBase32PaddedUntyped :: ShortText -> Either Text ShortText +decodeBase32PaddedUntyped value = + BS32H.decodeBase32PaddedUntyped (toShortByteString value) + >>= maybe (Left (ErrorText.pack "invalid UTF-8 payload")) Right + . fromShortByteString +{-# INLINE decodeBase32PaddedUntyped #-} -- | Attempt to decode a padded 'ShortByteString' value as Base32hex, converting from --- 'ByteString' to 'ShortText' according to some encoding function. In practice, --- This is something like 'decodeUtf8'', which may produce an error. +-- 'ShortByteString' to 'ShortText' according to some encoding function. In practice, +-- The conversion can report a character-encoding error. -- -- See: -- -- === __Examples__: -- --- @ --- 'decodeBase32With' '(fmap fromText . Data.Text.Encoding.decodeUtf8' . toText)' --- :: 'ShortByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'ShortText' --- @ +-- >>> let utf8 = maybe (Left "invalid UTF-8") Right . Text.fromShortByteString +-- >>> decodeBase32PaddedWith utf8 "ADQMS===" +-- Right "Sun" -- +-- >>> decodeBase32PaddedWith utf8 "!" +-- Left (DecodeError "Base32-encoded bytestring has invalid size") +-- +-- >>> decodeBase32PaddedWith (const (Left "unsupported encoding")) "ADQMS===" +-- Left (ConversionError "unsupported encoding") +-- decodeBase32PaddedWith :: (ShortByteString -> Either err ShortText) -- ^ convert a bytestring to text (e.g. 'Data.Text.Encoding.decodeUtf8'') -> ShortByteString -- ^ Input text to decode -> Either (Base32Error err) ShortText -decodeBase32PaddedWith f t = case BS32H.decodeBase32Padded t of +decodeBase32PaddedWith f t = case BS32H.decodeBase32PaddedUntyped t of Left de -> Left $ DecodeError de Right a -> first ConversionError (f a) {-# INLINE decodeBase32PaddedWith #-} --- -- | Leniently decode an unpadded Base32hex-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. --- -- --- -- __Note:__ This is not RFC 4648-compliant. --- -- --- -- === __Examples__: --- -- --- -- >>> decodeBase32Lenient "PDw_Pj4=" --- -- "<>" --- -- --- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" --- -- "<>" --- -- --- decodeBase32Lenient :: ShortText -> ShortText --- decodeBase32Lenient = fromText . B32TH.decodeBase32Lenient . toText --- {-# INLINE decodeBase32Lenient #-} +-- | Decode a typed Base32hex-encoded 'ShortText' value. +-- +-- This function is padding-agnostic. +-- The decoded payload must be valid UTF-8. +-- +-- >>> decodeBase32 (encodeBase32 "Sun") +-- "Sun" +-- +-- >>> decodeBase32 (encodeBase32Unpadded "Sun") +-- "Sun" +-- +-- @since 1.0 +-- +decodeBase32 :: HexAlphabet k => Base32 k ShortText -> ShortText +decodeBase32 = fromText . TE.decodeUtf8 . SBS.fromShort + . BS32H.decodeBase32 . fmap toShortByteString +{-# INLINE decodeBase32 #-} --- | Tell whether a 'ShortText' value is Base32hex-encoded. +-- | Decode a typed, padded Base32hex-encoded 'ShortText' value. -- --- === __Examples__: +-- The decoded payload must be valid UTF-8. -- --- >>> isBase32Hex "ADQMS" --- True +-- >>> decodeBase32Padded (encodeBase32 "Sun") +-- "Sun" -- --- >>> isBase32Hex "ADQMS===" --- True +-- @since 1.0 -- --- >>> isBase32Hex "ADQMS==" --- False +decodeBase32Padded :: Base32 'HexPadded ShortText -> ShortText +decodeBase32Padded = decodeBase32 +{-# INLINE decodeBase32Padded #-} + +-- | Parse and validate a base32hex-encoded value, assuming that it has padding. -- -isBase32Hex :: ShortText -> Bool -isBase32Hex = B32H.isBase32Hex . toByteString -{-# INLINE isBase32Hex #-} +-- >>> parseBase32Padded "adqms===" +-- Right "adqms===" +-- +-- >>> fmap decodeBase32Padded (parseBase32Padded "ADQMS===") +-- Right "Sun" +-- +-- >>> parseBase32Padded "" +-- Right "" +-- +-- >>> parseBase32Padded "ADQMS" +-- Left "Base32-encoded bytestring requires padding" +-- +-- @since 1.0 +-- +parseBase32Padded :: ShortText -> Either Text (Base32 'HexPadded ShortText) +parseBase32Padded value = assertBase32 value + <$ (BS32H.decodeBase32PaddedUntyped . toShortByteString) value +{-# INLINE parseBase32Padded #-} --- | Tell whether a 'ShortText' value is a valid Base32hex format. +-- | Decode a typed, unpadded Base32hex-encoded value. -- --- This will not tell you whether or not this is a correct Base32hex representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base32 encoded 'ShortText' value, use 'isBase32Hex'. +-- The decoded payload must be valid UTF-8. -- --- === __Examples__: +-- >>> decodeBase32Unpadded (encodeBase32Unpadded "Sun") +-- "Sun" -- --- >>> isValidBase32Hex "ADQMS" --- True +-- @since 1.0 -- --- >>> isValidBase32Hex "ADQMS=" --- False +decodeBase32Unpadded :: Base32 'HexUnpadded ShortText -> ShortText +decodeBase32Unpadded = decodeBase32 +{-# INLINE decodeBase32Unpadded #-} + +-- | Parse and validate a base32hex-encoded value, assuming that it is unpadded. -- --- >>> isValidBase32Hex "ADQMS%" --- False +-- >>> parseBase32Unpadded "adqms" +-- Right "adqms" -- -isValidBase32Hex :: ShortText -> Bool -isValidBase32Hex = B32H.isValidBase32Hex . toByteString -{-# INLINE isValidBase32Hex #-} +-- >>> fmap decodeBase32Unpadded (parseBase32Unpadded "ADQMS") +-- Right "Sun" +-- +-- >>> parseBase32Unpadded "" +-- Right "" +-- +-- >>> parseBase32Unpadded "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +-- >>> isLeft (parseBase32Unpadded "CP") +-- True +-- +-- @since 1.0 +-- +parseBase32Unpadded :: ShortText -> Either Text (Base32 'HexUnpadded ShortText) +parseBase32Unpadded value = assertBase32 value + <$ (BS32H.decodeBase32UnpaddedUntyped . toShortByteString) value +{-# INLINE parseBase32Unpadded #-} + +-- $setup +-- >>> :seti -XOverloadedStrings +-- >>> import qualified Data.Text.Short as Text +-- >>> import Data.Either (isLeft) diff --git a/test/Internal.hs b/test/Internal.hs --- a/test/Internal.hs +++ b/test/Internal.hs @@ -2,6 +2,7 @@ {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE BangPatterns #-} {-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE EmptyDataDecls #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE KindSignatures #-} @@ -9,7 +10,7 @@ {-# OPTIONS_GHC -fno-warn-orphans #-} -- | -- Module : Main --- Copyright : (c) 2019-2023 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -33,6 +34,8 @@ ) where +import Data.Base32.Types (Alphabet(..), Base32, StdAlphabet, HexAlphabet, extractBase32) +import Data.Either (isRight) import Test.QuickCheck hiding (label) import Data.Text import qualified Data.ByteString as BS @@ -69,12 +72,24 @@ , encodeNopad :: bs -> bs , encodeHex :: bs -> bs , encodeHexNopad :: bs -> bs + , decodeTyped :: forall k. StdAlphabet k => Base32 k bs -> bs + , decodePaddedTyped :: Base32 'StdPadded bs -> bs + , decodeUnpaddedTyped :: Base32 'StdUnpadded bs -> bs + , decodeHexTyped :: forall k. HexAlphabet k => Base32 k bs -> bs + , decodeHexPaddedTyped :: Base32 'HexPadded bs -> bs + , decodeHexUnpaddedTyped :: Base32 'HexUnpadded bs -> bs , decode :: bs -> Either Text bs , decodeHex :: bs -> Either Text bs , decodePad :: bs -> Either Text bs , decodeHexPad :: bs -> Either Text bs , decodeNopad :: bs -> Either Text bs , decodeHexNopad :: bs -> Either Text bs + , parseValue :: bs -> Either Text bs + , parseHexValue :: bs -> Either Text bs + , parsePaddedValue :: bs -> Either Text bs + , parseUnpaddedValue :: bs -> Either Text bs + , parseHexPaddedValue :: bs -> Either Text bs + , parseHexUnpaddedValue :: bs -> Either Text bs , correct :: bs -> Bool , correctHex :: bs -> Bool , validate :: bs -> Bool @@ -84,115 +99,187 @@ b32 :: Harness BS.ByteString b32 = Harness { label = "ByteString" - , encode = B32.encodeBase32' - , encodeNopad = B32.encodeBase32Unpadded' - , decode = B32.decodeBase32 - , decodePad = B32.decodeBase32Padded - , decodeNopad = B32.decodeBase32Unpadded - , correct = B32.isBase32 - , validate = B32.isValidBase32 - , encodeHex = B32H.encodeBase32' - , encodeHexNopad = B32H.encodeBase32Unpadded' - , decodeHex = B32H.decodeBase32 - , decodeHexPad = B32H.decodeBase32Padded - , decodeHexNopad = B32H.decodeBase32Unpadded - , correctHex = B32H.isBase32Hex - , validateHex = B32H.isValidBase32Hex + , encode = extractBase32 . B32.encodeBase32' + , encodeNopad = extractBase32 . B32.encodeBase32Unpadded' + , decodeTyped = B32.decodeBase32 + , decodePaddedTyped = B32.decodeBase32Padded + , decodeUnpaddedTyped = B32.decodeBase32Unpadded + , decodeHexTyped = B32H.decodeBase32 + , decodeHexPaddedTyped = B32H.decodeBase32Padded + , decodeHexUnpaddedTyped = B32H.decodeBase32Unpadded + , decode = B32.decodeBase32Untyped + , decodePad = B32.decodeBase32PaddedUntyped + , decodeNopad = B32.decodeBase32UnpaddedUntyped + , parseValue = fmap extractBase32 . B32.parseBase32Padded + , parseHexValue = fmap extractBase32 . B32H.parseBase32Padded + , parsePaddedValue = fmap extractBase32 . B32.parseBase32Padded + , parseUnpaddedValue = fmap extractBase32 . B32.parseBase32Unpadded + , parseHexPaddedValue = fmap extractBase32 . B32H.parseBase32Padded + , parseHexUnpaddedValue = fmap extractBase32 . B32H.parseBase32Unpadded + , correct = isRight . B32.decodeBase32Untyped + , validate = isRight . B32.decodeBase32Untyped + , encodeHex = extractBase32 . B32H.encodeBase32' + , encodeHexNopad = extractBase32 . B32H.encodeBase32Unpadded' + , decodeHex = B32H.decodeBase32Untyped + , decodeHexPad = B32H.decodeBase32PaddedUntyped + , decodeHexNopad = B32H.decodeBase32UnpaddedUntyped + , correctHex = isRight . B32H.decodeBase32Untyped + , validateHex = isRight . B32H.decodeBase32Untyped } lb32 :: Harness LBS.ByteString lb32 = Harness { label = "Lazy ByteString" - , encode = BL32.encodeBase32' - , encodeNopad = BL32.encodeBase32Unpadded' - , decode = BL32.decodeBase32 - , decodePad = BL32.decodeBase32Padded - , decodeNopad = BL32.decodeBase32Unpadded - , correct = BL32.isBase32 - , validate = BL32.isValidBase32 - , encodeHex = BL32H.encodeBase32' - , encodeHexNopad = BL32H.encodeBase32Unpadded' - , decodeHex = BL32H.decodeBase32 - , decodeHexPad = BL32H.decodeBase32Padded - , decodeHexNopad = BL32H.decodeBase32Unpadded - , correctHex = BL32H.isBase32Hex - , validateHex = BL32H.isValidBase32Hex + , encode = extractBase32 . BL32.encodeBase32' + , encodeNopad = extractBase32 . BL32.encodeBase32Unpadded' + , decodeTyped = BL32.decodeBase32 + , decodePaddedTyped = BL32.decodeBase32Padded + , decodeUnpaddedTyped = BL32.decodeBase32Unpadded + , decodeHexTyped = BL32H.decodeBase32 + , decodeHexPaddedTyped = BL32H.decodeBase32Padded + , decodeHexUnpaddedTyped = BL32H.decodeBase32Unpadded + , decode = BL32.decodeBase32Untyped + , decodePad = BL32.decodeBase32PaddedUntyped + , decodeNopad = BL32.decodeBase32UnpaddedUntyped + , parseValue = fmap extractBase32 . BL32.parseBase32Padded + , parseHexValue = fmap extractBase32 . BL32H.parseBase32Padded + , parsePaddedValue = fmap extractBase32 . BL32.parseBase32Padded + , parseUnpaddedValue = fmap extractBase32 . BL32.parseBase32Unpadded + , parseHexPaddedValue = fmap extractBase32 . BL32H.parseBase32Padded + , parseHexUnpaddedValue = fmap extractBase32 . BL32H.parseBase32Unpadded + , correct = isRight . BL32.decodeBase32Untyped + , validate = isRight . BL32.decodeBase32Untyped + , encodeHex = extractBase32 . BL32H.encodeBase32' + , encodeHexNopad = extractBase32 . BL32H.encodeBase32Unpadded' + , decodeHex = BL32H.decodeBase32Untyped + , decodeHexPad = BL32H.decodeBase32PaddedUntyped + , decodeHexNopad = BL32H.decodeBase32UnpaddedUntyped + , correctHex = isRight . BL32H.decodeBase32Untyped + , validateHex = isRight . BL32H.decodeBase32Untyped } sb32 :: Harness SBS.ShortByteString sb32 = Harness { label = "Short ByteString" - , encode = BS32.encodeBase32' - , encodeNopad = BS32.encodeBase32Unpadded' - , decode = BS32.decodeBase32 - , decodePad = BS32.decodeBase32Padded - , decodeNopad = BS32.decodeBase32Unpadded - , correct = BS32.isBase32 - , validate = BS32.isValidBase32 - , encodeHex = BS32H.encodeBase32' - , encodeHexNopad = BS32H.encodeBase32Unpadded' - , decodeHex = BS32H.decodeBase32 - , decodeHexPad = BS32H.decodeBase32Padded - , decodeHexNopad = BS32H.decodeBase32Unpadded - , correctHex = BS32H.isBase32Hex - , validateHex = BS32H.isValidBase32Hex + , encode = extractBase32 . BS32.encodeBase32' + , encodeNopad = extractBase32 . BS32.encodeBase32Unpadded' + , decodeTyped = BS32.decodeBase32 + , decodePaddedTyped = BS32.decodeBase32Padded + , decodeUnpaddedTyped = BS32.decodeBase32Unpadded + , decodeHexTyped = BS32H.decodeBase32 + , decodeHexPaddedTyped = BS32H.decodeBase32Padded + , decodeHexUnpaddedTyped = BS32H.decodeBase32Unpadded + , decode = BS32.decodeBase32Untyped + , decodePad = BS32.decodeBase32PaddedUntyped + , decodeNopad = BS32.decodeBase32UnpaddedUntyped + , parseValue = fmap extractBase32 . BS32.parseBase32Padded + , parseHexValue = fmap extractBase32 . BS32H.parseBase32Padded + , parsePaddedValue = fmap extractBase32 . BS32.parseBase32Padded + , parseUnpaddedValue = fmap extractBase32 . BS32.parseBase32Unpadded + , parseHexPaddedValue = fmap extractBase32 . BS32H.parseBase32Padded + , parseHexUnpaddedValue = fmap extractBase32 . BS32H.parseBase32Unpadded + , correct = isRight . BS32.decodeBase32Untyped + , validate = isRight . BS32.decodeBase32Untyped + , encodeHex = extractBase32 . BS32H.encodeBase32' + , encodeHexNopad = extractBase32 . BS32H.encodeBase32Unpadded' + , decodeHex = BS32H.decodeBase32Untyped + , decodeHexPad = BS32H.decodeBase32PaddedUntyped + , decodeHexNopad = BS32H.decodeBase32UnpaddedUntyped + , correctHex = isRight . BS32H.decodeBase32Untyped + , validateHex = isRight . BS32H.decodeBase32Untyped } t32 :: Harness T.Text t32 = Harness { label = "Text" - , encode = T32.encodeBase32 - , encodeNopad = T32.encodeBase32Unpadded - , decode = T32.decodeBase32 - , decodePad = T32.decodeBase32Padded - , decodeNopad = T32.decodeBase32Unpadded - , correct = T32.isBase32 - , validate = T32.isValidBase32 - , encodeHex = T32H.encodeBase32 - , encodeHexNopad = T32H.encodeBase32Unpadded - , decodeHex = T32H.decodeBase32 - , decodeHexPad = T32H.decodeBase32Padded - , decodeHexNopad = T32H.decodeBase32Unpadded - , correctHex = T32H.isBase32Hex - , validateHex = T32H.isValidBase32Hex + , encode = extractBase32 . T32.encodeBase32 + , encodeNopad = extractBase32 . T32.encodeBase32Unpadded + , decodeTyped = T32.decodeBase32 + , decodePaddedTyped = T32.decodeBase32Padded + , decodeUnpaddedTyped = T32.decodeBase32Unpadded + , decodeHexTyped = T32H.decodeBase32 + , decodeHexPaddedTyped = T32H.decodeBase32Padded + , decodeHexUnpaddedTyped = T32H.decodeBase32Unpadded + , decode = T32.decodeBase32Untyped + , decodePad = T32.decodeBase32PaddedUntyped + , decodeNopad = T32.decodeBase32UnpaddedUntyped + , parseValue = fmap extractBase32 . T32.parseBase32Padded + , parseHexValue = fmap extractBase32 . T32H.parseBase32Padded + , parsePaddedValue = fmap extractBase32 . T32.parseBase32Padded + , parseUnpaddedValue = fmap extractBase32 . T32.parseBase32Unpadded + , parseHexPaddedValue = fmap extractBase32 . T32H.parseBase32Padded + , parseHexUnpaddedValue = fmap extractBase32 . T32H.parseBase32Unpadded + , correct = isRight . T32.decodeBase32Untyped + , validate = isRight . T32.decodeBase32Untyped + , encodeHex = extractBase32 . T32H.encodeBase32 + , encodeHexNopad = extractBase32 . T32H.encodeBase32Unpadded + , decodeHex = T32H.decodeBase32Untyped + , decodeHexPad = T32H.decodeBase32PaddedUntyped + , decodeHexNopad = T32H.decodeBase32UnpaddedUntyped + , correctHex = isRight . T32H.decodeBase32Untyped + , validateHex = isRight . T32H.decodeBase32Untyped } tl32 :: Harness TL.Text tl32 = Harness { label = "Lazy Text" - , encode = TL32.encodeBase32 - , encodeNopad = TL32.encodeBase32Unpadded - , decode = TL32.decodeBase32 - , decodePad = TL32.decodeBase32Padded - , decodeNopad = TL32.decodeBase32Unpadded - , correct = TL32.isBase32 - , validate = TL32.isValidBase32 - , encodeHex = TL32H.encodeBase32 - , encodeHexNopad = TL32H.encodeBase32Unpadded - , decodeHex = TL32H.decodeBase32 - , decodeHexPad = TL32H.decodeBase32Padded - , decodeHexNopad = TL32H.decodeBase32Unpadded - , correctHex = TL32H.isBase32Hex - , validateHex = TL32H.isValidBase32Hex + , encode = extractBase32 . TL32.encodeBase32 + , encodeNopad = extractBase32 . TL32.encodeBase32Unpadded + , decodeTyped = TL32.decodeBase32 + , decodePaddedTyped = TL32.decodeBase32Padded + , decodeUnpaddedTyped = TL32.decodeBase32Unpadded + , decodeHexTyped = TL32H.decodeBase32 + , decodeHexPaddedTyped = TL32H.decodeBase32Padded + , decodeHexUnpaddedTyped = TL32H.decodeBase32Unpadded + , decode = TL32.decodeBase32Untyped + , decodePad = TL32.decodeBase32PaddedUntyped + , decodeNopad = TL32.decodeBase32UnpaddedUntyped + , parseValue = fmap extractBase32 . TL32.parseBase32Padded + , parseHexValue = fmap extractBase32 . TL32H.parseBase32Padded + , parsePaddedValue = fmap extractBase32 . TL32.parseBase32Padded + , parseUnpaddedValue = fmap extractBase32 . TL32.parseBase32Unpadded + , parseHexPaddedValue = fmap extractBase32 . TL32H.parseBase32Padded + , parseHexUnpaddedValue = fmap extractBase32 . TL32H.parseBase32Unpadded + , correct = isRight . TL32.decodeBase32Untyped + , validate = isRight . TL32.decodeBase32Untyped + , encodeHex = extractBase32 . TL32H.encodeBase32 + , encodeHexNopad = extractBase32 . TL32H.encodeBase32Unpadded + , decodeHex = TL32H.decodeBase32Untyped + , decodeHexPad = TL32H.decodeBase32PaddedUntyped + , decodeHexNopad = TL32H.decodeBase32UnpaddedUntyped + , correctHex = isRight . TL32H.decodeBase32Untyped + , validateHex = isRight . TL32H.decodeBase32Untyped } ts32 :: Harness TS.ShortText ts32 = Harness { label = "Short Lazy Text" - , encode = TS32.encodeBase32 - , encodeNopad = TS32.encodeBase32Unpadded - , decode = TS32.decodeBase32 - , decodePad = TS32.decodeBase32Padded - , decodeNopad = TS32.decodeBase32Unpadded - , correct = TS32.isBase32 - , validate = TS32.isValidBase32 - , encodeHex = TS32H.encodeBase32 - , encodeHexNopad = TS32H.encodeBase32Unpadded - , decodeHex = TS32H.decodeBase32 - , decodeHexPad = TS32H.decodeBase32Padded - , decodeHexNopad = TS32H.decodeBase32Unpadded - , correctHex = TS32H.isBase32Hex - , validateHex = TS32H.isValidBase32Hex + , encode = extractBase32 . TS32.encodeBase32 + , encodeNopad = extractBase32 . TS32.encodeBase32Unpadded + , decodeTyped = TS32.decodeBase32 + , decodePaddedTyped = TS32.decodeBase32Padded + , decodeUnpaddedTyped = TS32.decodeBase32Unpadded + , decodeHexTyped = TS32H.decodeBase32 + , decodeHexPaddedTyped = TS32H.decodeBase32Padded + , decodeHexUnpaddedTyped = TS32H.decodeBase32Unpadded + , decode = TS32.decodeBase32Untyped + , decodePad = TS32.decodeBase32PaddedUntyped + , decodeNopad = TS32.decodeBase32UnpaddedUntyped + , parseValue = fmap extractBase32 . TS32.parseBase32Padded + , parseHexValue = fmap extractBase32 . TS32H.parseBase32Padded + , parsePaddedValue = fmap extractBase32 . TS32.parseBase32Padded + , parseUnpaddedValue = fmap extractBase32 . TS32.parseBase32Unpadded + , parseHexPaddedValue = fmap extractBase32 . TS32H.parseBase32Padded + , parseHexUnpaddedValue = fmap extractBase32 . TS32H.parseBase32Unpadded + , correct = isRight . TS32.decodeBase32Untyped + , validate = isRight . TS32.decodeBase32Untyped + , encodeHex = extractBase32 . TS32H.encodeBase32 + , encodeHexNopad = extractBase32 . TS32H.encodeBase32Unpadded + , decodeHex = TS32H.decodeBase32Untyped + , decodeHexPad = TS32H.decodeBase32PaddedUntyped + , decodeHexNopad = TS32H.decodeBase32UnpaddedUntyped + , correctHex = isRight . TS32H.decodeBase32Untyped + , validateHex = isRight . TS32H.decodeBase32Untyped } -- -------------------------------------------------------------------- -- @@ -200,11 +287,16 @@ data TextHarness bs cs = TextHarness { decodeWith_ :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs - , decodePaddedWith_ :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs - , decodeUnpaddedWith_ :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs - , decodeHexWith_ :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs - , decodeHexPaddedWith_ :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs - , decodeHexUnpaddedWith_ :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs + , decodePaddedWith_ + :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs + , decodeUnpaddedWith_ + :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs + , decodeHexWith_ + :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs + , decodeHexPaddedWith_ + :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs + , decodeHexUnpaddedWith_ + :: forall err. (bs -> Either err cs) -> bs -> Either (Base32Error err) cs } tt32 :: TextHarness BS.ByteString Text diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -1,5 +1,4 @@ {-# LANGUAGE MultiWayIf #-} -{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PackageImports #-} {-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE ScopedTypeVariables #-} @@ -8,7 +7,7 @@ {-# LANGUAGE RecordWildCards #-} -- | -- Module : Main --- Copyright : (c) 2019-2023 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -22,24 +21,21 @@ ) where +import Data.Base32.Types (extractBase32) import Data.Bifunctor (second) import qualified "memory" Data.ByteArray.Encoding as Mem import qualified Data.ByteString as BS -import Data.ByteString.Internal (c2w) import "base32" Data.ByteString.Base32 as B32 -import "base32" Data.ByteString.Base32.Hex as B32H -import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Short as SBS -import Data.String (IsString) -import qualified Data.Text as T +import Data.String (IsString, fromString) +import qualified Data.Text as Text import qualified Data.Text.Encoding as T import Data.Text.Encoding.Base32.Error (Base32Error(..)) -import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL import qualified Data.Text.Short as TS -import Data.Word import Internal +import Regression (regressions) import Test.Tasty import Test.Tasty.HUnit @@ -54,7 +50,8 @@ tests :: TestTree tests = testGroup "Base32 Tests" - [ mkTree b32 + [ regressions + , mkTree b32 [ mkPropTree , mkUnitTree ] @@ -206,8 +203,9 @@ prop_mem_coherence :: TestTree prop_mem_coherence = testGroup "prop_mem_coherence" [ testProperty "prop_std_mem_coherence" $ \bs -> - Right bs == B32.decodeBase32 (B32.encodeBase32' bs) - && Right bs == Mem.convertFromBase Mem.Base32 (Mem.convertToBase @BS.ByteString @BS.ByteString Mem.Base32 bs) + Right bs == B32.decodeBase32Untyped (extractBase32 (B32.encodeBase32' bs)) + && Right bs == Mem.convertFromBase Mem.Base32 + (Mem.convertToBase @BS.ByteString @BS.ByteString Mem.Base32 bs) ] -- ---------------------------------------------------------------- -- @@ -240,18 +238,18 @@ testCaseStd s t = testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do step "encode is sound" - t @=? encode s + fromString t @=? encode (fromString s) step "decode is sound" - Right s @=? decode (encode s) + Right (fromString s) @=? decode (encode (fromString s)) testCaseHex s t = testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do step "encode is sound" - t @=? encodeHex s + fromString t @=? encodeHex (fromString s) step "decode is sound" - Right s @=? decodeHexPad t + Right (fromString s) @=? decodeHexPad (fromString t) -- | Unit test trees for the `decode*With` family of text-valued functions -- @@ -268,78 +266,87 @@ decodeWithVectors utf8 TextHarness{..} s t = testGroup "DecodeWith* unit tests" [ testGroup "decodeWith negative tests" [ testCase "decodeWith non-utf8 inputs on decodeUtf8" $ do - case decodeWith_ utf8 "\1079743" of + case decodeWith_ utf8 (fromString "\1079743") of Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodeWith valid utf8 inputs on decodeUtf8" $ do - case decodeWith_ utf8 (encode s "\1079743") of + case decodeWith_ utf8 (encode s (fromString "\1079743")) of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" , testCase "decodeHexWith non-utf8 inputs on decodeUtf8" $ do - case decodeHexWith_ utf8 "\1079743" of + case decodeHexWith_ utf8 (fromString "\1079743") of Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodePaddedWith non-utf8 inputs on decodeUtf8" $ do - case decodePaddedWith_ utf8 "\1079743" of + case decodePaddedWith_ utf8 (fromString "\1079743") of Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodePaddedWith valid utf8 inputs on decodeUtf8" $ do - case decodePaddedWith_ utf8 (encode s "\1079743") of + case decodePaddedWith_ utf8 (encode s (fromString "\1079743")) of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" , testCase "decodeUnpaddedWith non-utf8 inputs on decodeUtf8" $ do - case decodeUnpaddedWith_ utf8 "\1079743" of + case decodeUnpaddedWith_ utf8 (fromString "\1079743") of Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodeUnpaddedWith valid utf8 inputs on decodeUtf8" $ do - case decodeUnpaddedWith_ utf8 (encodeNopad s "\1079743") of + case decodeUnpaddedWith_ utf8 (encodeNopad s (fromString "\1079743")) of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" , testCase "decodeHexWith valid utf8 inputs on decodeUtf8" $ do - case decodeHexWith_ utf8 (encodeHex s "\1079743") of + case decodeHexWith_ utf8 (encodeHex s (fromString "\1079743")) of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" , testCase "decodeHexPaddedWith non-utf8 inputs on decodeUtf8" $ do - case decodeHexPaddedWith_ utf8 "\1079743" of + case decodeHexPaddedWith_ utf8 (fromString "\1079743") of Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodeHexPaddedWith valid utf8 inputs on decodeUtf8" $ do - case decodeHexPaddedWith_ utf8 (encodeHex s "\1079743") of + case decodeHexPaddedWith_ utf8 (encodeHex s (fromString "\1079743")) of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" , testCase "decodeHexUnpaddedWith non-utf8 inputs on decodeUtf8" $ do - case decodeHexUnpaddedWith_ utf8 "\1079743" of + case decodeHexUnpaddedWith_ utf8 (fromString "\1079743") of Left (DecodeError _) -> return () _ -> assertFailure "decoding phase" , testCase "decodeHexUnpaddedWith valid utf8 inputs on decodeUtf8" $ do - case decodeHexUnpaddedWith_ utf8 (encodeHexNopad s "\1079743") of + case decodeHexUnpaddedWith_ utf8 (encodeHexNopad s (fromString "\1079743")) of Left (ConversionError _) -> return () _ -> assertFailure "conversion phase" ] , testGroup "decodeWith positive tests" [ testCase "decodeWith utf8 inputs on decodeUtf8" $ do - a <- either (assertFailure . show) pure $ decode t "MZXW6YTBOI======" - b <- either (assertFailure . show) pure $ decodeWith_ utf8 "MZXW6YTBOI======" + a <- either (assertFailure . show) pure $ decode t (fromString "MZXW6YTBOI======") + b <- either (assertFailure . show) pure $ + decodeWith_ utf8 (fromString "MZXW6YTBOI======") a @=? b , testCase "decodePaddedWith utf8 inputs on decodeUtf8" $ do - a <- either (assertFailure . show) pure $ decodePad t "MZXW6YTBOI======" - b <- either (assertFailure . show) pure $ decodePaddedWith_ utf8 "MZXW6YTBOI======" + a <- either (assertFailure . show) pure $ + decodePad t (fromString "MZXW6YTBOI======") + b <- either (assertFailure . show) pure $ + decodePaddedWith_ utf8 (fromString "MZXW6YTBOI======") a @=? b , testCase "decodeUnpaddedWith utf8 inputs on decodeUtf8" $ do - a <- either (assertFailure . show) pure $ decodeNopad t "MZXW6YTBOI" - b <- either (assertFailure . show) pure $ decodeUnpaddedWith_ utf8 "MZXW6YTBOI" + a <- either (assertFailure . show) pure $ decodeNopad t (fromString "MZXW6YTBOI") + b <- either (assertFailure . show) pure $ + decodeUnpaddedWith_ utf8 (fromString "MZXW6YTBOI") a @=? b , testCase "decodeHexWith utf8 inputs on decodeUtf8" $ do - a <- either (assertFailure . show) pure $ decodeHex t "CPNMUOJ1E8======" - b <- either (assertFailure . show) pure $ decodeHexWith_ utf8 "CPNMUOJ1E8======" + a <- either (assertFailure . show) pure $ + decodeHex t (fromString "CPNMUOJ1E8======") + b <- either (assertFailure . show) pure $ + decodeHexWith_ utf8 (fromString "CPNMUOJ1E8======") a @=? b , testCase "decodeHexPaddedWith utf8 inputs on decodeUtf8" $ do - a <- either (assertFailure . show) pure $ decodeHexPad t "CPNMUOJ1E8======" - b <- either (assertFailure . show) pure $ decodeHexPaddedWith_ utf8 "CPNMUOJ1E8======" + a <- either (assertFailure . show) pure $ + decodeHexPad t (fromString "CPNMUOJ1E8======") + b <- either (assertFailure . show) pure $ + decodeHexPaddedWith_ utf8 (fromString "CPNMUOJ1E8======") a @=? b , testCase "decodeHexUnpaddedWith utf8 inputs on decodeUtf8" $ do - a <- either (assertFailure . show) pure $ decodeHexNopad t "CPNMUOJ1" - b <- either (assertFailure . show) pure $ decodeHexUnpaddedWith_ utf8 "CPNMUOJ1" + a <- either (assertFailure . show) pure $ decodeHexNopad t (fromString "CPNMUOJ1") + b <- either (assertFailure . show) pure $ + decodeHexUnpaddedWith_ utf8 (fromString "CPNMUOJ1") a @=? b ] ] @@ -350,63 +357,63 @@ validityTests Harness{..} = testGroup "Validity and correctness unit tests" [ testGroup "Validity unit tests" [ testCase "Hex padding tests" $ do - not (validateHex "C") @? "C" - validateHex "CO" @? "CO" - validateHex "CPNG" @? "CPNG" - validateHex "CPNMU" @? "CPNMU" - validateHex "CPNMUOG" @? "CPNMUOG" - validateHex "CPNMUOJ1" @? "CPNMUOJ1" - validateHex "CPNMUOJ1E8" @? "CPNMUOJ1E8" - validateHex "CO======" @? "CO======" - validateHex "CPNG====" @? "CPNG====" - validateHex "CPNMU===" @? "CPNMU===" - validateHex "CPNMUOG=" @? "CPNMUOG=" - validateHex "CPNMUOJ1" @? "CPNMUOJ1" - validateHex "CPNMUOJ1E8======" @? "CPNMUOJ1E8======" + not (validateHex (fromString "C")) @? "C" + validateHex (fromString "CO") @? "CO" + validateHex (fromString "CPNG") @? "CPNG" + validateHex (fromString "CPNMU") @? "CPNMU" + validateHex (fromString "CPNMUOG") @? "CPNMUOG" + validateHex (fromString "CPNMUOJ1") @? "CPNMUOJ1" + validateHex (fromString "CPNMUOJ1E8") @? "CPNMUOJ1E8" + validateHex (fromString "CO======") @? "CO======" + validateHex (fromString "CPNG====") @? "CPNG====" + validateHex (fromString "CPNMU===") @? "CPNMU===" + validateHex (fromString "CPNMUOG=") @? "CPNMUOG=" + validateHex (fromString "CPNMUOJ1") @? "CPNMUOJ1" + validateHex (fromString "CPNMUOJ1E8======") @? "CPNMUOJ1E8======" , testCase "Std padding tests" $ do - not (validate "M") @? "M" - validate "MY" @? "MY" - validate "MZXQ" @? "MZXQ" - validate "MZXW6" @? "MZXW6" - validate "MZXW6YQ" @? "MZXW6YQ" - validate "MZXW6YTB" @? "MZXW6YTB" - validate "MZXW6YTBOI" @? "MZXW6YTBOI" - validate "MY======" @? "MY======" - validate "MZXQ====" @? "MZXQ====" - validate "MZXW6===" @? "MZXW6===" - validate "MZXW6YQ=" @? "MZXW6YQ=" - validate "MZXW6YTB" @? "MZXW6YTB" - validate "MZXW6YTBOI======" @? "MZXW6YTBOI======" + not (validate (fromString "M")) @? "M" + validate (fromString "MY") @? "MY" + validate (fromString "MZXQ") @? "MZXQ" + validate (fromString "MZXW6") @? "MZXW6" + validate (fromString "MZXW6YQ") @? "MZXW6YQ" + validate (fromString "MZXW6YTB") @? "MZXW6YTB" + validate (fromString "MZXW6YTBOI") @? "MZXW6YTBOI" + validate (fromString "MY======") @? "MY======" + validate (fromString "MZXQ====") @? "MZXQ====" + validate (fromString "MZXW6===") @? "MZXW6===" + validate (fromString "MZXW6YQ=") @? "MZXW6YQ=" + validate (fromString "MZXW6YTB") @? "MZXW6YTB" + validate (fromString "MZXW6YTBOI======") @? "MZXW6YTBOI======" ] , testGroup "Correctness unit tests" [ testCase "Hex tests" $ do - not (correctHex "C") @? "C" - correctHex "CO" @? "CO" - correctHex "CPNG" @? "CPNG" - correctHex "CPNMU" @? "CPNMU" - correctHex "CPNMUOG" @? "CPNMUOG" - correctHex "CPNMUOJ1" @? "CPNMUOJ1" - correctHex "CPNMUOJ1E8" @? "CPNMUOJ1E8" - correctHex "CO======" @? "CO======" - correctHex "CPNG====" @? "CPNG====" - correctHex "CPNMU===" @? "CPNMU===" - correctHex "CPNMUOG=" @? "CPNMUOG=" - correctHex "CPNMUOJ1" @? "CPNMUOJ1" - correctHex "CPNMUOJ1E8======" @? "CPNMUOJ1E8======" + not (correctHex (fromString "C")) @? "C" + correctHex (fromString "CO") @? "CO" + correctHex (fromString "CPNG") @? "CPNG" + correctHex (fromString "CPNMU") @? "CPNMU" + correctHex (fromString "CPNMUOG") @? "CPNMUOG" + correctHex (fromString "CPNMUOJ1") @? "CPNMUOJ1" + correctHex (fromString "CPNMUOJ1E8") @? "CPNMUOJ1E8" + correctHex (fromString "CO======") @? "CO======" + correctHex (fromString "CPNG====") @? "CPNG====" + correctHex (fromString "CPNMU===") @? "CPNMU===" + correctHex (fromString "CPNMUOG=") @? "CPNMUOG=" + correctHex (fromString "CPNMUOJ1") @? "CPNMUOJ1" + correctHex (fromString "CPNMUOJ1E8======") @? "CPNMUOJ1E8======" , testCase "Std tests" $ do - not (correct "M") @? "M" - correct "MY" @? "MY" - correct "MZXQ" @? "MZXQ" - correct "MZXW6" @? "MZXW6" - correct "MZXW6YQ" @? "MZXW6YQ" - correct "MZXW6YTB" @? "MZXW6YTB" - correct "MZXW6YTBOI" @? "MZXW6YTBOI" - correct "MY======" @? "MY======" - correct "MZXQ====" @? "MZXQ====" - correct "MZXW6===" @? "MZXW6===" - correct "MZXW6YQ=" @? "MZXW6YQ=" - correct "MZXW6YTB" @? "MZXW6YTB" - correct "MZXW6YTBOI======" @? "MZXW6YTBOI======" + not (correct (fromString "M")) @? "M" + correct (fromString "MY") @? "MY" + correct (fromString "MZXQ") @? "MZXQ" + correct (fromString "MZXW6") @? "MZXW6" + correct (fromString "MZXW6YQ") @? "MZXW6YQ" + correct (fromString "MZXW6YTB") @? "MZXW6YTB" + correct (fromString "MZXW6YTBOI") @? "MZXW6YTBOI" + correct (fromString "MY======") @? "MY======" + correct (fromString "MZXQ====") @? "MZXQ====" + correct (fromString "MZXW6===") @? "MZXW6===" + correct (fromString "MZXW6YQ=") @? "MZXW6YQ=" + correct (fromString "MZXW6YTB") @? "MZXW6YTB" + correct (fromString "MZXW6YTBOI======") @? "MZXW6YTBOI======" ] ] @@ -417,42 +424,74 @@ offsetVectors Harness{..} = testGroup "Offset tests" [ testGroup "Hex - Invalid padding" [ testCase "Invalid staggered padding" $ do - decodeHex "=PNMUOJ1E8======" @?= Left "invalid padding at offset: 0" - decodeHex "C=NMUOJ1E8======" @?= Left "invalid padding at offset: 1" - decodeHex "CP=MUOJ1E8======" @?= Left "invalid padding at offset: 2" - decodeHex "CPN=UOJ1E8======" @?= Left "invalid padding at offset: 3" - decodeHex "CPNM=OJ1E8======" @?= Left "invalid padding at offset: 4" - decodeHex "CPNMU=J1E8======" @?= Left "invalid padding at offset: 5" - decodeHex "CPNMUO=1E8======" @?= Left "invalid padding at offset: 6" - decodeHex "CPNMUOJ=E8======" @?= Left "invalid padding at offset: 7" + decodeHex (fromString "=PNMUOJ1E8======") + @?= Left (Text.pack "invalid padding at offset: 0") + decodeHex (fromString "C=NMUOJ1E8======") + @?= Left (Text.pack "invalid padding at offset: 1") + decodeHex (fromString "CP=MUOJ1E8======") + @?= Left (Text.pack "invalid padding at offset: 2") + decodeHex (fromString "CPN=UOJ1E8======") + @?= Left (Text.pack "invalid padding at offset: 3") + decodeHex (fromString "CPNM=OJ1E8======") + @?= Left (Text.pack "invalid padding at offset: 4") + decodeHex (fromString "CPNMU=J1E8======") + @?= Left (Text.pack "invalid padding at offset: 5") + decodeHex (fromString "CPNMUO=1E8======") + @?= Left (Text.pack "invalid padding at offset: 6") + decodeHex (fromString "CPNMUOJ=E8======") + @?= Left (Text.pack "invalid padding at offset: 7") , testCase "Invalid character coverage" $ do - decodeHex "%PNMUOJ1E8======" @?= Left "invalid character at offset: 0" - decodeHex "C%NMUOJ1E8======" @?= Left "invalid character at offset: 1" - decodeHex "CP%MUOJ1E8======" @?= Left "invalid character at offset: 2" - decodeHex "CPN%UOJ1E8======" @?= Left "invalid character at offset: 3" - decodeHex "CPNM%OJ1E8======" @?= Left "invalid character at offset: 4" - decodeHex "CPNMU%J1E8======" @?= Left "invalid character at offset: 5" - decodeHex "CPNMUO%1E8======" @?= Left "invalid character at offset: 6" - decodeHex "CPNMUOJ%E8======" @?= Left "invalid character at offset: 7" + decodeHex (fromString "%PNMUOJ1E8======") + @?= Left (Text.pack "invalid character at offset: 0") + decodeHex (fromString "C%NMUOJ1E8======") + @?= Left (Text.pack "invalid character at offset: 1") + decodeHex (fromString "CP%MUOJ1E8======") + @?= Left (Text.pack "invalid character at offset: 2") + decodeHex (fromString "CPN%UOJ1E8======") + @?= Left (Text.pack "invalid character at offset: 3") + decodeHex (fromString "CPNM%OJ1E8======") + @?= Left (Text.pack "invalid character at offset: 4") + decodeHex (fromString "CPNMU%J1E8======") + @?= Left (Text.pack "invalid character at offset: 5") + decodeHex (fromString "CPNMUO%1E8======") + @?= Left (Text.pack "invalid character at offset: 6") + decodeHex (fromString "CPNMUOJ%E8======") + @?= Left (Text.pack "invalid character at offset: 7") ] , testGroup "Std - Invalid padding" [ testCase "Invalid staggered padding" $ do - decode "=ZXW6YTBOI======" @?= Left "invalid padding at offset: 0" - decode "M=XW6YTBOI======" @?= Left "invalid padding at offset: 1" - decode "MZ=W6YTBOI======" @?= Left "invalid padding at offset: 2" - decode "MZX=6YTBOI======" @?= Left "invalid padding at offset: 3" - decode "MZXW=YTBOI======" @?= Left "invalid padding at offset: 4" - decode "MZXW6=TBOI======" @?= Left "invalid padding at offset: 5" - decode "MZXW6Y=BOI======" @?= Left "invalid padding at offset: 6" - decode "MZXW6YT=OI======" @?= Left "invalid padding at offset: 7" + decode (fromString "=ZXW6YTBOI======") + @?= Left (Text.pack "invalid padding at offset: 0") + decode (fromString "M=XW6YTBOI======") + @?= Left (Text.pack "invalid padding at offset: 1") + decode (fromString "MZ=W6YTBOI======") + @?= Left (Text.pack "invalid padding at offset: 2") + decode (fromString "MZX=6YTBOI======") + @?= Left (Text.pack "invalid padding at offset: 3") + decode (fromString "MZXW=YTBOI======") + @?= Left (Text.pack "invalid padding at offset: 4") + decode (fromString "MZXW6=TBOI======") + @?= Left (Text.pack "invalid padding at offset: 5") + decode (fromString "MZXW6Y=BOI======") + @?= Left (Text.pack "invalid padding at offset: 6") + decode (fromString "MZXW6YT=OI======") + @?= Left (Text.pack "invalid padding at offset: 7") , testCase "Invalid character coverage" $ do - decode "%ZXW6YTBOI======" @?= Left "invalid character at offset: 0" - decode "M%XW6YTBOI======" @?= Left "invalid character at offset: 1" - decode "MZ%W6YTBOI======" @?= Left "invalid character at offset: 2" - decode "MZX%6YTBOI======" @?= Left "invalid character at offset: 3" - decode "MZXW%YTBOI======" @?= Left "invalid character at offset: 4" - decode "MZXW6%TBOI======" @?= Left "invalid character at offset: 5" - decode "MZXW6Y%BOI======" @?= Left "invalid character at offset: 6" - decode "MZXW6YT%OI======" @?= Left "invalid character at offset: 7" + decode (fromString "%ZXW6YTBOI======") + @?= Left (Text.pack "invalid character at offset: 0") + decode (fromString "M%XW6YTBOI======") + @?= Left (Text.pack "invalid character at offset: 1") + decode (fromString "MZ%W6YTBOI======") + @?= Left (Text.pack "invalid character at offset: 2") + decode (fromString "MZX%6YTBOI======") + @?= Left (Text.pack "invalid character at offset: 3") + decode (fromString "MZXW%YTBOI======") + @?= Left (Text.pack "invalid character at offset: 4") + decode (fromString "MZXW6%TBOI======") + @?= Left (Text.pack "invalid character at offset: 5") + decode (fromString "MZXW6Y%BOI======") + @?= Left (Text.pack "invalid character at offset: 6") + decode (fromString "MZXW6YT%OI======") + @?= Left (Text.pack "invalid character at offset: 7") ] ] diff --git a/test/Regression.hs b/test/Regression.hs new file mode 100644 --- /dev/null +++ b/test/Regression.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeApplications #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} +-- | +-- Module : Regression +-- Copyright : (c) 2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- Regression tests for typed codecs, parsing, and buffer boundaries. +-- +module Regression (regressions) where + +import Control.Concurrent (forkIO, killThread, threadDelay) +import Control.DeepSeq (force) +import Control.Exception (ErrorCall, bracket, evaluate, try) +import Control.Monad (forM_, forever, replicateM) +import Data.Base32.Types +import Data.Bits (xor) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Base32 as B +import qualified Data.ByteString.Base32.Hex as H +import Data.ByteString.Base32.Internal.Head (decodeBase32_, encodeBase32_) +import Data.ByteString.Base32.Internal.Short (decodeShort, encodeShort) +import Data.ByteString.Base32.Internal.Tables (stdDecodeTable) +import Data.ByteString.Base32.Internal.Utils (encodedLength) +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Lazy.Base32 as L +import qualified Data.ByteString.Short as SBS +import qualified Data.ByteString.Short.Base32 as S +import qualified Data.ByteString.Short.Base32.Hex as SH +import Data.Either (isLeft, isRight) +import Data.String (IsString, fromString) +import qualified Data.Text as T +import qualified Data.Text.Encoding.Base32 as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding.Base32 as TL +import qualified Data.Text.Short as TS +import qualified Data.Text.Short.Encoding.Base32 as TS +import Foreign.Marshal.Array (peekArray, withArray) +import Internal +import System.Mem (performGC) +import System.Timeout (timeout) +import Test.QuickCheck hiding (label) +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck (testProperty) + +regressions :: TestTree +regressions = + testGroup + "Release regressions" + [ testCase "custom alphabets and tables retain scalar semantics" $ do + let input = BS.pack (take 1000 (cycle [0 .. 255])) + alphabet = "ACBDEFGHIJKLMNOPQRSTUVWXYZ234567"# + swap w + | w == 66 = 67 + | w == 67 = 66 + | otherwise = w + expected = BS.map swap (extractBase32 (B.encodeBase32' input)) + encodeBase32_ alphabet input @?= expected + encodeShort alphabet True (SBS.toShort input) @?= SBS.toShort expected + table <- peekArray 256 stdDecodeTable + let replace i w + | i == 66 = 2 + | i == 67 = 1 + | otherwise = w + withArray (zipWith replace [0 :: Int ..] table) $ \custom -> do + decodeBase32_ custom expected >>= (@?= Right input) + decodeShort custom (SBS.toShort expected) + @?= Right (SBS.toShort input) + , testCase "allocation lengths reject overflow before allocation" $ do + forM_ [-1, maxBound] $ \n -> do + result <- try (evaluate (encodedLength n)) :: IO (Either ErrorCall Int) + assertBool "expected checked capacity failure" (isLeft result) + map encodedLength [0 .. 5] @?= [0, 8, 8, 8, 8, 8] + , testCase "strict codecs handle sliced inputs" $ + forM_ [0 .. 31] $ \offset -> do + let payload = BS.pack (take 1001 (cycle [0 .. 255])) + input = BS.drop offset (BS.replicate offset 99 <> payload) + encoded = extractBase32 (B.encodeBase32' input) + sliced = BS.drop offset (BS.replicate offset 99 <> encoded) + B.decodeBase32Untyped sliced @?= Right payload + B.decodeBase32 (assertBase32 @'StdPadded sliced) @?= payload + , parserTests b32 + , parserTests lb32 + , parserTests sb32 + , parserTests t32 + , parserTests tl32 + , parserTests ts32 + , testCase "strict and short SIMD boundaries, both alphabets" $ + forM_ ([0 .. 170] ++ [255, 256, 257, 1023, 1024, 1025, 100000]) $ \n -> do + let input = BS.pack (take n (cycle [0 .. 255])) + short = SBS.toShort input + encoded = B.encodeBase32' input + encodedHex = H.encodeBase32' input + extractBase32 (S.encodeBase32' short) @?= SBS.toShort (extractBase32 encoded) + extractBase32 (SH.encodeBase32' short) + @?= SBS.toShort (extractBase32 encodedHex) + B.decodeBase32 encoded @?= input + H.decodeBase32 encodedHex @?= input + S.decodeBase32 (S.encodeBase32' short) @?= short + SH.decodeBase32 (SH.encodeBase32' short) @?= short + B.decodeBase32 (B.encodeBase32Unpadded' input) @?= input + S.decodeBase32 (S.encodeBase32Unpadded' short) @?= short + , testCase "typed lazy decoding streams without whole-input validation" $ do + output <- timeout 1000000 $ evaluate $ force $ + BL.take 16 (L.decodeBase32 (L.encodeBase32' (BL.repeat 255))) + output @?= Just (BL.replicate 16 255) + , testCase "parsed padding provenance selects the matching typed decoder" $ do + let padded = BS8.pack "MY======" + unpaddedHex = BS8.pack "CO" + decoded = BS8.pack "f" + fmap B.decodeBase32Padded (B.parseBase32Padded padded) @?= Right decoded + fmap H.decodeBase32Unpadded (H.parseBase32Unpadded unpaddedHex) + @?= Right decoded + fmap S.decodeBase32Padded (S.parseBase32Padded (SBS.toShort padded)) + @?= Right (SBS.toShort decoded) + fmap SH.decodeBase32Unpadded (SH.parseBase32Unpadded (SBS.toShort unpaddedHex)) + @?= Right (SBS.toShort decoded) + , testCase "lazy padding at every chunk boundary" $ do + let encoded = extractBase32 (B.encodeBase32' (BS.replicate 81 102)) + forM_ [0 .. BS.length encoded] $ \i -> do + let chunks = BL.fromChunks [BS.take i encoded, BS.drop i encoded] + fmap extractBase32 (L.parseBase32Padded chunks) @?= Right chunks + L.decodeBase32Untyped chunks @?= Right (BL.replicate 81 102) + L.decodeBase32 (assertBase32 @'StdPadded chunks) @?= BL.replicate 81 102 + , testCase "invalid bytes after SIMD prefixes keep global offsets" $ + forM_ [0 .. 159] $ \i -> do + let input = BS.replicate i 65 <> BS.singleton 33 <> BS.replicate (159 - i) 65 + expected = Left (T.pack ("invalid character at offset: " ++ show i)) + B.decodeBase32Untyped input @?= expected + S.decodeBase32Untyped (SBS.toShort input) @?= expected + , testCase "strict and short decoders agree on final padding" $ + forM_ [0, 80] $ \prefixLength -> + forM_ [0 .. 8] $ \tailLength -> + forM_ (replicateM tailLength [False, True]) $ \padding -> do + let input symbol = BS.replicate prefixLength symbol + <> BS.pack (map (\pad -> if pad then 0x3d else symbol) padding) + standard = input 65 + hex = input 48 + check raw decodeStrict decodeSmall = + decodeSmall (SBS.toShort raw) @?= fmap SBS.toShort (decodeStrict raw) + check standard B.decodeBase32Untyped S.decodeBase32Untyped + check standard B.decodeBase32PaddedUntyped S.decodeBase32PaddedUntyped + check standard B.decodeBase32UnpaddedUntyped S.decodeBase32UnpaddedUntyped + check hex H.decodeBase32Untyped SH.decodeBase32Untyped + check hex H.decodeBase32PaddedUntyped SH.decodeBase32PaddedUntyped + check hex H.decodeBase32UnpaddedUntyped SH.decodeBase32UnpaddedUntyped + , testProperty "strict and short malformed inputs agree" $ \(bytes :: [Word]) -> + let input = BS.pack (map fromIntegral bytes) + short = SBS.toShort input + in conjoin + [ fmap SBS.toShort (B.decodeBase32Untyped input) + === S.decodeBase32Untyped short + , fmap SBS.toShort (H.decodeBase32Untyped input) + === SH.decodeBase32Untyped short + , fmap SBS.toShort (B.decodeBase32PaddedUntyped input) + === S.decodeBase32PaddedUntyped short + , fmap SBS.toShort (B.decodeBase32UnpaddedUntyped input) + === S.decodeBase32UnpaddedUntyped short + ] + , testCase "text parsers accept binary; decoders check UTF-8" $ do + assertBool "binary parser" (isRight (T.parseBase32Padded (T.pack "74======"))) + assertBool "invalid UTF-8" (isLeft (T.decodeBase32Untyped (T.pack "74======"))) + assertBool "lazy invalid UTF-8" + (isLeft (TL.decodeBase32Untyped (TL.pack "74======"))) + assertBool "short invalid UTF-8" + (isLeft (TS.decodeBase32Untyped (TS.pack "74======"))) + , testCase "short arrays remain valid during concurrent collection" $ + bracket (forkIO (forever (performGC >> threadDelay 1000))) killThread $ \_ -> + forM_ [0 .. 99 :: Int] $ \salt -> do + let input = + SBS.toShort + ( BS.pack + [fromIntegral (i `xor` salt) | i <- [0 .. 8191 :: Int]] + ) + output <- evaluate (force (S.decodeBase32 (S.encodeBase32' input))) + output @?= input + , testCase "typed text roundtrip" $ do + T.decodeBase32 (T.encodeBase32 (T.pack "λ☃")) @?= T.pack "λ☃" + TS.decodeBase32 (TS.encodeBase32 (TS.pack "λ☃")) @?= TS.pack "λ☃" + ] + +parserTests :: + (Arbitrary a, IsString a, Eq a, Show a) => + Harness a -> + TestTree +parserTests Harness{..} = + testGroup + (label ++ " parsers") + [ testProperty "typed standard decoding preserves padding provenance" $ \input -> + let padded = assertBase32 @'StdPadded (encode input) + unpadded = assertBase32 @'StdUnpadded (encodeNopad input) + in conjoin + [ decodeTyped padded === input + , decodeTyped unpadded === input + , decodePaddedTyped padded === input + , decodeUnpaddedTyped unpadded === input + ] + , testProperty "typed hex decoding preserves padding provenance" $ \input -> + let padded = assertBase32 @'HexPadded (encodeHex input) + unpadded = assertBase32 @'HexUnpadded (encodeHexNopad input) + in conjoin + [ decodeHexTyped padded === input + , decodeHexTyped unpadded === input + , decodeHexPaddedTyped padded === input + , decodeHexUnpaddedTyped unpadded === input + ] + , testProperty "preserve padded standard input" $ \input -> + parsePaddedValue (encode input) === Right (encode input) + , testProperty "preserve unpadded hex input" $ \input -> + parseHexUnpaddedValue (encodeHexNopad input) === Right (encodeHexNopad input) + , testCase "preserve original letter case" $ do + parseValue (fromString "my======") @?= Right (fromString "my======") + parseHexValue (fromString "co======") @?= Right (fromString "co======") + decodeTyped (assertBase32 @'StdPadded (fromString "my======")) @?= fromString "f" + decodeHexTyped (assertBase32 @'HexPadded (fromString "co======")) + @?= fromString "f" + , testCase "enforce padding policies" $ do + assertBool "padded requires padding" (isLeft (parsePaddedValue (fromString "MY"))) + assertBool "unpadded rejects padding" + (isLeft (parseUnpaddedValue (fromString "MY======"))) + assertBool "hex padded requires padding" + (isLeft (parseHexPaddedValue (fromString "CO"))) + assertBool + "hex unpadded rejects padding" + (isLeft (parseHexUnpaddedValue (fromString "CO======"))) + parseValue (fromString "") @?= Right (fromString "") + parseHexValue (fromString "") @?= Right (fromString "") + , testCase "reject nonzero unused bits in all tail lengths" $ do + forM_ (map fromString + [ "MZ" + , "MZXR" + , "MZXW7" + , "MZXW6YR" + , "MZ======" + , "MZXR====" + , "MZXW7===" + , "MZXW6YR=" + ]) + $ \value -> + assertBool (show value) + (isLeft (parsePaddedValue value) && isLeft (parseUnpaddedValue value)) + forM_ (map fromString + [ "CP" + , "CPNH" + , "CPNMV" + , "CPNMUOH" + , "CP======" + , "CPNH====" + , "CPNMV===" + , "CPNMUOH=" + ]) + $ \value -> + assertBool (show value) + (isLeft (parseHexPaddedValue value) && isLeft (parseHexUnpaddedValue value)) + , testCase "parser and checked decoder report the same errors" $ + forM_ (map fromString + ["M", "!Y======", "MZ======", "MY====", "MY======MY======"]) $ \value -> + case decodePad value of + Left err -> parseValue value @?= Left err + Right _ -> assertFailure "expected malformed fixture" + ] diff --git a/test/simd-native.c b/test/simd-native.c new file mode 100644 --- /dev/null +++ b/test/simd-native.c @@ -0,0 +1,184 @@ +/* Copyright (c) 2026 Emily Pillmore. BSD-3-Clause; see LICENSE. */ +#include "base32_simd.h" +#include +#include +#include +#include +#if defined(__unix__) || defined(__APPLE__) +#include +#include +#endif + +static const char *alphabets[2] = { + "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567", "0123456789ABCDEFGHIJKLMNOPQRSTUV" +}; + +static void reference(const uint8_t *src, size_t len, uint8_t *dst, int hex) +{ + unsigned bits = 0, buffer = 0; + size_t out = 0; + for (size_t i = 0; i < len; ++i) { + buffer = (buffer << 8) | src[i]; + bits += 8; + while (bits >= 5) { + bits -= 5; + dst[out++] = (uint8_t)alphabets[hex][(buffer >> bits) & 31]; + } + } + if (bits) { + dst[out] = (uint8_t)alphabets[hex][(buffer << (5 - bits)) & 31]; + } +} + +static void boundaries(int hex) +{ + for (size_t len = 0; len <= 1024; ++len) { + for (size_t offset = 0; offset < 16; ++offset) { + size_t capacity = (len / 5) * 8; + uint8_t *allocation = malloc(len + offset + (len == 0)); + uint8_t *output = malloc(capacity + offset + 1); + uint8_t *expected = malloc((len * 8 + 4) / 5 + 1); + assert(allocation && output && expected); + uint8_t *src = allocation + offset; + uint8_t *dst = output + offset; + for (size_t i = 0; i < len; ++i) { + src[i] = (uint8_t)(i * 131 + len * 17); + } + memset(output, 0xa5, capacity + offset + 1); + reference(src, len, expected, hex); + size_t read = hs_base32_simd_encode(src, len, dst, hex); + assert(read <= len && read % 5 == 0); + if (hs_base32_simd_backend() && len >= 20) { + assert(read != 0); + } + size_t written = read / 5 * 8; + assert(memcmp(dst, expected, written) == 0); + for (size_t i = written; i <= capacity; ++i) { + assert(dst[i] == 0xa5); + } + for (size_t i = 0; i < offset; ++i) { + assert(output[i] == 0xa5); + } + /* Decode from an allocation that ends exactly at the input end. */ + uint8_t *encoded = malloc(written + offset + (written == 0)); + uint8_t *decoded = malloc(read + offset + 1); + assert(encoded && decoded); + memcpy(encoded + offset, expected, written); + memset(decoded, 0xa5, read + offset + 1); + size_t used = hs_base32_simd_decode(encoded + offset, written, + decoded + offset, hex); + assert(used <= written && used % 8 == 0); + assert(used == (hs_base32_simd_backend() ? written : 0)); + assert(memcmp(decoded + offset, src, used / 8 * 5) == 0); + for (size_t i = used / 8 * 5; i <= read; ++i) { + assert(decoded[offset + i] == 0xa5); + } + for (size_t i = 0; i < offset; ++i) { + assert(decoded[i] == 0xa5); + } + memset(decoded, 0xa5, read + offset + 1); + used = hs_base32_simd_decode_typed(encoded + offset, written, + decoded + offset, hex); + assert(used == (hs_base32_simd_backend() ? written : 0)); + assert(memcmp(decoded + offset, src, used / 8 * 5) == 0); + for (size_t i = used / 8 * 5; i <= read; ++i) { + assert(decoded[offset + i] == 0xa5); + } + for (size_t i = 0; i < offset; ++i) { + assert(decoded[i] == 0xa5); + } + free(encoded); + free(decoded); + free(allocation); + free(output); + free(expected); + } + } +} + +static void malformed(int hex) +{ + uint8_t payload[80], encoded[128], changed[128], decoded[80]; + for (size_t i = 0; i < sizeof payload; ++i) { + payload[i] = (uint8_t)(i * 73); + } + reference(payload, sizeof payload, encoded, hex); + for (size_t pos = 0; pos < sizeof encoded; ++pos) { + for (unsigned byte = 0; byte < 256; ++byte) { + unsigned upper = byte & ~32U; + int valid = (upper >= 'A' && upper <= (hex ? 'V' : 'Z')) || + (byte >= (hex ? '0' : '2') && byte <= (hex ? '9' : '7')); + if (valid) { + continue; + } + memcpy(changed, encoded, sizeof changed); + changed[pos] = (uint8_t)byte; + memset(decoded, 0xa5, sizeof decoded); + size_t used = hs_base32_simd_decode(changed, sizeof changed, decoded, hex); + assert(used <= pos && used % 8 == 0); + assert(memcmp(decoded, payload, used / 8 * 5) == 0); + for (size_t i = used / 8 * 5; i < sizeof decoded; ++i) { + assert(decoded[i] == 0xa5); + } + } + } + for (size_t i = 0; i < sizeof encoded; ++i) { + if (encoded[i] >= 'A' && encoded[i] <= 'Z') { + encoded[i] |= 32; + } + } + size_t used = hs_base32_simd_decode(encoded, sizeof encoded, decoded, hex); + assert(used == (hs_base32_simd_backend() ? sizeof encoded : 0)); + assert(memcmp(decoded, payload, used / 8 * 5) == 0); + used = hs_base32_simd_decode_typed(encoded, sizeof encoded, decoded, hex); + assert(used == (hs_base32_simd_backend() ? sizeof encoded : 0)); + assert(memcmp(decoded, payload, used / 8 * 5) == 0); + + /* White-box check: the typed entry point must bypass validation. */ + memset(encoded, '!', sizeof encoded); + used = hs_base32_simd_decode_typed(encoded, sizeof encoded, decoded, hex); + assert(used == (hs_base32_simd_backend() ? sizeof encoded : 0)); +} + +static void guarded(int hex) +{ +#if defined(__unix__) || defined(__APPLE__) + size_t page = (size_t)sysconf(_SC_PAGESIZE); + uint8_t *src = mmap(NULL, page * 2, PROT_READ | PROT_WRITE, + MAP_PRIVATE | MAP_ANON, -1, 0); + uint8_t *dst = mmap(NULL, page * 2, PROT_READ | PROT_WRITE, + MAP_PRIVATE | MAP_ANON, -1, 0); + assert(src != MAP_FAILED && dst != MAP_FAILED); + assert(mprotect(src + page, page, PROT_NONE) == 0); + assert(mprotect(dst + page, page, PROT_NONE) == 0); + for (size_t len = 0; len <= 160; ++len) { + size_t capacity = len / 5 * 8; + memset(src + page - len, 42, len); + hs_base32_simd_encode(src + page - len, len, dst + page - capacity, hex); + capacity = len / 8 * 5; + memset(src + page - len, hex ? '0' : 'A', len); + hs_base32_simd_decode(src + page - len, len, dst + page - capacity, hex); + hs_base32_simd_decode_typed(src + page - len, len, dst + page - capacity, hex); + } + assert(munmap(src, page * 2) == 0); + assert(munmap(dst, page * 2) == 0); +#else + (void)hex; +#endif +} + +int main(int argc, char **argv) +{ + if (argc == 2) { + assert(hs_base32_simd_backend() == atoi(argv[1])); + } else { + assert(argc == 1); + } + for (int hex = 0; hex < 2; ++hex) { + boundaries(hex); + malformed(hex); + guarded(hex); + } + printf("Native Base32 tests passed (backend %d)\n", hs_base32_simd_backend()); + return 0; +} diff --git a/test/typecheck.sh b/test/typecheck.sh new file mode 100644 --- /dev/null +++ b/test/typecheck.sh @@ -0,0 +1,97 @@ +#!/bin/sh +# Run inside the package environment: cabal exec -- sh test/typecheck.sh +set -eu + +compiler=${GHC:-ghc} +work=$(mktemp -d) +trap 'rm -rf "$work"' EXIT HUP INT TERM + +compile() { + "$compiler" -v0 -fno-code -fforce-recomp -package base32 \ + -odir "$work" -hidir "$work" "$work/Api.hs" > "$work/result" 2>&1 +} + +reject() { + cat "$work/header" > "$work/Api.hs" + printf '%s\n' "$1" >> "$work/Api.hs" + if compile; then + printf 'Unexpectedly accepted in %s: %s\n' "$api" "$1" >&2 + exit 1 + fi + if ! grep -F "$2" "$work/result" > /dev/null; then + cat "$work/result" >&2 + exit 1 + fi +} + +while read -r api representation value suffix; do + [ "$suffix" != - ] || suffix= + padded="encodeBase32$suffix" + unpadded="encodeBase32Unpadded$suffix" + cat > "$work/header" < "$work/Api.hs" + cat >> "$work/Api.hs" < Base32 k Value -> Value +standard = S.decodeBase32 +hexadecimal :: HexAlphabet k => Base32 k Value -> Value +hexadecimal = H.decodeBase32 +roundtrips :: Value -> [Value] +roundtrips value = + [ standard (S.$padded value), standard (S.$unpadded value) + , S.decodeBase32Padded (S.$padded value) + , S.decodeBase32Unpadded (S.$unpadded value) + , hexadecimal (H.$padded value), hexadecimal (H.$unpadded value) + , H.decodeBase32Padded (H.$padded value) + , H.decodeBase32Unpadded (H.$unpadded value) + ] +stdPadded :: Value -> Either Error.Text (Base32 'StdPadded Value) +stdPadded = S.parseBase32Padded +stdUnpadded :: Value -> Either Error.Text (Base32 'StdUnpadded Value) +stdUnpadded = S.parseBase32Unpadded +hexPadded :: Value -> Either Error.Text (Base32 'HexPadded Value) +hexPadded = H.parseBase32Padded +hexUnpadded :: Value -> Either Error.Text (Base32 'HexUnpadded Value) +hexUnpadded = H.parseBase32Unpadded +EOF + if ! compile; then + cat "$work/result" >&2 + exit 1 + fi + for encoder in "$padded" "$unpadded"; do + reject "bad = S.decodeBase32 . H.$encoder" 'standard alphabet' + reject "bad = H.decodeBase32 . S.$encoder" 'extended-hex alphabet' + done + for alphabet in S H; do + reject "bad = $alphabet.decodeBase32Padded . $alphabet.$unpadded" \ + "Couldn't match type" + reject "bad = $alphabet.decodeBase32Unpadded . $alphabet.$padded" \ + "Couldn't match type" + reject "bad = fmap $alphabet.decodeBase32Padded . $alphabet.parseBase32Unpadded" \ + "Couldn't match type" + reject "bad = fmap $alphabet.decodeBase32Unpadded . $alphabet.parseBase32Padded" \ + "Couldn't match type" + done + reject "bad :: Base32 'StdPadded Value -> Base32 'StdUnpadded Value +bad = coerce" "Couldn't match type" + reject "bad :: Base32 'StdPadded Value -> Base32 'HexPadded Value +bad = coerce" "Couldn't match type" + printf 'Type checks passed: %s\n' "$api" +done <<'EOF' +Data.ByteString.Base32 Data.ByteString ByteString ' +Data.ByteString.Lazy.Base32 Data.ByteString.Lazy ByteString ' +Data.ByteString.Short.Base32 Data.ByteString.Short ShortByteString ' +Data.Text.Encoding.Base32 Data.Text Text - +Data.Text.Lazy.Encoding.Base32 Data.Text.Lazy Text - +Data.Text.Short.Encoding.Base32 Data.Text.Short ShortText - +EOF