diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,17 @@ # Revision history for base64 +## 2.1 + +This release completes the typed parser API for URL-safe Base64. It removes +`isBase64Url` and `isValidBase64Url`; see [MIGRATION-2.1.md](MIGRATION-2.1.md) +for replacement examples. + +* Adds `parseBase64Padded` and `parseBase64Unpadded` to all six URL-safe + modules: strict, lazy, and short ByteString and Text. URL Parsers validate the URL alphabet, length, padding policy, and canonical padding bits before returning the original encoded value. Lazy parsers validate + the whole input and preserve its chunk boundaries; Text parsers do not + require the decoded payload to be valid UTF-8. +* Removed both URL `Bool` validators in line with the `2.0` work. No one was using them. + ## 2.0 This release removes two public functions. See [MIGRATION-2.0.md](MIGRATION-2.0.md) diff --git a/MIGRATION-2.0.md b/MIGRATION-2.0.md --- a/MIGRATION-2.0.md +++ b/MIGRATION-2.0.md @@ -1,5 +1,7 @@ # Migrating to base64 2.0 +For the URL-safe parser migration in 2.1, also see [MIGRATION-2.1.md](MIGRATION-2.1.md). + Version 2.0 replaces the standard-alphabet predicates `isBase64` and `isValidBase64` with `parseBase64`. The new function checks the encoded input and returns a typed `Base64` value, or an error explaining why validation diff --git a/MIGRATION-2.1.md b/MIGRATION-2.1.md new file mode 100644 --- /dev/null +++ b/MIGRATION-2.1.md @@ -0,0 +1,109 @@ +# Migrating to base64 2.1 + +Version 2.1 replaces `isBase64Url` and `isValidBase64Url` with +`parseBase64Padded` and `parseBase64Unpadded`. The parsers validate the encoded +input and return a typed `Base64` value, or an error explaining why validation +failed. The old URL predicates are removed without a deprecation period. + +The standard-alphabet `parseBase64` functions introduced in 2.0 are unchanged. +If upgrading from 1.x, also follow [MIGRATION-2.0.md](MIGRATION-2.0.md). +Encoding, decoding, compiler support, and the optional SIMD flag are unchanged. + +## Affected modules + +Both parsers are available for all six string representations: + +- `Data.ByteString.Base64.URL` +- `Data.ByteString.Lazy.Base64.URL` +- `Data.ByteString.Short.Base64.URL` +- `Data.Text.Encoding.Base64.URL` +- `Data.Text.Lazy.Encoding.Base64.URL` +- `Data.Text.Short.Encoding.Base64.URL` + +## Parse URL-safe input + +Each module specializes these signatures to its string type: + +```haskell +parseBase64Padded :: a -> Either Text (Base64 'UrlPadded a) +parseBase64Unpadded :: a -> Either Text (Base64 'UrlUnpadded a) +``` + +The padded parser requires complete padding when needed. The unpadded parser +rejects padding. Empty input and complete four-character quanta without +padding are valid in both modes. + +```haskell +{-# LANGUAGE OverloadedStrings #-} + +import qualified Data.ByteString.Base64.URL as B64U + +-- Right "PDw_Pj4=", with alphabet UrlPadded. +padded = B64U.parseBase64Padded "PDw_Pj4=" + +-- Right "PDw_Pj4", with alphabet UrlUnpadded. +unpadded = B64U.parseBase64Unpadded "PDw_Pj4" + +-- Both return Right "<>". +decodedPadded = fmap B64U.decodeBase64Padded padded +decodedUnpadded = fmap B64U.decodeBase64Unpadded unpadded +``` + +Both parsers check the URL-safe alphabet, length, padding, and unused padding +bits. They validate the entire input before returning `Right` and preserve +the original encoded value, including lazy chunk boundaries. Errors match +the corresponding strict ByteString untyped decoder. + +The Text parsers validate Base64 independently of the decoded payload's +UTF-8 validity. For example, `parseBase64Padded "_w=="` and +`parseBase64Unpadded "_w"` succeed even though the decoded byte is not valid +UTF-8. Use a ByteString decoder for binary payloads, or an untyped `With` +decoder with a checked conversion such as `decodeUtf8'`. + +## Replace Boolean checks + +Import `isRight` from `Data.Either`. When a specific padding policy is +required, use `isRight . B64U.parseBase64Padded` or +`isRight . B64U.parseBase64Unpadded`. + +To accept either padding policy, replace `isBase64Url input` with: + +```haskell +isRight (B64U.parseBase64Padded input) + || isRight (B64U.parseBase64Unpadded input) +``` + +The parsers are stricter than the old shape-only `isValidBase64Url` check: + +| Input | Padded parser | Unpadded parser | +| --- | --- | --- | +| `""` | Accept | Accept | +| `"Zm9v"` | Accept | Accept | +| `"Zg=="` | Accept | Reject padding | +| `"Zg"` | Require padding | Accept | +| `"Zg="` | Require complete padding | Reject padding | +| `"ZE=="` | Reject noncanonical bits | Reject padding | +| `"ZE"` | Require padding | Reject noncanonical bits | +| `"PDw/"` | Reject standard-alphabet character | Reject standard-alphabet character | + +If your application intentionally accepts incomplete or noncanonical input, +keep that policy explicit; the parsers do not reproduce the permissive +behavior of `isValidBase64Url`. + +To decode validated input when either padding policy is accepted, +`decodeBase64` consumes both URL alphabet types: + +```haskell +decodeEitherPadding input = + case B64U.parseBase64Padded input of + Right encoded -> Right (B64U.decodeBase64 encoded) + Left _ -> fmap B64U.decodeBase64 (B64U.parseBase64Unpadded input) +``` + +If only decoded bytes are needed, `B64U.decodeBase64Untyped` continues to +accept either padding policy directly. + +## Update package bounds + +After migrating callers, admit 2.1 with `base64 >= 2.1 && < 2.2` or +`base64 ^>= 2.1`. GHC 9.6 through 9.14 remains the supported compiler range. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -22,15 +22,16 @@ - Better performance than `base64-bytestring` for encode and decode. - Optics for handling more complex structures with Base64 representations via the `base64-lens` package -- Parses standard Base64 into a validated `Base64` value, and checks Base64url encodings +- Parses standard and URL-safe Base64 into validated `Base64` values - Rejects non-canonical encodings that do not roundtrip in other base64 libraries like `ZE==`. The library supports GHC 9.6 through 9.14. Its dependencies are `base`, `bytestring`, `deepseq`, `text`, and `text-short`. -Upgrading to 2.0? See the [migration guide](MIGRATION-2.0.md) for the replacement -of `isBase64` and `isValidBase64`, and the [release notes](CHANGELOG.md#20) for -the optional SIMD implementation. +Upgrading to 2.1? See the [migration guide](MIGRATION-2.1.md) and +[release notes](CHANGELOG.md#21) for the replacement of the URL-safe Boolean +validators. If upgrading from 1.x, also follow the [2.0 migration guide](MIGRATION-2.0.md) +for the standard-alphabet parsers and optional SIMD support. ### Parsing existing Base64 @@ -56,8 +57,51 @@ `parseBase64` replaces `isBase64` and `isValidBase64`. For a Boolean check, use `isRight . parseBase64` from `Data.Either`. Unlike the old `isValidBase64`, this -rejects missing padding and non-canonical encodings. The URL-specific validators -`isBase64Url` and `isValidBase64Url` retain their existing behavior. +rejects missing padding and non-canonical encodings. + +Each URL-safe module likewise replaces `isBase64Url` and `isValidBase64Url` +with two parsers: + +```haskell +parseBase64Padded :: a -> Either Text (Base64 'UrlPadded a) +parseBase64Unpadded :: a -> Either Text (Base64 'UrlUnpadded a) +``` + +Choose the parser for the required padding policy. Both preserve the input +and check canonicity; the padded parser requires complete padding when needed, +and the unpadded parser rejects any padding. + +```haskell +>>> import qualified Data.ByteString.Base64.URL as B64U +>>> B64U.parseBase64Padded "PDw_Pj4=" +Right "PDw_Pj4=" +>>> B64U.parseBase64Unpadded "PDw_Pj4" +Right "PDw_Pj4" +>>> fmap B64U.decodeBase64Unpadded (B64U.parseBase64Unpadded "PDw_Pj4") +Right "<>" +``` + +For a Boolean check that accepts either padding policy, use +`isRight (B64U.parseBase64Padded input) || isRight (B64U.parseBase64Unpadded input)`. +See the [migration guide](MIGRATION-2.1.md#parse-url-safe-input) for typed use. + +The complete parser API covers all six string representations: + +| Representation | Standard module | URL-safe module | +| --- | --- | --- | +| Strict `ByteString` | `Data.ByteString.Base64` | `Data.ByteString.Base64.URL` | +| Lazy `ByteString` | `Data.ByteString.Lazy.Base64` | `Data.ByteString.Lazy.Base64.URL` | +| `ShortByteString` | `Data.ByteString.Short.Base64` | `Data.ByteString.Short.Base64.URL` | +| Strict `Text` | `Data.Text.Encoding.Base64` | `Data.Text.Encoding.Base64.URL` | +| Lazy `Text` | `Data.Text.Lazy.Encoding.Base64` | `Data.Text.Lazy.Encoding.Base64.URL` | +| `ShortText` | `Data.Text.Short.Encoding.Base64` | `Data.Text.Short.Encoding.Base64.URL` | + +Every standard module exports `parseBase64` for `StdPadded`. Every URL-safe +module exports both `parseBase64Padded` for `UrlPadded` and +`parseBase64Unpadded` for `UrlUnpadded`. All 18 combinations validate the whole +input and preserve its encoded representation, including lazy chunk boundaries. +`NonStandard` is a marker for input handled by lenient decoders; it does not +define an alphabet or canonical validation rules. ### Optional SIMD diff --git a/base64.cabal b/base64.cabal --- a/base64.cabal +++ b/base64.cabal @@ -1,6 +1,6 @@ cabal-version: 2.0 name: base64 -version: 2.0 +version: 2.1 synopsis: A modern Base64 library description: A performant, featureful RFC 4648 and 7049-compliant Base64 implementation @@ -19,6 +19,7 @@ README.md MIGRATION-1.0.md MIGRATION-2.0.md + MIGRATION-2.1.md tested-with: GHC ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.4 || ==9.14.1 diff --git a/src/Data/Base64/Types.hs b/src/Data/Base64/Types.hs --- a/src/Data/Base64/Types.hs +++ b/src/Data/Base64/Types.hs @@ -38,8 +38,9 @@ -- | Assert the provenance of a value encoded in a particular -- base64 alphabet. -- --- For untrusted standard Base64 input, use the @parseBase64@ function --- in the corresponding ByteString or Text module to validate it first. +-- For untrusted input, use @parseBase64@ for standard Base64, or +-- @parseBase64Padded@ / @parseBase64Unpadded@ for Base64url, in the +-- corresponding ByteString or Text module to validate it first. -- -- /Warning/: This is a blind assertion that a particular -- value is base64 encoded in some alphabet. If you are not diff --git a/src/Data/Base64/Types/Internal.hs b/src/Data/Base64/Types/Internal.hs --- a/src/Data/Base64/Types/Internal.hs +++ b/src/Data/Base64/Types/Internal.hs @@ -32,17 +32,17 @@ data Alphabet = StdPadded -- ^ Standard base64 according to [RFC 4648 §4](https://datatracker.ietf.org/doc/html/rfc4648#section-4) - -- Padding is always inserted when encoding, and required when decoding + -- Padding is inserted when needed and required by the standard parser and decoder. | UrlPadded - -- ^ Standard base64 according to [RFC 4648 §4](https://datatracker.ietf.org/doc/html/rfc4648#section-4) - -- Padding is never inserted when encoding, and optional when decoding per - -- [RFC 7049](https://datatracker.ietf.org/doc/html/rfc7049#section-2.4.4.2). + -- ^ URL-safe base64 according to [RFC 4648 §5](https://datatracker.ietf.org/doc/html/rfc4648#section-5) aka base64url. + -- Padding is inserted when needed and required by the padded parser and decoder. | UrlUnpadded -- ^ URL-safe base64 according to [RFC 4648 §5](https://datatracker.ietf.org/doc/html/rfc4648#section-5) aka base64url - -- Padding is never inserted when encoding, and optional when decoding + -- Padding is never inserted and is rejected by the unpadded parser and decoder. | NonStandard -- ^ Any non-standard, non RFC 4648-compliant base64 encoding. -- Can only be decoded using lenient decoders. + -- This marker does not define an alphabet or canonical validation rules. -- | Wraps a value, asserting that it is or is intended to be -- in a particular kind of Base64 encoding use 'extractBase64' diff --git a/src/Data/ByteString/Base64/Internal.hs b/src/Data/ByteString/Base64/Internal.hs --- a/src/Data/ByteString/Base64/Internal.hs +++ b/src/Data/ByteString/Base64/Internal.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} -- | -- Module : Data.ByteString.Base64.Internal @@ -13,8 +12,7 @@ -- processes and tables. -- module Data.ByteString.Base64.Internal -( validateBase64Url -, validateLastPad +( validateLastPad ) where @@ -22,39 +20,7 @@ import Data.ByteString.Internal import Data.Text (Text) -import Foreign.ForeignPtr -import Foreign.Ptr -import Foreign.Storable - import System.IO.Unsafe - -validateBase64Url :: ByteString -> ByteString -> Bool -validateBase64Url !alphabet bs@(PS _ _ l) - | l == 0 = True - | r == 0 = f bs - | r == 2 = f (BS.append bs "==") - | r == 3 = f (BS.append bs "=") - | otherwise = False - - where - r = l `rem` 4 - - f (PS fp o n) = accursedUnutterablePerformIO $ - withForeignPtr fp $ \p -> go (plusPtr p o) (plusPtr p (n + o)) - - 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 = False - | otherwise = BS.elem a alphabet - - if check w then go (plusPtr p 1) end else return False -{-# INLINE validateBase64Url #-} -- | This function checks that the last char of a bytestring is '=' -- and, if true, fails with a message or completes some io action. diff --git a/src/Data/ByteString/Base64/URL.hs b/src/Data/ByteString/Base64/URL.hs --- a/src/Data/ByteString/Base64/URL.hs +++ b/src/Data/ByteString/Base64/URL.hs @@ -30,9 +30,9 @@ , decodeBase64Padded , decodeBase64PaddedUntyped , decodeBase64Lenient - -- * Validation -, isBase64Url -, isValidBase64Url + -- * Parsing +, parseBase64Padded +, parseBase64Unpadded ) where @@ -44,7 +44,6 @@ import Data.ByteString.Base64.Internal import Data.ByteString.Base64.Internal.Head import Data.ByteString.Base64.Internal.Tables -import Data.Either (isRight) import Data.Text (Text) import qualified Data.Text.Encoding as T @@ -278,46 +277,58 @@ decodeBase64Lenient = decodeBase64Lenient_ decodeB64UrlTable {-# INLINE decodeBase64Lenient #-} --- | Tell whether a 'ByteString' is encoded in padded /or/ unpadded Base64url format. +-- | Parse a canonical, padded Base64url-encoded 'ByteString' value. -- --- This function will also detect non-canonical encodings such as @ZE==@, which are --- externally valid Base64url-encoded values, but are internally inconsistent "impossible" --- values. +-- Checks the URL-safe alphabet, length, padding, and unused padding bits. +-- Returns the original encoded value wrapped in 'Base64', ready for +-- 'decodeBase64Padded' or 'decodeBase64'. Errors match the strict ByteString +-- 'Data.ByteString.Base64.URL.decodeBase64PaddedUntyped' decoder. +-- The input is neither decoded nor normalized in the returned value. -- -- === __Examples__: -- --- >>> isBase64Url "PDw_Pj4=" --- True +-- >>> parseBase64Padded "PDw_Pj4=" +-- Right "PDw_Pj4=" -- --- >>> isBase64Url "PDw_Pj4" --- True +-- >>> fmap decodeBase64Padded (parseBase64Padded "PDw_Pj4=") +-- Right "<>" -- --- >>> isBase64Url "PDw_Pj" --- False +-- >>> parseBase64Padded "PDw_Pj4" +-- Left "Base64-encoded bytestring requires padding" -- -isBase64Url :: ByteString -> Bool -isBase64Url bs - = isValidBase64Url bs - && isRight (decodeBase64Untyped bs) -{-# INLINE isBase64Url #-} +-- >>> parseBase64Padded "ZE==" +-- Left "non-canonical encoding detected at offset: 1" +-- +-- @since 2.1 +-- +parseBase64Padded :: ByteString -> Either Text (Base64 'UrlPadded ByteString) +parseBase64Padded bs = assertBase64 bs <$ decodeBase64PaddedUntyped bs +{-# INLINE parseBase64Padded #-} --- | Tell whether a 'ByteString' is a valid Base64url format. +-- | Parse a canonical, unpadded Base64url-encoded 'ByteString' value. -- --- This will not tell you whether or not this is a correct Base64url representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base64 encoded 'ByteString' value, use 'isBase64Url'. +-- Checks the URL-safe alphabet, length, padding, and unused padding bits. +-- Returns the original encoded value wrapped in 'Base64', ready for +-- 'decodeBase64Unpadded' or 'decodeBase64'. Errors match the strict ByteString +-- 'Data.ByteString.Base64.URL.decodeBase64UnpaddedUntyped' decoder. +-- The input is neither decoded nor normalized in the returned value. -- -- === __Examples__: -- --- >>> isValidBase64Url "PDw_Pj4=" --- True +-- >>> parseBase64Unpadded "PDw_Pj4" +-- Right "PDw_Pj4" -- --- >>> isValidBase64Url "PDw_Pj" --- True +-- >>> fmap decodeBase64Unpadded (parseBase64Unpadded "PDw_Pj4") +-- Right "<>" -- --- >>> isValidBase64Url "%" --- False +-- >>> parseBase64Unpadded "PDw_Pj4=" +-- Left "Base64-encoded bytestring has invalid padding" -- -isValidBase64Url :: ByteString -> Bool -isValidBase64Url = validateBase64Url "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_" -{-# INLINE isValidBase64Url #-} +-- >>> parseBase64Unpadded "ZE" +-- Left "non-canonical encoding detected at offset: 1" +-- +-- @since 2.1 +-- +parseBase64Unpadded :: ByteString -> Either Text (Base64 'UrlUnpadded ByteString) +parseBase64Unpadded bs = assertBase64 bs <$ decodeBase64UnpaddedUntyped bs +{-# INLINE parseBase64Unpadded #-} diff --git a/src/Data/ByteString/Lazy/Base64/URL.hs b/src/Data/ByteString/Lazy/Base64/URL.hs --- a/src/Data/ByteString/Lazy/Base64/URL.hs +++ b/src/Data/ByteString/Lazy/Base64/URL.hs @@ -29,9 +29,9 @@ , decodeBase64Padded , decodeBase64PaddedUntyped , decodeBase64Lenient - -- * Validation -, isBase64Url -, isValidBase64Url + -- * Parsing +, parseBase64Padded +, parseBase64Unpadded ) where @@ -42,7 +42,6 @@ import Data.ByteString.Lazy (fromChunks, toChunks) import qualified Data.ByteString.Lazy as BL import Data.ByteString.Lazy.Internal (ByteString(..)) -import Data.Either (isRight) import qualified Data.Text as T import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Encoding as TL @@ -275,48 +274,64 @@ . toChunks {-# INLINE decodeBase64Lenient #-} --- | Tell whether an untyped 'ByteString' is Base64url-encoded. +-- | Parse a canonical, padded Base64url-encoded 'ByteString' value. -- +-- Checks the URL-safe alphabet, length, padding, and unused padding bits. +-- Returns the original encoded value wrapped in 'Base64', ready for +-- 'decodeBase64Padded' or 'decodeBase64'. Errors match the strict ByteString +-- 'Data.ByteString.Base64.URL.decodeBase64PaddedUntyped' decoder. +-- The input is neither decoded nor normalized in the returned value. +-- +-- The entire input is validated before returning 'Right'; the original +-- chunk boundaries are preserved in the result. +-- -- === __Examples__: -- --- >>> isBase64Url "PDw_Pj4=" --- True +-- >>> parseBase64Padded "PDw_Pj4=" +-- Right "PDw_Pj4=" -- --- >>> isBase64Url "PDw_Pj4" --- True +-- >>> fmap decodeBase64Padded (parseBase64Padded "PDw_Pj4=") +-- Right "<>" -- --- >>> isBase64Url "PDw_Pj" --- False +-- >>> parseBase64Padded "PDw_Pj4" +-- Left "Base64-encoded bytestring requires padding" -- -isBase64Url :: ByteString -> Bool -isBase64Url bs - = isValidBase64Url bs - && isRight (decodeBase64Untyped bs) -{-# INLINE isBase64Url #-} +-- >>> parseBase64Padded "ZE==" +-- Left "non-canonical encoding detected at offset: 1" +-- +-- @since 2.1 +-- +parseBase64Padded :: ByteString -> Either T.Text (Base64 'UrlPadded ByteString) +parseBase64Padded bs = assertBase64 bs <$ B64U.parseBase64Padded (BS.concat $ toChunks bs) +{-# INLINE parseBase64Padded #-} --- | Tell whether an untyped 'ByteString' is a valid Base64url format. +-- | Parse a canonical, unpadded Base64url-encoded 'ByteString' value. -- --- This will not tell you whether or not this is a correct Base64url representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base64 encoded 'ByteString' value, use 'isBase64Url'. +-- Checks the URL-safe alphabet, length, padding, and unused padding bits. +-- Returns the original encoded value wrapped in 'Base64', ready for +-- 'decodeBase64Unpadded' or 'decodeBase64'. Errors match the strict ByteString +-- 'Data.ByteString.Base64.URL.decodeBase64UnpaddedUntyped' decoder. +-- The input is neither decoded nor normalized in the returned value. -- +-- The entire input is validated before returning 'Right'; the original +-- chunk boundaries are preserved in the result. +-- -- === __Examples__: -- --- >>> isValidBase64Url "PDw_Pj4=" --- True +-- >>> parseBase64Unpadded "PDw_Pj4" +-- Right "PDw_Pj4" -- --- >>> isValidBase64Url "PDw_Pj" --- True +-- >>> fmap decodeBase64Unpadded (parseBase64Unpadded "PDw_Pj4") +-- Right "<>" -- --- >>> isValidBase64Url "%" --- False +-- >>> parseBase64Unpadded "PDw_Pj4=" +-- Left "Base64-encoded bytestring has invalid padding" -- -isValidBase64Url :: ByteString -> Bool -isValidBase64Url = go . toChunks - where - go [] = True - go [c] = B64U.isValidBase64Url c - go (c:cs) = -- note the lack of padding char - BS.all (`BL.elem` "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_") c - && go cs -{-# INLINE isValidBase64Url #-} +-- >>> parseBase64Unpadded "ZE" +-- Left "non-canonical encoding detected at offset: 1" +-- +-- @since 2.1 +-- +parseBase64Unpadded :: ByteString -> Either T.Text (Base64 'UrlUnpadded ByteString) +parseBase64Unpadded bs = assertBase64 bs <$ B64U.parseBase64Unpadded (BS.concat $ toChunks bs) +{-# INLINE parseBase64Unpadded #-} diff --git a/src/Data/ByteString/Short/Base64/URL.hs b/src/Data/ByteString/Short/Base64/URL.hs --- a/src/Data/ByteString/Short/Base64/URL.hs +++ b/src/Data/ByteString/Short/Base64/URL.hs @@ -27,9 +27,9 @@ , decodeBase64Padded , decodeBase64PaddedUntyped , decodeBase64Lenient - -- * Validation -, isBase64Url -, isValidBase64Url + -- * Parsing +, parseBase64Padded +, parseBase64Unpadded ) where @@ -243,40 +243,58 @@ decodeBase64Lenient = toShort . B64U.decodeBase64Lenient . fromShort {-# INLINE decodeBase64Lenient #-} --- | Tell whether an untyped 'ShortByteString' is Base64url-encoded. +-- | Parse a canonical, padded Base64url-encoded 'ShortByteString' value. -- +-- Checks the URL-safe alphabet, length, padding, and unused padding bits. +-- Returns the original encoded value wrapped in 'Base64', ready for +-- 'decodeBase64Padded' or 'decodeBase64'. Errors match the strict ByteString +-- 'Data.ByteString.Base64.URL.decodeBase64PaddedUntyped' decoder. +-- The input is neither decoded nor normalized in the returned value. +-- -- === __Examples__: -- --- >>> isBase64Url "PDw_Pj4=" --- True +-- >>> parseBase64Padded "PDw_Pj4=" +-- Right "PDw_Pj4=" -- --- >>> isBase64Url "PDw_Pj4" --- True +-- >>> fmap decodeBase64Padded (parseBase64Padded "PDw_Pj4=") +-- Right "<>" -- --- >>> isBase64Url "PDw_Pj" --- False +-- >>> parseBase64Padded "PDw_Pj4" +-- Left "Base64-encoded bytestring requires padding" -- -isBase64Url :: ShortByteString -> Bool -isBase64Url = B64U.isBase64Url . fromShort -{-# INLINE isBase64Url #-} +-- >>> parseBase64Padded "ZE==" +-- Left "non-canonical encoding detected at offset: 1" +-- +-- @since 2.1 +-- +parseBase64Padded :: ShortByteString -> Either Text (Base64 'UrlPadded ShortByteString) +parseBase64Padded bs = assertBase64 bs <$ B64U.parseBase64Padded (fromShort bs) +{-# INLINE parseBase64Padded #-} --- | Tell whether an untyped 'ShortByteString' is a valid Base64url format. +-- | Parse a canonical, unpadded Base64url-encoded 'ShortByteString' value. -- --- This will not tell you whether or not this is a correct Base64url representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base64 encoded 'ShortByteString' value, use 'isBase64Url'. +-- Checks the URL-safe alphabet, length, padding, and unused padding bits. +-- Returns the original encoded value wrapped in 'Base64', ready for +-- 'decodeBase64Unpadded' or 'decodeBase64'. Errors match the strict ByteString +-- 'Data.ByteString.Base64.URL.decodeBase64UnpaddedUntyped' decoder. +-- The input is neither decoded nor normalized in the returned value. -- -- === __Examples__: -- --- >>> isValidBase64Url "PDw_Pj4=" --- True +-- >>> parseBase64Unpadded "PDw_Pj4" +-- Right "PDw_Pj4" -- --- >>> isValidBase64Url "PDw_Pj" --- True +-- >>> fmap decodeBase64Unpadded (parseBase64Unpadded "PDw_Pj4") +-- Right "<>" -- --- >>> isValidBase64Url "%" --- False +-- >>> parseBase64Unpadded "PDw_Pj4=" +-- Left "Base64-encoded bytestring has invalid padding" -- -isValidBase64Url :: ShortByteString -> Bool -isValidBase64Url = B64U.isValidBase64Url . fromShort -{-# INLINE isValidBase64Url #-} +-- >>> parseBase64Unpadded "ZE" +-- Left "non-canonical encoding detected at offset: 1" +-- +-- @since 2.1 +-- +parseBase64Unpadded :: ShortByteString -> Either Text (Base64 'UrlUnpadded ShortByteString) +parseBase64Unpadded bs = assertBase64 bs <$ B64U.parseBase64Unpadded (fromShort bs) +{-# INLINE parseBase64Unpadded #-} diff --git a/src/Data/Text/Encoding/Base64/URL.hs b/src/Data/Text/Encoding/Base64/URL.hs --- a/src/Data/Text/Encoding/Base64/URL.hs +++ b/src/Data/Text/Encoding/Base64/URL.hs @@ -28,9 +28,9 @@ , decodeBase64PaddedUntyped , decodeBase64PaddedUntypedWith , decodeBase64Lenient - -- * Validation -, isBase64Url -, isValidBase64Url + -- * Parsing +, parseBase64Padded +, parseBase64Unpadded ) where @@ -295,40 +295,64 @@ . T.encodeUtf8 {-# INLINE decodeBase64Lenient #-} --- | Tell whether an untyped 'Text' value is Base64url-encoded. +-- | Parse a canonical, padded Base64url-encoded 'Text' value. -- +-- Checks the URL-safe alphabet, length, padding, and unused padding bits. +-- Returns the original encoded value wrapped in 'Base64', ready for +-- 'decodeBase64Padded' or 'decodeBase64'. Errors match the strict ByteString +-- 'Data.ByteString.Base64.URL.decodeBase64PaddedUntyped' decoder. +-- The input is neither decoded nor normalized in the returned value. +-- +-- This validates the Base64url encoding, independently of whether the +-- decoded payload is valid UTF-8. +-- -- === __Examples__: -- --- >>> isBase64Url "PDw_Pj4=" --- True +-- >>> parseBase64Padded "PDw_Pj4=" +-- Right "PDw_Pj4=" -- --- >>> isBase64Url "PDw_Pj4" --- True +-- >>> fmap decodeBase64Padded (parseBase64Padded "PDw_Pj4=") +-- Right "<>" -- --- >>> isBase64Url "PDw_Pj" --- False +-- >>> parseBase64Padded "PDw_Pj4" +-- Left "Base64-encoded bytestring requires padding" -- -isBase64Url :: Text -> Bool -isBase64Url = B64U.isBase64Url . T.encodeUtf8 -{-# INLINE isBase64Url #-} +-- >>> parseBase64Padded "ZE==" +-- Left "non-canonical encoding detected at offset: 1" +-- +-- @since 2.1 +-- +parseBase64Padded :: Text -> Either Text (Base64 'UrlPadded Text) +parseBase64Padded bs = assertBase64 bs <$ B64U.parseBase64Padded (T.encodeUtf8 bs) +{-# INLINE parseBase64Padded #-} --- | Tell whether an untyped 'Text' value is a valid Base64url format. +-- | Parse a canonical, unpadded Base64url-encoded 'Text' value. -- --- This will not tell you whether or not this is a correct Base64url representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base64 encoded 'Text' value, use 'isBase64Url'. +-- Checks the URL-safe alphabet, length, padding, and unused padding bits. +-- Returns the original encoded value wrapped in 'Base64', ready for +-- 'decodeBase64Unpadded' or 'decodeBase64'. Errors match the strict ByteString +-- 'Data.ByteString.Base64.URL.decodeBase64UnpaddedUntyped' decoder. +-- The input is neither decoded nor normalized in the returned value. -- +-- This validates the Base64url encoding, independently of whether the +-- decoded payload is valid UTF-8. +-- -- === __Examples__: -- --- >>> isValidBase64Url "PDw_Pj4=" --- True +-- >>> parseBase64Unpadded "PDw_Pj4" +-- Right "PDw_Pj4" -- --- >>> isValidBase64Url "PDw_Pj" --- True +-- >>> fmap decodeBase64Unpadded (parseBase64Unpadded "PDw_Pj4") +-- Right "<>" -- --- >>> isValidBase64Url "%" --- False +-- >>> parseBase64Unpadded "PDw_Pj4=" +-- Left "Base64-encoded bytestring has invalid padding" -- -isValidBase64Url :: Text -> Bool -isValidBase64Url = B64U.isValidBase64Url . T.encodeUtf8 -{-# INLINE isValidBase64Url #-} +-- >>> parseBase64Unpadded "ZE" +-- Left "non-canonical encoding detected at offset: 1" +-- +-- @since 2.1 +-- +parseBase64Unpadded :: Text -> Either Text (Base64 'UrlUnpadded Text) +parseBase64Unpadded bs = assertBase64 bs <$ B64U.parseBase64Unpadded (T.encodeUtf8 bs) +{-# INLINE parseBase64Unpadded #-} diff --git a/src/Data/Text/Lazy/Encoding/Base64/URL.hs b/src/Data/Text/Lazy/Encoding/Base64/URL.hs --- a/src/Data/Text/Lazy/Encoding/Base64/URL.hs +++ b/src/Data/Text/Lazy/Encoding/Base64/URL.hs @@ -28,9 +28,9 @@ , decodeBase64PaddedUntyped , decodeBase64PaddedUntypedWith , decodeBase64Lenient - -- * Validation -, isBase64Url -, isValidBase64Url + -- * Parsing +, parseBase64Padded +, parseBase64Unpadded ) where import Data.Base64.Types @@ -285,40 +285,70 @@ . TL.encodeUtf8 {-# INLINE decodeBase64Lenient #-} --- | Tell whether an untyped 'TL.Text' value is Base64url-encoded +-- | Parse a canonical, padded Base64url-encoded 'TL.Text' value. -- +-- Checks the URL-safe alphabet, length, padding, and unused padding bits. +-- Returns the original encoded value wrapped in 'Base64', ready for +-- 'decodeBase64Padded' or 'decodeBase64'. Errors match the strict ByteString +-- 'Data.ByteString.Base64.URL.decodeBase64PaddedUntyped' decoder. +-- The input is neither decoded nor normalized in the returned value. +-- +-- The entire input is validated before returning 'Right'; the original +-- chunk boundaries are preserved in the result. +-- +-- This validates the Base64url encoding, independently of whether the +-- decoded payload is valid UTF-8. +-- -- === __Examples__: -- --- >>> isBase64Url "PDw_Pj4=" --- True +-- >>> parseBase64Padded "PDw_Pj4=" +-- Right "PDw_Pj4=" -- --- >>> isBase64Url "PDw_Pj4" --- True +-- >>> fmap decodeBase64Padded (parseBase64Padded "PDw_Pj4=") +-- Right "<>" -- --- >>> isBase64Url "PDw_Pj" --- False +-- >>> parseBase64Padded "PDw_Pj4" +-- Left "Base64-encoded bytestring requires padding" -- -isBase64Url :: TL.Text -> Bool -isBase64Url = BL64U.isBase64Url . TL.encodeUtf8 -{-# INLINE isBase64Url #-} +-- >>> parseBase64Padded "ZE==" +-- Left "non-canonical encoding detected at offset: 1" +-- +-- @since 2.1 +-- +parseBase64Padded :: TL.Text -> Either T.Text (Base64 'UrlPadded TL.Text) +parseBase64Padded bs = assertBase64 bs <$ BL64U.parseBase64Padded (TL.encodeUtf8 bs) +{-# INLINE parseBase64Padded #-} --- | Tell whether an untyped 'TL.Text' value is a valid Base64url format. +-- | Parse a canonical, unpadded Base64url-encoded 'TL.Text' value. -- --- This will not tell you whether or not this is a correct Base64url representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base64 encoded 'TL.Text' value, use 'isBase64Url'. +-- Checks the URL-safe alphabet, length, padding, and unused padding bits. +-- Returns the original encoded value wrapped in 'Base64', ready for +-- 'decodeBase64Unpadded' or 'decodeBase64'. Errors match the strict ByteString +-- 'Data.ByteString.Base64.URL.decodeBase64UnpaddedUntyped' decoder. +-- The input is neither decoded nor normalized in the returned value. -- +-- The entire input is validated before returning 'Right'; the original +-- chunk boundaries are preserved in the result. +-- +-- This validates the Base64url encoding, independently of whether the +-- decoded payload is valid UTF-8. +-- -- === __Examples__: -- --- >>> isValidBase64Url "PDw_Pj4=" --- True +-- >>> parseBase64Unpadded "PDw_Pj4" +-- Right "PDw_Pj4" -- --- >>> isValidBase64Url "PDw_Pj" --- True +-- >>> fmap decodeBase64Unpadded (parseBase64Unpadded "PDw_Pj4") +-- Right "<>" -- --- >>> isValidBase64Url "%" --- False +-- >>> parseBase64Unpadded "PDw_Pj4=" +-- Left "Base64-encoded bytestring has invalid padding" -- -isValidBase64Url :: TL.Text -> Bool -isValidBase64Url = BL64U.isValidBase64Url . TL.encodeUtf8 -{-# INLINE isValidBase64Url #-} +-- >>> parseBase64Unpadded "ZE" +-- Left "non-canonical encoding detected at offset: 1" +-- +-- @since 2.1 +-- +parseBase64Unpadded :: TL.Text -> Either T.Text (Base64 'UrlUnpadded TL.Text) +parseBase64Unpadded bs = assertBase64 bs <$ BL64U.parseBase64Unpadded (TL.encodeUtf8 bs) +{-# INLINE parseBase64Unpadded #-} diff --git a/src/Data/Text/Short/Encoding/Base64/URL.hs b/src/Data/Text/Short/Encoding/Base64/URL.hs --- a/src/Data/Text/Short/Encoding/Base64/URL.hs +++ b/src/Data/Text/Short/Encoding/Base64/URL.hs @@ -28,9 +28,9 @@ , decodeBase64PaddedUntyped , decodeBase64PaddedUntypedWith , decodeBase64Lenient - -- * Validation -, isBase64Url -, isValidBase64Url + -- * Parsing +, parseBase64Padded +, parseBase64Unpadded ) where import Data.Base64.Types @@ -287,40 +287,64 @@ decodeBase64Lenient = fromText . B64TU.decodeBase64Lenient . toText {-# INLINE decodeBase64Lenient #-} --- | Tell whether an untyped 'ShortText' value is Base64url-encoded. +-- | Parse a canonical, padded Base64url-encoded 'ShortText' value. -- +-- Checks the URL-safe alphabet, length, padding, and unused padding bits. +-- Returns the original encoded value wrapped in 'Base64', ready for +-- 'decodeBase64Padded' or 'decodeBase64'. Errors match the strict ByteString +-- 'Data.ByteString.Base64.URL.decodeBase64PaddedUntyped' decoder. +-- The input is neither decoded nor normalized in the returned value. +-- +-- This validates the Base64url encoding, independently of whether the +-- decoded payload is valid UTF-8. +-- -- === __Examples__: -- --- >>> isBase64Url "PDw_Pj4=" --- True +-- >>> parseBase64Padded "PDw_Pj4=" +-- Right "PDw_Pj4=" -- --- >>> isBase64Url "PDw_Pj4" --- True +-- >>> fmap decodeBase64Padded (parseBase64Padded "PDw_Pj4=") +-- Right "<>" -- --- >>> isBase64Url "PDw_Pj" --- False +-- >>> parseBase64Padded "PDw_Pj4" +-- Left "Base64-encoded bytestring requires padding" -- -isBase64Url :: ShortText -> Bool -isBase64Url = B64U.isBase64Url . toByteString -{-# INLINE isBase64Url #-} +-- >>> parseBase64Padded "ZE==" +-- Left "non-canonical encoding detected at offset: 1" +-- +-- @since 2.1 +-- +parseBase64Padded :: ShortText -> Either Text (Base64 'UrlPadded ShortText) +parseBase64Padded bs = assertBase64 bs <$ B64U.parseBase64Padded (toByteString bs) +{-# INLINE parseBase64Padded #-} --- | Tell whether an untyped 'ShortText' value is a valid Base64url format. +-- | Parse a canonical, unpadded Base64url-encoded 'ShortText' value. -- --- This will not tell you whether or not this is a correct Base64url representation, --- only that it conforms to the correct shape. To check whether it is a true --- Base64 encoded 'ShortText' value, use 'isBase64Url'. +-- Checks the URL-safe alphabet, length, padding, and unused padding bits. +-- Returns the original encoded value wrapped in 'Base64', ready for +-- 'decodeBase64Unpadded' or 'decodeBase64'. Errors match the strict ByteString +-- 'Data.ByteString.Base64.URL.decodeBase64UnpaddedUntyped' decoder. +-- The input is neither decoded nor normalized in the returned value. -- +-- This validates the Base64url encoding, independently of whether the +-- decoded payload is valid UTF-8. +-- -- === __Examples__: -- --- >>> isValidBase64Url "PDw_Pj4=" --- True +-- >>> parseBase64Unpadded "PDw_Pj4" +-- Right "PDw_Pj4" -- --- >>> isValidBase64Url "PDw_Pj" --- True +-- >>> fmap decodeBase64Unpadded (parseBase64Unpadded "PDw_Pj4") +-- Right "<>" -- --- >>> isValidBase64Url "%" --- False +-- >>> parseBase64Unpadded "PDw_Pj4=" +-- Left "Base64-encoded bytestring has invalid padding" -- -isValidBase64Url :: ShortText -> Bool -isValidBase64Url = B64U.isValidBase64Url . toByteString -{-# INLINE isValidBase64Url #-} +-- >>> parseBase64Unpadded "ZE" +-- Left "non-canonical encoding detected at offset: 1" +-- +-- @since 2.1 +-- +parseBase64Unpadded :: ShortText -> Either Text (Base64 'UrlUnpadded ShortText) +parseBase64Unpadded bs = assertBase64 bs <$ B64U.parseBase64Unpadded (toByteString bs) +{-# INLINE parseBase64Unpadded #-} diff --git a/test/Internal.hs b/test/Internal.hs --- a/test/Internal.hs +++ b/test/Internal.hs @@ -75,8 +75,8 @@ , lenientUrl :: bs -> bs , lenient :: bs -> bs , parse :: bs -> Either Text (Base64 'StdPadded bs) - , correctUrl :: bs -> Bool - , validateUrl :: bs -> Bool + , parseUrlPad :: bs -> Either Text (Base64 'UrlPadded bs) + , parseUrlNopad :: bs -> Either Text (Base64 'UrlUnpadded bs) } @@ -97,8 +97,8 @@ , decodeUrlTypedPad = B64U.decodeBase64Padded , decodeUrlTypedNopad = B64U.decodeBase64Unpadded , lenientUrl = B64U.decodeBase64Lenient - , correctUrl = B64U.isBase64Url - , validateUrl = B64U.isValidBase64Url + , parseUrlPad = B64U.parseBase64Padded + , parseUrlNopad = B64U.parseBase64Unpadded } lb64 :: Harness LBS.ByteString @@ -118,8 +118,8 @@ , decodeUrlTypedPad = LB64U.decodeBase64Padded , decodeUrlTypedNopad = LB64U.decodeBase64Unpadded , lenientUrl = LB64U.decodeBase64Lenient - , correctUrl = LB64U.isBase64Url - , validateUrl = LB64U.isValidBase64Url + , parseUrlPad = LB64U.parseBase64Padded + , parseUrlNopad = LB64U.parseBase64Unpadded } sb64 :: Harness SBS.ShortByteString @@ -139,8 +139,8 @@ , decodeUrlTypedPad = SB64U.decodeBase64Padded , decodeUrlTypedNopad = SB64U.decodeBase64Unpadded , lenientUrl = SB64U.decodeBase64Lenient - , correctUrl = SB64U.isBase64Url - , validateUrl = SB64U.isValidBase64Url + , parseUrlPad = SB64U.parseBase64Padded + , parseUrlNopad = SB64U.parseBase64Unpadded } t64 :: Harness Text @@ -160,8 +160,8 @@ , decodeUrlTypedPad = T64U.decodeBase64Padded , decodeUrlTypedNopad = T64U.decodeBase64Unpadded , lenientUrl = T64U.decodeBase64Lenient - , correctUrl = T64U.isBase64Url - , validateUrl = T64U.isValidBase64Url + , parseUrlPad = T64U.parseBase64Padded + , parseUrlNopad = T64U.parseBase64Unpadded } tl64 :: Harness TL.Text @@ -181,8 +181,8 @@ , decodeUrlTypedPad = TL64U.decodeBase64Padded , decodeUrlTypedNopad = TL64U.decodeBase64Unpadded , lenientUrl = TL64U.decodeBase64Lenient - , correctUrl = TL64U.isBase64Url - , validateUrl = TL64U.isValidBase64Url + , parseUrlPad = TL64U.parseBase64Padded + , parseUrlNopad = TL64U.parseBase64Unpadded } ts64 :: Harness TS.ShortText @@ -202,8 +202,8 @@ , decodeUrlTypedPad = TS64U.decodeBase64Padded , decodeUrlTypedNopad = TS64U.decodeBase64Unpadded , lenientUrl = TS64U.decodeBase64Lenient - , correctUrl = TS64U.isBase64Url - , validateUrl = TS64U.isValidBase64Url + , parseUrlPad = TS64U.parseBase64Padded + , parseUrlNopad = TS64U.parseBase64Unpadded } -- -------------------------------------------------------------------- -- diff --git a/test/Main.hs b/test/Main.hs --- a/test/Main.hs +++ b/test/Main.hs @@ -49,7 +49,7 @@ import Test.Tasty import Test.Tasty.HUnit import Test.Tasty.QuickCheck (testProperty) -import Data.String (IsString) +import Data.String (IsString, fromString) import Test.QuickCheck hiding (label) @@ -93,6 +93,8 @@ (second TS.fromText . T.decodeUtf8' . SBS.fromShort) tts64 sb64 ] , parseRepresentationTests + , urlParseRepresentationTests + , parserCoherenceTests ] -- ---------------------------------------------------------------- -- @@ -132,7 +134,7 @@ mkPropTree = mkTests "Property Tests" [ prop_roundtrip , prop_parse - , prop_correctness + , prop_parse_url , prop_url_padding , const prop_bos_coherence ] @@ -149,7 +151,7 @@ [ paddingTests last_ length_ , rfcVectors , offsetVectors - , validityTests + , urlParseTests , canonicityTests , parseTests ] @@ -191,14 +193,6 @@ bs == lenientUrl (extractBase64 $ encodeUrl bs) ] -prop_correctness :: (Arbitrary a, IsString a, Eq a, Show a) => Harness a -> TestTree -prop_correctness Harness{..} = testGroup "prop_validity" - [ testProperty "prop_url_valid" $ \(bs :: a) -> - validateUrl (extractBase64 $ encodeUrl bs) - , testProperty "prop_url_correct" $ \(bs :: a) -> - correctUrl (extractBase64 $ encodeUrl bs) - ] - prop_parse :: (Arbitrary a, IsString a, Eq a, Show a) => Harness a -> TestTree prop_parse Harness{..} = testGroup "Parsing properties" [ testProperty "parse an encoded value" $ \(bs :: a) -> @@ -293,6 +287,193 @@ @?= Right chunks ] +prop_parse_url :: (Arbitrary a, IsString a, Eq a, Show a) => Harness a -> TestTree +prop_parse_url Harness{..} = testGroup "URL parsing properties" + [ parserProperties "padded" parseUrlPad encodeUrl decodeUrlTypedPad decodeUrlPad + , parserProperties "unpadded" parseUrlNopad encodeUrlNopad decodeUrlTypedNopad decodeUrlNopad + ] + where + parserProperties name parser encoder decoder untyped = testGroup name + [ testProperty "parse an encoded value" $ \bs -> + parser (extractBase64 $ encoder bs) === Right (encoder bs) + , testProperty "decode a parsed value" $ \bs -> + fmap decoder (parser $ extractBase64 $ encoder bs) === Right bs + , testProperty "preserve arbitrary accepted input" $ \bs -> + case parser bs of + Left _ -> property True + Right encoded -> extractBase64 encoded === bs + , testProperty "agree with untyped decoding errors" $ \bs -> + -- Do not force a possible UTF-8 conversion of the decoded payload. + (() <$ parser bs) === (() <$ untyped bs) + , testProperty "validate arbitrary alphabet and padding combinations" $ + forAll (listOf $ elements "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_=+/% \n") $ \s -> + let input = fromString s + in (extractBase64 <$> parser input) === (input <$ untyped input) + ] + +urlParseTests :: (IsString a, Eq a, Show a) => Harness a -> TestTree +urlParseTests Harness{..} = testGroup "URL parsing unit tests" + [ testGroup "Preserve valid padded values" + [ testCase (show input) $ parseUrlPad input @?= Right (assertBase64 input) + | input <- ["", "Zg==", "Zm8=", "Zm9v", "Zm9vYg==", "Zm9vYmE=", "Zm9vYmFy" + , "PDw_Pj4=", "PDw_Pz4-", "_w==", "-_8=", "PA==", "PDw=", "PDw_" + , "ZA==", "ZmA=", "Zm9vYmA="] + ] + , testGroup "Preserve valid unpadded values" + [ testCase (show input) $ parseUrlNopad input @?= Right (assertBase64 input) + | input <- ["", "Zg", "Zm8", "Zm9v", "Zm9vYg", "Zm9vYmE", "Zm9vYmFy" + , "PDw_Pj4", "PDw_Pz4-", "_w", "-_8", "PA", "PDw", "PDw_" + , "ZA", "ZmA", "Zm9vYmA"] + ] + , testGroup "Require complete padding for UrlPadded" + [ testCase (show input) $ + parseUrlPad input @?= Left "Base64-encoded bytestring requires padding" + | input <- ["Zg", "Zm8", "Zg=", "PDw_Pj4"] + ] + , testGroup "Reject padding for UrlUnpadded" + [ testCase (show input) $ + parseUrlNopad input @?= Left "Base64-encoded bytestring has invalid padding" + | input <- ["Zg==", "Zm8=", "Zg=", "==", "====", "PDw_Pj4="] + ] + , testGroup "Reject malformed values in both modes" + [ testGroup name + [ testCase (show input) $ parser input @?= Left err + | (input, err) <- + [ ("Z", "Base64-encoded bytestring has invalid size") + , ("Zg===", "Base64-encoded bytestring has invalid size") + , ("AA=A", "invalid base64 encoding near offset: 3") + , ("Zg==AAAA", "invalid padding near offset: 2") + , ("Zm8=AAAA", "invalid padding near offset: 3") + , ("%AAA", "invalid base64 encoding near offset: 0") + , ("A%AA", "invalid base64 encoding near offset: 1") + , ("AA%A", "invalid base64 encoding near offset: 2") + , ("AAA%", "invalid base64 encoding near offset: 3") + , ("AAAA%AAA", "invalid base64 encoding near offset: 4") + , ("PDw/", "invalid base64 encoding near offset: 3") + , ("PDw+", "invalid base64 encoding near offset: 3") + , ("AAA ", "invalid base64 encoding near offset: 3") + , ("AAA\n", "invalid base64 encoding near offset: 3") + ] + ] + | (name, parser) <- [("padded", fmap extractBase64 . parseUrlPad) + , ("unpadded", fmap extractBase64 . parseUrlNopad)] + ] + , testGroup "Reject invalid padded quanta" + [ testCase (show input) $ parseUrlPad input @?= Left err + | (input, err) <- [("====", "invalid padding near offset: 0") + , ("A===", "invalid padding near offset: 1")] + ] + , testGroup "Reject non-canonical values in both modes" + [ testCase (show (padded, unpadded)) $ do + parseUrlPad padded @?= Left err + parseUrlNopad unpadded @?= Left err + | (padded, unpadded, err) <- + [ ("ZE==", "ZE", "non-canonical encoding detected at offset: 1") + , ("ZK==", "ZK", "non-canonical encoding detected at offset: 1") + , ("ZmC=", "ZmC", "non-canonical encoding detected at offset: 2") + , ("ZmD=", "ZmD", "non-canonical encoding detected at offset: 2") + , ("_x==", "_x", "non-canonical encoding detected at offset: 1") + , ("-_9=", "-_9", "non-canonical encoding detected at offset: 2") + , ("Zm9vYE==", "Zm9vYE", "non-canonical encoding detected at offset: 5") + , ("Zm9vYmC=", "Zm9vYmC", "non-canonical encoding detected at offset: 6") + ] + ] + , testCase "reject non-ASCII input in both modes" $ do + assertBool "padded parser accepted non-ASCII input" $ + isLeft (parseUrlPad "\255\255\255\255") + assertBool "unpadded parser accepted non-ASCII input" $ + isLeft (parseUrlNopad "\255\255\255\255") + ] + +urlParseRepresentationTests :: TestTree +urlParseRepresentationTests = testGroup "URL parsing representations" + [ testGroup name + [ testProperty "parse sliced ByteStrings" $ \bs -> + let input = encoder bs + sliced = BS.take (BS.length input) $ BS.drop 2 ("!!" <> input <> "!!") + in parser sliced === Right input + , testCase "error offsets are relative to the ByteString slice" $ + parser (BS.take 4 $ BS.drop 2 "!!AA%A!!") + @?= Left "invalid base64 encoding near offset: 2" + , testGroup "Lazy ByteString chunk boundaries" + [ testCase (show (input, n)) $ + let splitChunks = [BS.take n input, BS.drop n input] + in fmap LBS.toStrict (lazyParser $ LBS.fromChunks splitChunks) @?= parser input + | input <- inputs + , n <- [0 .. BS.length input] + ] + , testGroup "Lazy Text chunk boundaries" + [ testCase (show (input, n)) $ + let txt = T.decodeUtf8 input + splitChunks = [T.take n txt, T.drop n txt] + in fmap TL.toStrict (lazyTextParser $ TL.fromChunks splitChunks) @?= textParser txt + | input <- inputs + , n <- [0 .. BS.length input] + ] + , testCase "preserve lazy ByteString chunks" $ + fmap LBS.toChunks (lazyParser $ LBS.fromChunks chunks) @?= Right chunks + , testCase "preserve lazy Text chunks" $ + let textChunks = fmap T.decodeUtf8 chunks + in fmap TL.toChunks (lazyTextParser $ TL.fromChunks textChunks) @?= Right textChunks + ] + | (name, encoder, parser, lazyParser, textParser, lazyTextParser, chunks) <- + [ ("padded", extractBase64 . B64U.encodeBase64' + , fmap extractBase64 . parseUrlPad b64, fmap extractBase64 . parseUrlPad lb64 + , fmap extractBase64 . parseUrlPad t64, fmap extractBase64 . parseUrlPad tl64 + , ["_", "w=", "="]) + , ("unpadded", extractBase64 . B64U.encodeBase64Unpadded' + , fmap extractBase64 . parseUrlNopad b64, fmap extractBase64 . parseUrlNopad lb64 + , fmap extractBase64 . parseUrlNopad t64, fmap extractBase64 . parseUrlNopad tl64 + , ["P", "Dw_", "Pj4"]) + ] + ] + where + inputs = + [ "", "_w==", "_w", "PDw_Pj4=", "PDw_Pj4", "PDw_Pz4-", "Zg==AAAA" + , "Zm9vYmC=", "Zm9vYmC", "Zg=", "A", "AAAA%AAA", "AA=A", "====" + , BS.replicate 64 65 <> "-_8=", BS.replicate 64 65 <> "-_8" + , BS.replicate 64 65 <> "AA%A", BS.replicate 64 65 <> "-_9=" + ] + +parserCoherenceTests :: TestTree +parserCoherenceTests = testGroup "Parser consistency across all representations" + [ testProperty name $ + forAll (listOf $ resize 8 $ listOf1 $ elements alphabet) $ \chunks -> + let textChunks = fmap T.pack chunks + byteChunks = fmap T.encodeUtf8 textChunks + textInput = T.concat textChunks + byteInput = BS.concat byteChunks + expected = strictBytes byteInput + in conjoin + [ counterexample "lazy ByteString" $ + (LBS.toStrict <$> lazyBytes (LBS.fromChunks byteChunks)) === expected + , counterexample "short ByteString" $ + (SBS.fromShort <$> shortBytes (SBS.toShort byteInput)) === expected + , counterexample "strict Text" $ + (T.encodeUtf8 <$> strictText textInput) === expected + , counterexample "lazy Text" $ + (T.encodeUtf8 . TL.toStrict <$> lazyText (TL.fromChunks textChunks)) === expected + , counterexample "short Text" $ + (TS.toByteString <$> shortText (TS.fromText textInput)) === expected + ] + | (name, strictBytes, lazyBytes, shortBytes, strictText, lazyText, shortText) <- + [ ("standard padded" + , fmap extractBase64 . parse b64, fmap extractBase64 . parse lb64 + , fmap extractBase64 . parse sb64, fmap extractBase64 . parse t64 + , fmap extractBase64 . parse tl64, fmap extractBase64 . parse ts64) + , ("URL padded" + , fmap extractBase64 . parseUrlPad b64, fmap extractBase64 . parseUrlPad lb64 + , fmap extractBase64 . parseUrlPad sb64, fmap extractBase64 . parseUrlPad t64 + , fmap extractBase64 . parseUrlPad tl64, fmap extractBase64 . parseUrlPad ts64) + , ("URL unpadded" + , fmap extractBase64 . parseUrlNopad b64, fmap extractBase64 . parseUrlNopad lb64 + , fmap extractBase64 . parseUrlNopad sb64, fmap extractBase64 . parseUrlNopad t64 + , fmap extractBase64 . parseUrlNopad tl64, fmap extractBase64 . parseUrlNopad ts64) + ] + ] + where + alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=_-% \n\255\955\128512" + prop_url_padding :: (Arbitrary a, IsString a, Eq a, Show a) => Harness a -> TestTree prop_url_padding Harness{..} = testGroup "prop_url_padding" [ testProperty "prop_url_nopad_roundtrip_untyped" $ \(bs :: a) -> @@ -605,60 +786,5 @@ a <- either (assertFailure . show) pure $ decodeUrlNopad t "PDw_Pz4-" b <- either (assertFailure . show) pure $ decodeUrlUnpaddedWith_ utf8 "PDw_Pz4-" a @=? b - ] - ] - --- | Validity unit tests for the URL workflow --- -validityTests :: IsString a => Harness a -> TestTree -validityTests Harness{..} = testGroup "Validity and correctness unit tests" - [ testGroup "Validity unit tests" - [ testCase "Padding tests" $ do - not (validateUrl "P") @? "P" - validateUrl "PA" @? "PA" - validateUrl "PDw" @? "PDw" - validateUrl "PDw_" @? "PDw_" - validateUrl "PA==" @? "PA==" - validateUrl "PDw=" @? "PDw=" - validateUrl "PDw_" @? "PDw_" - - , testCase "Canonicity tests" $ do - validateUrl "ZK==" @? "ZK==" - validateUrl "ZE==" @? "ZE==" - - validateUrl "ZA==" @? "ZA==" - validateUrl "ZK==" @? "ZK==" - validateUrl "ZK" @? "ZK" - - validateUrl "ZmA=" @? "ZmA=" - validateUrl "ZmC=" @? "ZmC=" - validateUrl "ZmE" @? "ZmE" - - validateUrl "Zm9vYmA=" @? "Zm9vYmA=" - validateUrl "Zm9vYmC=" @? "Zm9vYmC=" - validateUrl "Zm9vYmC" @? "Zm9vYmC" - ] - , testGroup "Correctness unit tests" - [ testCase "Padding tests" $ do - not (validateUrl "P") @? "P" - correctUrl "PA" @? "PA" - correctUrl "PDw" @? "PDw" - correctUrl "PDw_" @? "PDw_" - correctUrl "PA==" @? "PA==" - correctUrl "PDw=" @? "PDw=" - correctUrl "PDw_" @? "PDw_" - - , testCase "Canonicity tests" $ do - not (correctUrl "ZK==") @? "ZK==" - not (correctUrl "ZE==") @? "ZE==" - correctUrl "ZA==" @? "ZA==" - - correctUrl "ZmA=" @? "ZmA=" - not (correctUrl "ZmC=") @? "ZmC=" - not (correctUrl "ZmD") @? "ZmD" - - correctUrl "Zm9vYmA=" @? "Zm9vYmA=" - not (correctUrl "Zm9vYmC=") @? "Zm9vYmC=" - not (correctUrl "Zm9vYmC") @? "Zm9vYmC" ] ]