diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,54 @@ # Revision history for base64-lens +## 0.4 — 2026-10-13 + +* Support `base64` 2.0 and GHC 9.6–9.14; update dependency bounds for + `bytestring` 0.11–0.12, `text` 2.0–2.2, and `lens` 5.0–5.3. +* Change string optics from raw-string prisms to typed isomorphisms over + `Base64` wrappers. Encoding records the alphabet; decoding consumes the + corresponding wrapper. Validate untrusted standard input with `parseBase64`. +* Add `_Base64Untyped`, `_Base64UrlUntyped`, and + `_Base64UrlUnpaddedUntyped` alongside the typed optics in all six string + modules. These restore raw-string prisms using the checked untyped decoders. +* Change all string patterns to construct and match typed wrappers. Lenient + optics and patterns use `NonStandard`; fix their patterns to encode on + construction and decode on matching. +* Add `Data.Base64.Types.Lens` with a type-changing payload isomorphism, + `Wrapped`/`Rewrapped` instances, and prisms for all `Alphabet` constructors. + Payload optics preserve the alphabet index and do not validate or encode. +* Generalize `_ConversionError` to allow changing the error payload type. +* Simplify the string optics to direct compositions of the typed codecs. + Use `Trustworthy` because `base64` 2.0's encoding modules are not Safe + Haskell modules; the error optics remain `Safe`. +* Add regression and property tests for all representations, typed patterns, + wrapper optics, alphabet constructors, untyped decoding and rejection, lazy + chunk boundaries, binary data, Unicode, and errors. + Replace the unused doctest stub. +* Refresh CI to test source distributions across supported compilers and both + scalar and SIMD decoding backends. + +### Migration from 0.3 + +For typed decoding, validate external standard-alphabet input with +`parseBase64`, then use `view` or `(^.)` with the corresponding typed optic. +Use `extractBase64` or `Data.Base64.Types.Lens._Base64` when an API needs the +encoded payload without its wrapper. + +To keep using `preview` or `(^?)` with ordinary encoded strings, rename the +prisms: + +| Previous name | Replacement | +| --- | --- | +| `_Base64` | `_Base64Untyped` | +| `_Base64Url` | `_Base64UrlUntyped` | +| `_Base64UrlUnpadded` | `_Base64UrlUnpaddedUntyped` | + +The generic URL prism accepts both padded and unpadded input and reviews to +padded output. The unpadded URL prism rejects padding. Text decoding continues +to require UTF-8 payloads; use the ByteString optics for arbitrary binary data. + ## 0.3.1 + * Add lazy and short text and bytestring optics * Add safe/trustworthy pragmas diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,6 +1,146 @@ # Base64-lens -[![Build Status](https://travis-ci.com/emilypi/base64-lens.svg?branch=master)](https://travis-ci.com/emilypi/base64-lens) +[![Build Status](https://github.com/emilypi/base64-lens/actions/workflows/haskell-ci.yml/badge.svg)](https://github.com/emilypi/base64-lens/actions/workflows/haskell-ci.yml) [![Hackage](https://img.shields.io/hackage/v/base64-lens.svg)](https://hackage.haskell.org/package/base64-lens) -This package provides optics and convenient pattern synonyms for the [base64](https://hackage.haskell.org/package/base64) library. +Optics and bidirectional patterns for +[base64](https://hackage.haskell.org/package/base64), covering strict, lazy, and +short `ByteString` and `Text` values. Version 0.4 supports `base64` 2.0, +`lens` 5.0–5.3, and GHC 9.6–9.14. + +## Encoding and decoding + +The string modules expose typed isomorphisms. Viewing decodes a `Base64` value; +reviewing encodes the payload and returns a wrapper with the matching alphabet. + +```haskell +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +import Control.Lens +import Data.Base64.Types (Alphabet(..), Base64) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Base64.Lens as B64 + +encoded :: Base64 'StdPadded ByteString +encoded = B64._Base64 # "Sun" + +-- "Sun" +decoded = encoded ^. B64._Base64 + +-- Right "Sun": validate external input before using the typed optic. +checked = fmap (view B64._Base64) (Base64.parseBase64 "U3Vu") +``` + +Each string module provides these optics, where `a` is its string type: + +| Optic | Type | +| --- | --- | +| `_Base64` | `Iso' (Base64 'StdPadded a) a` | +| `_Base64Url` | `Iso' (Base64 'UrlPadded a) a` | +| `_Base64UrlUnpadded` | `Iso' (Base64 'UrlUnpadded a) a` | +| `_Base64Lenient` | `Iso' (Base64 'NonStandard a) a` | +| `_Base64UrlLenient` | `Iso' (Base64 'NonStandard a) a` | + +The corresponding patterns construct encoded wrappers and match decoded +payloads. For example, `B64.Base64 "Sun"` has type +`Base64 'StdPadded ByteString`, and matching `B64.Base64 bytes` binds the +decoded bytes. Each pattern is complete for its input type. + +The lenient optics ignore invalid Base64 characters, stop at padding, and +construct canonical padded output tagged as `NonStandard`. They are not lawful +isomorphisms for arbitrary input. + +The `Text` optics expect the decoded payload to be UTF-8, as in the underlying +library. Invalid UTF-8 may throw an exception. Use the `ByteString` optics for +arbitrary binary payloads. + +## Untyped decoding prisms + +For ordinary encoded strings, each string module also provides: + +| Prism | Checked decoder | Review produces | +| --- | --- | --- | +| `_Base64Untyped` | `decodeBase64Untyped` | Standard, padded Base64 | +| `_Base64UrlUntyped` | URL `decodeBase64Untyped` | URL-safe, padded Base64 | +| `_Base64UrlUnpaddedUntyped` | URL `decodeBase64UnpaddedUntyped` | URL-safe, unpadded Base64 | + +Each has type `Prism' a a`, where `a` is the module's string type. Preview +returns the decoded payload on success and `Nothing` on a Base64 decoding +error; review encodes directly to an ordinary string. + +```haskell +-- Just "Sun" +untypedDecoded = "U3Vu" ^? B64._Base64Untyped + +-- Nothing: non-canonical padding bits +untypedRejected = "U3V=" ^? B64._Base64Untyped + +-- "U3Vu" +untypedEncoded = B64._Base64Untyped # "Sun" +``` + +The URL prism accepts both padded and unpadded input, matching its decoder. +Reviewing a successful match adds any required padding, so it is not a lawful +prism over all accepted input. The unpadded URL prism rejects padding. The +`Text` prisms retain the underlying decoders' UTF-8 requirement described above. + +## Wrapper and alphabet optics + +`Data.Base64.Types.Lens` gives the wrapper its own namespace. Its `_Base64` +accesses the **encoded** payload and can change its representation while +preserving the alphabet index: + +```haskell +import qualified Data.Base64.Types.Lens as Wrapped +import qualified Data.ByteString.Lazy as BL + +-- "U3Vu": the encoded payload +payload = encoded ^. Wrapped._Base64 + +lazyEncoded :: Base64 'StdPadded BL.ByteString +lazyEncoded = encoded & Wrapped._Base64 %~ BL.fromStrict +``` + +Importing this module also enables the standard `Wrapped` and `Rewrapped` +instances, so `_Wrapped` and `_Wrapped'` work with `Base64`. Wrapping uses +`assertBase64`: it does not encode or validate. Payload changes must preserve +the claimed encoding if the result will be decoded. These optics keep the +alphabet index fixed; they do not silently change standard Base64 into URL-safe +Base64. + +The same module supplies `_StdPadded`, `_UrlPadded`, `_UrlUnpadded`, and +`_NonStandard`, each a `Prism' Alphabet ()`. + +`Data.Text.Encoding.Base64.Error.Lens` provides `_DecodeError` and a +type-changing `_ConversionError` prism for mapping conversion failures. + +## Migrating from 0.3 + +The existing optic names now operate on `Base64` wrappers. Use `view` or `(^.)` +for typed decoding. Use `parseBase64` to validate external standard-alphabet +input, then decode the returned wrapper. Extract encoded output with +`Wrapped._Base64` or `extractBase64` when an API expects an ordinary string. + +To retain raw-string prism usage, switch `_Base64` to `_Base64Untyped`, +`_Base64Url` to `_Base64UrlUntyped`, and `_Base64UrlUnpadded` to +`_Base64UrlUnpaddedUntyped`. These support `preview` or `(^?)` as before. + +The lenient patterns also change direction: construction encodes and matching +decodes, consistently with the other patterns. + +## Development + +```sh +cabal update +cabal test --test-show-details=direct +cabal haddock +cabal check +``` + +To exercise the optional SIMD backend in `base64`: + +```sh +cabal test --constraint='base64 +simd' --test-show-details=direct +``` diff --git a/base64-lens.cabal b/base64-lens.cabal --- a/base64-lens.cabal +++ b/base64-lens.cabal @@ -1,23 +1,23 @@ cabal-version: 2.0 name: base64-lens -version: 0.3.1 +version: 0.4 synopsis: Optics for the Base64 library -description: Prisms and pattern synonyms for the Base64 library +description: Optics and pattern synonyms for Base64 values homepage: https://github.com/emilypi/base64-lens bug-reports: https://github.com/emilypi/base64-lens/issues license: BSD3 license-file: LICENSE author: Emily Pillmore maintainer: Emily Pillmore -copyright: (c) 2019-2021 Emily Pillmore +copyright: (c) 2019-2026 Emily Pillmore category: Data build-type: Simple -extra-source-files: +extra-doc-files: CHANGELOG.md README.md tested-with: - GHC ==8.2.2 || ==8.4.4 || ==8.6.5 || ==8.8.4 || ==8.10.4 + GHC ==9.6.7 || ==9.8.4 || ==9.10.3 || ==9.12.4 || ==9.14.1 source-repository head type: git @@ -25,6 +25,7 @@ library exposed-modules: + Data.Base64.Types.Lens Data.ByteString.Base64.Lens Data.ByteString.Lazy.Base64.Lens Data.ByteString.Short.Base64.Lens @@ -34,13 +35,31 @@ Data.Text.Short.Encoding.Base64.Lens build-depends: - base >=4.10 && <5 - , base64 ^>=0.4 - , bytestring ^>=0.10 - , lens >=4.0 && <5.1 - , text ^>=1.2 + base >=4.18 && <4.23 + , base64 ^>=2.0 + , bytestring >=0.11 && <0.13 + , lens >=5.0 && <5.4 + , text >=2.0 && <2.3 , text-short ^>=0.1 hs-source-dirs: src default-language: Haskell2010 ghc-options: -Wall + +test-suite tests + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + default-language: Haskell2010 + ghc-options: -Wall + build-depends: + base + , base64 + , base64-lens + , bytestring + , lens + , tasty >=1.4 && <1.6 + , tasty-hunit ^>=0.10 + , tasty-quickcheck >=0.10 && <0.12 + , text + , text-short diff --git a/src/Data/Base64/Types/Lens.hs b/src/Data/Base64/Types/Lens.hs new file mode 100644 --- /dev/null +++ b/src/Data/Base64/Types/Lens.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE Trustworthy #-} +{-# OPTIONS_GHC -Wno-orphans #-} +-- | +-- Module : Data.Base64.Types.Lens +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : non-portable +-- +-- Optics for the 'Base64' wrapper and 'Alphabet' constructors. Importing this +-- module also supplies 'Wrapped' and 'Rewrapped' instances for 'Base64'. +-- The wrapper optic accesses encoded data; the string-specific modules +-- contain the encoding and decoding optics. +-- +module Data.Base64.Types.Lens +( -- * Encoded payload + _Base64 + -- * Alphabets +, _StdPadded +, _UrlPadded +, _UrlUnpadded +, _NonStandard +) where + +import Control.Lens (Iso, Prism', Wrapped(..), Rewrapped, _Wrapped, iso, prism') +import Data.Base64.Types (Alphabet(..), Base64, assertBase64, extractBase64) + +-- $setup +-- >>> import Control.Lens +-- >>> import Data.Base64.Types +-- >>> import Data.Base64.Types.Lens +-- >>> :set -XDataKinds -XOverloadedStrings + +-- | Access the encoded payload, preserving the alphabet index while allowing +-- the payload type to change. This is also available as '_Wrapped'. +-- +-- Like 'assertBase64', wrapping does not encode or validate the value. +-- Use @parseBase64@ to validate untrusted standard-alphabet input. Changes +-- through this optic must preserve the claimed encoding if it will be decoded. +-- +-- >>> view _Base64 (assertBase64 "U3Vu" :: Base64 'StdPadded String) +-- "U3Vu" +-- +_Base64 :: Iso (Base64 k a) (Base64 k b) a b +_Base64 = _Wrapped +{-# INLINE _Base64 #-} + +-- | The encoded payload, without decoding or validation. +instance Wrapped (Base64 k a) where + type Unwrapped (Base64 k a) = a + _Wrapped' = iso extractBase64 assertBase64 + {-# INLINE _Wrapped' #-} + +-- | Change the payload type without changing the alphabet index. +instance (t ~ Base64 k b) => Rewrapped (Base64 k a) t + +-- | The standard, padded alphabet. +_StdPadded :: Prism' Alphabet () +_StdPadded = prism' (const StdPadded) $ \case + StdPadded -> Just () + _ -> Nothing +{-# INLINE _StdPadded #-} + +-- | The padded URL-safe alphabet. +_UrlPadded :: Prism' Alphabet () +_UrlPadded = prism' (const UrlPadded) $ \case + UrlPadded -> Just () + _ -> Nothing +{-# INLINE _UrlPadded #-} + +-- | The unpadded URL-safe alphabet. +_UrlUnpadded :: Prism' Alphabet () +_UrlUnpadded = prism' (const UrlUnpadded) $ \case + UrlUnpadded -> Just () + _ -> Nothing +{-# INLINE _UrlUnpadded #-} + +-- | A non-standard encoding, suitable for lenient decoding only. +_NonStandard :: Prism' Alphabet () +_NonStandard = prism' (const NonStandard) $ \case + NonStandard -> Just () + _ -> Nothing +{-# INLINE _NonStandard #-} diff --git a/src/Data/ByteString/Base64/Lens.hs b/src/Data/ByteString/Base64/Lens.hs --- a/src/Data/ByteString/Base64/Lens.hs +++ b/src/Data/ByteString/Base64/Lens.hs @@ -1,28 +1,32 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -#if MIN_VERSION_lens(5,0,0) -{-# LANGUAGE Safe #-} -#else {-# LANGUAGE Trustworthy #-} -#endif -- | -- Module : Data.ByteString.Base64.Lens --- Copyright : (c) 2019-2021 Emily Pillmore --- License : BSD-style +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style -- --- Maintainer : Emily Pillmore --- Stability : Experimental --- Portability : non-portable +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : non-portable -- --- This module contains 'Prism''s and 'Iso''s for Base64-encoding and --- decoding 'ByteString' values. +-- Optics and patterns for Base64-encoded 'ByteString' values. +-- The alphabet is recorded in the t'Base64' wrapper. Validate untrusted +-- standard-alphabet input with 'B64.parseBase64' before decoding, +-- or use '_Base64Untyped' to decode an ordinary string directly. +-- For access to the encoded payload itself, see "Data.Base64.Types.Lens". -- module Data.ByteString.Base64.Lens -( -- * Prisms +( -- * Encoding isomorphisms _Base64 , _Base64Url , _Base64UrlUnpadded + -- * Untyped decoding prisms +, _Base64Untyped +, _Base64UrlUntyped +, _Base64UrlUnpaddedUntyped + -- * Lenient decoding , _Base64Lenient , _Base64UrlLenient -- * Patterns @@ -33,133 +37,173 @@ , pattern Base64UrlLenient ) where - -import Control.Lens - +import Control.Lens (Iso', Prism', iso, prism', view, (#)) +import Data.Base64.Types (Alphabet(..), Base64, coerceBase64, extractBase64) import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as B64 import qualified Data.ByteString.Base64.URL as B64U - -- $setup --- -- >>> import Control.Lens +-- >>> import Data.Base64.Types (assertBase64) -- >>> import Data.ByteString.Base64.Lens --- -- >>> :set -XOverloadedStrings --- >>> :set -XTypeApplications - --- -------------------------------------------------------------------------- -- --- Optics - --- | A 'Prism'' into the Base64 encoding of a 'ByteString' value +-- | Decode standard, padded Base64, or encode in reverse. -- -- >>> _Base64 # "Sun" -- "U3Vu" -- --- >>> "U3Vu" ^? _Base64 --- Just "Sun" +-- >>> (_Base64 # "Sun") ^. _Base64 +-- "Sun" -- -_Base64 :: Prism' ByteString ByteString -_Base64 = prism' B64.encodeBase64' $ \s -> case B64.decodeBase64 s of - Left _ -> Nothing - Right a -> Just a +_Base64 :: Iso' (Base64 'StdPadded ByteString) ByteString +_Base64 = iso B64.decodeBase64 B64.encodeBase64' {-# INLINE _Base64 #-} --- | A 'Prism'' into the Base64url encoding of a 'ByteString' value +-- | Decode padded URL-safe Base64, or encode in reverse. -- -- >>> _Base64Url # "Sun" -- "U3Vu" -- --- >>> "PDw_Pz8-Pg==" ^? _Base64Url --- Just "<>" +-- >>> (_Base64Url # "Sun") ^. _Base64Url +-- "Sun" -- -_Base64Url :: Prism' ByteString ByteString -_Base64Url = prism' B64U.encodeBase64' $ \s -> case B64U.decodeBase64 s of - Left _ -> Nothing - Right a -> Just a +_Base64Url :: Iso' (Base64 'UrlPadded ByteString) ByteString +_Base64Url = iso B64U.decodeBase64 B64U.encodeBase64' {-# INLINE _Base64Url #-} --- | A 'Prism'' into the Base64url encoding of a 'ByteString' value --- --- Please note that unpadded variants should only be used --- when assumptions about the data can be made. In particular, if the length of --- the input is divisible by 3, then this is a safe function to call. +-- | Decode unpadded URL-safe Base64, or encode in reverse. -- --- >>> _Base64UrlUnpadded # "<>" --- "PDw_Pz4-" +-- >>> _Base64UrlUnpadded # "Sun" +-- "U3Vu" -- --- >>> "PDw_Pz4-" ^? _Base64UrlUnpadded --- Just "<>" +-- >>> (_Base64UrlUnpadded # "Sun") ^. _Base64UrlUnpadded +-- "Sun" -- -_Base64UrlUnpadded :: Prism' ByteString ByteString -_Base64UrlUnpadded = prism' B64U.encodeBase64Unpadded' $ \s -> case B64U.decodeBase64Unpadded s of - Left _ -> Nothing - Right a -> Just a +_Base64UrlUnpadded :: Iso' (Base64 'UrlUnpadded ByteString) ByteString +_Base64UrlUnpadded = iso B64U.decodeBase64Unpadded B64U.encodeBase64Unpadded' {-# INLINE _Base64UrlUnpadded #-} --- | An 'Iso'' into the Base64 encoding of a 'ByteString' value --- using lenient decoding. +-- | Decode a canonical, padded standard Base64 string, or encode in reverse. +-- Returns 'Nothing' on a Base64 decoding error. -- +-- >>> _Base64Untyped # "Sun" +-- "U3Vu" -- --- _Note:_ This is not a lawful 'Iso'. Please take care! +-- >>> "U3Vu" ^? _Base64Untyped +-- Just "Sun" -- +-- >>> "U3V=" ^? _Base64Untyped +-- Nothing +-- +_Base64Untyped :: Prism' ByteString ByteString +_Base64Untyped = prism' (extractBase64 . B64.encodeBase64') + (either (const Nothing) Just . B64.decodeBase64Untyped) +{-# INLINE _Base64Untyped #-} + +-- | Decode a padded or unpadded URL-safe Base64 string, or encode with padding +-- in reverse. Returns 'Nothing' on a Base64 decoding error. +-- +-- Matching unpadded input and reviewing the result normalizes its padding, +-- so this is not a lawful 'Prism'' over all accepted input. +-- +-- >>> _Base64UrlUntyped # "<>" +-- "PDw_Pz8-Pg==" +-- +-- >>> "PDw_Pz8-Pg" ^? _Base64UrlUntyped +-- Just "<>" +-- +_Base64UrlUntyped :: Prism' ByteString ByteString +_Base64UrlUntyped = prism' (extractBase64 . B64U.encodeBase64') + (either (const Nothing) Just . B64U.decodeBase64Untyped) +{-# INLINE _Base64UrlUntyped #-} + +-- | Decode a canonical, unpadded URL-safe Base64 string, or encode without +-- padding in reverse. Rejects padded input and other Base64 decoding errors. +-- +-- >>> _Base64UrlUnpaddedUntyped # "f" +-- "Zg" +-- +-- >>> "Zg" ^? _Base64UrlUnpaddedUntyped +-- Just "f" +-- +-- >>> "Zg==" ^? _Base64UrlUnpaddedUntyped +-- Nothing +-- +_Base64UrlUnpaddedUntyped :: Prism' ByteString ByteString +_Base64UrlUnpaddedUntyped = prism' (extractBase64 . B64U.encodeBase64Unpadded') + (either (const Nothing) Just . B64U.decodeBase64UnpaddedUntyped) +{-# INLINE _Base64UrlUnpaddedUntyped #-} + +-- | Decode lenient standard-alphabet Base64, or encode in reverse. +-- +-- Ignores invalid characters and stops at the first padding character. +-- This is not a lawful 'Iso'' for arbitrary input. Construction produces +-- canonical padded output tagged as 'NonStandard'. +-- -- >>> _Base64Lenient # "Sun" -- "U3Vu" -- --- >>> "U3Vu" ^. _Base64Lenient +-- >>> view _Base64Lenient (assertBase64 "U3!Vu") -- "Sun" -- -_Base64Lenient :: Iso' ByteString ByteString -_Base64Lenient = iso B64.decodeBase64Lenient B64.encodeBase64' +_Base64Lenient :: Iso' (Base64 'NonStandard ByteString) ByteString +_Base64Lenient = iso (B64.decodeBase64Lenient . extractBase64) + (coerceBase64 . B64.encodeBase64') +{-# INLINE _Base64Lenient #-} --- | An 'Iso'' into the Base64url encoding of a 'ByteString' value --- using lenient decoding. --- +-- | Decode lenient URL-safe Base64, or encode in reverse. -- --- _Note:_ This is not a lawful 'Iso'. Please take care! +-- Ignores invalid characters and stops at the first padding character. +-- This is not a lawful 'Iso'' for arbitrary input. Construction produces +-- canonical padded output tagged as 'NonStandard'. -- --- >>> _Base64UrlLenient # "<>" --- "PDw_Pz4-" +-- >>> _Base64UrlLenient # "Sun" +-- "U3Vu" -- --- >>> "PDw_Pz4-" ^. _Base64UrlLenient --- "<>" +-- >>> view _Base64UrlLenient (assertBase64 "U3!Vu") +-- "Sun" -- -_Base64UrlLenient :: Iso' ByteString ByteString -_Base64UrlLenient = iso B64U.decodeBase64Lenient B64U.encodeBase64' +_Base64UrlLenient :: Iso' (Base64 'NonStandard ByteString) ByteString +_Base64UrlLenient = iso (B64U.decodeBase64Lenient . extractBase64) + (coerceBase64 . B64U.encodeBase64') +{-# INLINE _Base64UrlLenient #-} -- -------------------------------------------------------------------------- -- -- Patterns --- | Bidirectional pattern synonym for base64-encoded 'ByteString' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64 :: ByteString -> ByteString -pattern Base64 a <- (preview _Base64 -> Just a) where +pattern Base64 :: ByteString -> Base64 'StdPadded ByteString +pattern Base64 a <- (view _Base64 -> a) where Base64 a = _Base64 # a +{-# COMPLETE Base64 #-} --- | Bidirectional pattern synonym for base64url-encoded 'ByteString' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64Url :: ByteString -> ByteString -pattern Base64Url a <- (preview _Base64Url -> Just a) where +pattern Base64Url :: ByteString -> Base64 'UrlPadded ByteString +pattern Base64Url a <- (view _Base64Url -> a) where Base64Url a = _Base64Url # a +{-# COMPLETE Base64Url #-} --- | Bidirectional pattern synonym for unpadded base64url-encoded 'ByteString' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64UrlUnpadded :: ByteString -> ByteString -pattern Base64UrlUnpadded a <- (preview _Base64UrlUnpadded -> Just a) where +pattern Base64UrlUnpadded :: ByteString -> Base64 'UrlUnpadded ByteString +pattern Base64UrlUnpadded a <- (view _Base64UrlUnpadded -> a) where Base64UrlUnpadded a = _Base64UrlUnpadded # a +{-# COMPLETE Base64UrlUnpadded #-} --- | Bidirectional pattern synonym for leniently Base64-encoded 'ByteString' values +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64Lenient :: ByteString -> ByteString -pattern Base64Lenient a <- (view (from _Base64Lenient) -> a) where - Base64Lenient a = view _Base64Lenient a +pattern Base64Lenient :: ByteString -> Base64 'NonStandard ByteString +pattern Base64Lenient a <- (view _Base64Lenient -> a) where + Base64Lenient a = _Base64Lenient # a {-# COMPLETE Base64Lenient #-} --- | Bidirectional pattern synonym for leniently Base64-encoded 'ByteString' values +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64UrlLenient :: ByteString -> ByteString -pattern Base64UrlLenient a <- (view (from _Base64UrlLenient) -> a) where - Base64UrlLenient a = view _Base64UrlLenient a +pattern Base64UrlLenient :: ByteString -> Base64 'NonStandard ByteString +pattern Base64UrlLenient a <- (view _Base64UrlLenient -> a) where + Base64UrlLenient a = _Base64UrlLenient # a {-# COMPLETE Base64UrlLenient #-} diff --git a/src/Data/ByteString/Lazy/Base64/Lens.hs b/src/Data/ByteString/Lazy/Base64/Lens.hs --- a/src/Data/ByteString/Lazy/Base64/Lens.hs +++ b/src/Data/ByteString/Lazy/Base64/Lens.hs @@ -1,28 +1,32 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -#if MIN_VERSION_lens(5,0,0) -{-# LANGUAGE Safe #-} -#else {-# LANGUAGE Trustworthy #-} -#endif -- | -- Module : Data.ByteString.Lazy.Base64.Lens --- Copyright : (c) 2019-2021 Emily Pillmore --- License : BSD-style +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style -- --- Maintainer : Emily Pillmore --- Stability : Experimental --- Portability : non-portable +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : non-portable -- --- This module contains 'Prism''s and 'Iso''s for Base64-encoding and --- decoding 'ByteString' values. +-- Optics and patterns for Base64-encoded 'ByteString' values. +-- The alphabet is recorded in the t'Base64' wrapper. Validate untrusted +-- standard-alphabet input with 'BL64.parseBase64' before decoding, +-- or use '_Base64Untyped' to decode an ordinary string directly. +-- For access to the encoded payload itself, see "Data.Base64.Types.Lens". -- module Data.ByteString.Lazy.Base64.Lens -( -- * Prisms +( -- * Encoding isomorphisms _Base64 , _Base64Url , _Base64UrlUnpadded + -- * Untyped decoding prisms +, _Base64Untyped +, _Base64UrlUntyped +, _Base64UrlUnpaddedUntyped + -- * Lenient decoding , _Base64Lenient , _Base64UrlLenient -- * Patterns @@ -33,133 +37,173 @@ , pattern Base64UrlLenient ) where - -import Control.Lens - +import Control.Lens (Iso', Prism', iso, prism', view, (#)) +import Data.Base64.Types (Alphabet(..), Base64, coerceBase64, extractBase64) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy.Base64 as BL64 import qualified Data.ByteString.Lazy.Base64.URL as BL64U - -- $setup --- -- >>> import Control.Lens +-- >>> import Data.Base64.Types (assertBase64) -- >>> import Data.ByteString.Lazy.Base64.Lens --- -- >>> :set -XOverloadedStrings --- >>> :set -XTypeApplications - --- -------------------------------------------------------------------------- -- --- Optics - --- | A 'Prism'' into the Base64 encoding of a 'ByteString' value +-- | Decode standard, padded Base64, or encode in reverse. -- -- >>> _Base64 # "Sun" -- "U3Vu" -- --- >>> "U3Vu" ^? _Base64 --- Just "Sun" +-- >>> (_Base64 # "Sun") ^. _Base64 +-- "Sun" -- -_Base64 :: Prism' ByteString ByteString -_Base64 = prism' BL64.encodeBase64' $ \s -> case BL64.decodeBase64 s of - Left _ -> Nothing - Right a -> Just a +_Base64 :: Iso' (Base64 'StdPadded ByteString) ByteString +_Base64 = iso BL64.decodeBase64 BL64.encodeBase64' {-# INLINE _Base64 #-} --- | A 'Prism'' into the Base64url encoding of a 'ByteString' value +-- | Decode padded URL-safe Base64, or encode in reverse. -- -- >>> _Base64Url # "Sun" -- "U3Vu" -- --- >>> "PDw_Pz8-Pg==" ^? _Base64Url --- Just "<>" +-- >>> (_Base64Url # "Sun") ^. _Base64Url +-- "Sun" -- -_Base64Url :: Prism' ByteString ByteString -_Base64Url = prism' BL64U.encodeBase64' $ \s -> case BL64U.decodeBase64 s of - Left _ -> Nothing - Right a -> Just a +_Base64Url :: Iso' (Base64 'UrlPadded ByteString) ByteString +_Base64Url = iso BL64U.decodeBase64 BL64U.encodeBase64' {-# INLINE _Base64Url #-} --- | A 'Prism'' into the Base64url encoding of a 'ByteString' value --- --- Please note that unpadded variants should only be used --- when assumptions about the data can be made. In particular, if the length of --- the input is divisible by 3, then this is a safe function to call. +-- | Decode unpadded URL-safe Base64, or encode in reverse. -- --- >>> _Base64UrlUnpadded # "<>" --- "PDw_Pz4-" +-- >>> _Base64UrlUnpadded # "Sun" +-- "U3Vu" -- --- >>> "PDw_Pz4-" ^? _Base64UrlUnpadded --- Just "<>" +-- >>> (_Base64UrlUnpadded # "Sun") ^. _Base64UrlUnpadded +-- "Sun" -- -_Base64UrlUnpadded :: Prism' ByteString ByteString -_Base64UrlUnpadded = prism' BL64U.encodeBase64Unpadded' $ \s -> case BL64U.decodeBase64Unpadded s of - Left _ -> Nothing - Right a -> Just a +_Base64UrlUnpadded :: Iso' (Base64 'UrlUnpadded ByteString) ByteString +_Base64UrlUnpadded = iso BL64U.decodeBase64Unpadded BL64U.encodeBase64Unpadded' {-# INLINE _Base64UrlUnpadded #-} --- | An 'Iso'' into the Base64 encoding of a 'ByteString' value --- using lenient decoding. +-- | Decode a canonical, padded standard Base64 string, or encode in reverse. +-- Returns 'Nothing' on a Base64 decoding error. -- +-- >>> _Base64Untyped # "Sun" +-- "U3Vu" -- --- _Note:_ This is not a lawful 'Iso'. Please take care! +-- >>> "U3Vu" ^? _Base64Untyped +-- Just "Sun" -- +-- >>> "U3V=" ^? _Base64Untyped +-- Nothing +-- +_Base64Untyped :: Prism' ByteString ByteString +_Base64Untyped = prism' (extractBase64 . BL64.encodeBase64') + (either (const Nothing) Just . BL64.decodeBase64Untyped) +{-# INLINE _Base64Untyped #-} + +-- | Decode a padded or unpadded URL-safe Base64 string, or encode with padding +-- in reverse. Returns 'Nothing' on a Base64 decoding error. +-- +-- Matching unpadded input and reviewing the result normalizes its padding, +-- so this is not a lawful 'Prism'' over all accepted input. +-- +-- >>> _Base64UrlUntyped # "<>" +-- "PDw_Pz8-Pg==" +-- +-- >>> "PDw_Pz8-Pg" ^? _Base64UrlUntyped +-- Just "<>" +-- +_Base64UrlUntyped :: Prism' ByteString ByteString +_Base64UrlUntyped = prism' (extractBase64 . BL64U.encodeBase64') + (either (const Nothing) Just . BL64U.decodeBase64Untyped) +{-# INLINE _Base64UrlUntyped #-} + +-- | Decode a canonical, unpadded URL-safe Base64 string, or encode without +-- padding in reverse. Rejects padded input and other Base64 decoding errors. +-- +-- >>> _Base64UrlUnpaddedUntyped # "f" +-- "Zg" +-- +-- >>> "Zg" ^? _Base64UrlUnpaddedUntyped +-- Just "f" +-- +-- >>> "Zg==" ^? _Base64UrlUnpaddedUntyped +-- Nothing +-- +_Base64UrlUnpaddedUntyped :: Prism' ByteString ByteString +_Base64UrlUnpaddedUntyped = prism' (extractBase64 . BL64U.encodeBase64Unpadded') + (either (const Nothing) Just . BL64U.decodeBase64UnpaddedUntyped) +{-# INLINE _Base64UrlUnpaddedUntyped #-} + +-- | Decode lenient standard-alphabet Base64, or encode in reverse. +-- +-- Ignores invalid characters and stops at the first padding character. +-- This is not a lawful 'Iso'' for arbitrary input. Construction produces +-- canonical padded output tagged as 'NonStandard'. +-- -- >>> _Base64Lenient # "Sun" -- "U3Vu" -- --- >>> "U3Vu" ^. _Base64Lenient +-- >>> view _Base64Lenient (assertBase64 "U3!Vu") -- "Sun" -- -_Base64Lenient :: Iso' ByteString ByteString -_Base64Lenient = iso BL64.decodeBase64Lenient BL64.encodeBase64' +_Base64Lenient :: Iso' (Base64 'NonStandard ByteString) ByteString +_Base64Lenient = iso (BL64.decodeBase64Lenient . extractBase64) + (coerceBase64 . BL64.encodeBase64') +{-# INLINE _Base64Lenient #-} --- | An 'Iso'' into the Base64url encoding of a 'ByteString' value --- using lenient decoding. --- +-- | Decode lenient URL-safe Base64, or encode in reverse. -- --- _Note:_ This is not a lawful 'Iso'. Please take care! +-- Ignores invalid characters and stops at the first padding character. +-- This is not a lawful 'Iso'' for arbitrary input. Construction produces +-- canonical padded output tagged as 'NonStandard'. -- --- >>> _Base64UrlLenient # "<>" --- "PDw_Pz4-" +-- >>> _Base64UrlLenient # "Sun" +-- "U3Vu" -- --- >>> "PDw_Pz4-" ^. _Base64UrlLenient --- "<>" +-- >>> view _Base64UrlLenient (assertBase64 "U3!Vu") +-- "Sun" -- -_Base64UrlLenient :: Iso' ByteString ByteString -_Base64UrlLenient = iso BL64U.decodeBase64Lenient BL64U.encodeBase64' +_Base64UrlLenient :: Iso' (Base64 'NonStandard ByteString) ByteString +_Base64UrlLenient = iso (BL64U.decodeBase64Lenient . extractBase64) + (coerceBase64 . BL64U.encodeBase64') +{-# INLINE _Base64UrlLenient #-} -- -------------------------------------------------------------------------- -- -- Patterns --- | Bidirectional pattern synonym for base64-encoded 'ByteString' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64 :: ByteString -> ByteString -pattern Base64 a <- (preview _Base64 -> Just a) where +pattern Base64 :: ByteString -> Base64 'StdPadded ByteString +pattern Base64 a <- (view _Base64 -> a) where Base64 a = _Base64 # a +{-# COMPLETE Base64 #-} --- | Bidirectional pattern synonym for base64url-encoded 'ByteString' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64Url :: ByteString -> ByteString -pattern Base64Url a <- (preview _Base64Url -> Just a) where +pattern Base64Url :: ByteString -> Base64 'UrlPadded ByteString +pattern Base64Url a <- (view _Base64Url -> a) where Base64Url a = _Base64Url # a +{-# COMPLETE Base64Url #-} --- | Bidirectional pattern synonym for unpadded base64url-encoded 'ByteString' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64UrlUnpadded :: ByteString -> ByteString -pattern Base64UrlUnpadded a <- (preview _Base64UrlUnpadded -> Just a) where +pattern Base64UrlUnpadded :: ByteString -> Base64 'UrlUnpadded ByteString +pattern Base64UrlUnpadded a <- (view _Base64UrlUnpadded -> a) where Base64UrlUnpadded a = _Base64UrlUnpadded # a +{-# COMPLETE Base64UrlUnpadded #-} --- | Bidirectional pattern synonym for leniently Base64-encoded 'ByteString' values +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64Lenient :: ByteString -> ByteString -pattern Base64Lenient a <- (view (from _Base64Lenient) -> a) where - Base64Lenient a = view _Base64Lenient a +pattern Base64Lenient :: ByteString -> Base64 'NonStandard ByteString +pattern Base64Lenient a <- (view _Base64Lenient -> a) where + Base64Lenient a = _Base64Lenient # a {-# COMPLETE Base64Lenient #-} --- | Bidirectional pattern synonym for leniently Base64-encoded 'ByteString' values +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64UrlLenient :: ByteString -> ByteString -pattern Base64UrlLenient a <- (view (from _Base64UrlLenient) -> a) where - Base64UrlLenient a = view _Base64UrlLenient a +pattern Base64UrlLenient :: ByteString -> Base64 'NonStandard ByteString +pattern Base64UrlLenient a <- (view _Base64UrlLenient -> a) where + Base64UrlLenient a = _Base64UrlLenient # a {-# COMPLETE Base64UrlLenient #-} diff --git a/src/Data/ByteString/Short/Base64/Lens.hs b/src/Data/ByteString/Short/Base64/Lens.hs --- a/src/Data/ByteString/Short/Base64/Lens.hs +++ b/src/Data/ByteString/Short/Base64/Lens.hs @@ -1,28 +1,32 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -#if MIN_VERSION_lens(5,0,0) -{-# LANGUAGE Safe #-} -#else {-# LANGUAGE Trustworthy #-} -#endif -- | -- Module : Data.ByteString.Short.Base64.Lens --- Copyright : (c) 2019-2021 Emily Pillmore --- License : BSD-style +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style -- --- Maintainer : Emily Pillmore --- Stability : Experimental --- Portability : non-portable +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : non-portable -- --- This module contains 'Prism''s and 'Iso''s for Base64-encoding and --- decoding 'ShortByteString' values. +-- Optics and patterns for Base64-encoded 'ShortByteString' values. +-- The alphabet is recorded in the t'Base64' wrapper. Validate untrusted +-- standard-alphabet input with 'BS64.parseBase64' before decoding, +-- or use '_Base64Untyped' to decode an ordinary string directly. +-- For access to the encoded payload itself, see "Data.Base64.Types.Lens". -- module Data.ByteString.Short.Base64.Lens -( -- * Prisms +( -- * Encoding isomorphisms _Base64 , _Base64Url , _Base64UrlUnpadded + -- * Untyped decoding prisms +, _Base64Untyped +, _Base64UrlUntyped +, _Base64UrlUnpaddedUntyped + -- * Lenient decoding , _Base64Lenient , _Base64UrlLenient -- * Patterns @@ -33,133 +37,173 @@ , pattern Base64UrlLenient ) where - -import Control.Lens - +import Control.Lens (Iso', Prism', iso, prism', view, (#)) +import Data.Base64.Types (Alphabet(..), Base64, coerceBase64, extractBase64) import Data.ByteString.Short (ShortByteString) import qualified Data.ByteString.Short.Base64 as BS64 import qualified Data.ByteString.Short.Base64.URL as BS64U - -- $setup --- -- >>> import Control.Lens +-- >>> import Data.Base64.Types (assertBase64) -- >>> import Data.ByteString.Short.Base64.Lens --- -- >>> :set -XOverloadedStrings --- >>> :set -XTypeApplications - --- -------------------------------------------------------------------------- -- --- Optics - --- | A 'Prism'' into the Base64 encoding of a 'ShortByteString' value +-- | Decode standard, padded Base64, or encode in reverse. -- -- >>> _Base64 # "Sun" -- "U3Vu" -- --- >>> "U3Vu" ^? _Base64 --- Just "Sun" +-- >>> (_Base64 # "Sun") ^. _Base64 +-- "Sun" -- -_Base64 :: Prism' ShortByteString ShortByteString -_Base64 = prism' BS64.encodeBase64' $ \s -> case BS64.decodeBase64 s of - Left _ -> Nothing - Right a -> Just a +_Base64 :: Iso' (Base64 'StdPadded ShortByteString) ShortByteString +_Base64 = iso BS64.decodeBase64 BS64.encodeBase64' {-# INLINE _Base64 #-} --- | A 'Prism'' into the Base64url encoding of a 'ShortByteString' value +-- | Decode padded URL-safe Base64, or encode in reverse. -- -- >>> _Base64Url # "Sun" -- "U3Vu" -- --- >>> "PDw_Pz8-Pg==" ^? _Base64Url --- Just "<>" +-- >>> (_Base64Url # "Sun") ^. _Base64Url +-- "Sun" -- -_Base64Url :: Prism' ShortByteString ShortByteString -_Base64Url = prism' BS64U.encodeBase64' $ \s -> case BS64U.decodeBase64 s of - Left _ -> Nothing - Right a -> Just a +_Base64Url :: Iso' (Base64 'UrlPadded ShortByteString) ShortByteString +_Base64Url = iso BS64U.decodeBase64 BS64U.encodeBase64' {-# INLINE _Base64Url #-} --- | A 'Prism'' into the Base64url encoding of a 'ShortByteString' value --- --- Please note that unpadded variants should only be used --- when assumptions about the data can be made. In particular, if the length of --- the input is divisible by 3, then this is a safe function to call. +-- | Decode unpadded URL-safe Base64, or encode in reverse. -- --- >>> _Base64UrlUnpadded # "<>" --- "PDw_Pz4-" +-- >>> _Base64UrlUnpadded # "Sun" +-- "U3Vu" -- --- >>> "PDw_Pz4-" ^? _Base64UrlUnpadded --- Just "<>" +-- >>> (_Base64UrlUnpadded # "Sun") ^. _Base64UrlUnpadded +-- "Sun" -- -_Base64UrlUnpadded :: Prism' ShortByteString ShortByteString -_Base64UrlUnpadded = prism' BS64U.encodeBase64Unpadded' $ \s -> case BS64U.decodeBase64Unpadded s of - Left _ -> Nothing - Right a -> Just a +_Base64UrlUnpadded :: Iso' (Base64 'UrlUnpadded ShortByteString) ShortByteString +_Base64UrlUnpadded = iso BS64U.decodeBase64Unpadded BS64U.encodeBase64Unpadded' {-# INLINE _Base64UrlUnpadded #-} --- | An 'Iso'' into the Base64 encoding of a 'ShortByteString' value --- using lenient decoding. +-- | Decode a canonical, padded standard Base64 string, or encode in reverse. +-- Returns 'Nothing' on a Base64 decoding error. -- +-- >>> _Base64Untyped # "Sun" +-- "U3Vu" -- --- _Note:_ This is not a lawful 'Iso'. Please take care! +-- >>> "U3Vu" ^? _Base64Untyped +-- Just "Sun" -- +-- >>> "U3V=" ^? _Base64Untyped +-- Nothing +-- +_Base64Untyped :: Prism' ShortByteString ShortByteString +_Base64Untyped = prism' (extractBase64 . BS64.encodeBase64') + (either (const Nothing) Just . BS64.decodeBase64Untyped) +{-# INLINE _Base64Untyped #-} + +-- | Decode a padded or unpadded URL-safe Base64 string, or encode with padding +-- in reverse. Returns 'Nothing' on a Base64 decoding error. +-- +-- Matching unpadded input and reviewing the result normalizes its padding, +-- so this is not a lawful 'Prism'' over all accepted input. +-- +-- >>> _Base64UrlUntyped # "<>" +-- "PDw_Pz8-Pg==" +-- +-- >>> "PDw_Pz8-Pg" ^? _Base64UrlUntyped +-- Just "<>" +-- +_Base64UrlUntyped :: Prism' ShortByteString ShortByteString +_Base64UrlUntyped = prism' (extractBase64 . BS64U.encodeBase64') + (either (const Nothing) Just . BS64U.decodeBase64Untyped) +{-# INLINE _Base64UrlUntyped #-} + +-- | Decode a canonical, unpadded URL-safe Base64 string, or encode without +-- padding in reverse. Rejects padded input and other Base64 decoding errors. +-- +-- >>> _Base64UrlUnpaddedUntyped # "f" +-- "Zg" +-- +-- >>> "Zg" ^? _Base64UrlUnpaddedUntyped +-- Just "f" +-- +-- >>> "Zg==" ^? _Base64UrlUnpaddedUntyped +-- Nothing +-- +_Base64UrlUnpaddedUntyped :: Prism' ShortByteString ShortByteString +_Base64UrlUnpaddedUntyped = prism' (extractBase64 . BS64U.encodeBase64Unpadded') + (either (const Nothing) Just . BS64U.decodeBase64UnpaddedUntyped) +{-# INLINE _Base64UrlUnpaddedUntyped #-} + +-- | Decode lenient standard-alphabet Base64, or encode in reverse. +-- +-- Ignores invalid characters and stops at the first padding character. +-- This is not a lawful 'Iso'' for arbitrary input. Construction produces +-- canonical padded output tagged as 'NonStandard'. +-- -- >>> _Base64Lenient # "Sun" -- "U3Vu" -- --- >>> "U3Vu" ^. _Base64Lenient +-- >>> view _Base64Lenient (assertBase64 "U3!Vu") -- "Sun" -- -_Base64Lenient :: Iso' ShortByteString ShortByteString -_Base64Lenient = iso BS64.decodeBase64Lenient BS64.encodeBase64' +_Base64Lenient :: Iso' (Base64 'NonStandard ShortByteString) ShortByteString +_Base64Lenient = iso (BS64.decodeBase64Lenient . extractBase64) + (coerceBase64 . BS64.encodeBase64') +{-# INLINE _Base64Lenient #-} --- | An 'Iso'' into the Base64url encoding of a 'ShortByteString' value --- using lenient decoding. --- +-- | Decode lenient URL-safe Base64, or encode in reverse. -- --- _Note:_ This is not a lawful 'Iso'. Please take care! +-- Ignores invalid characters and stops at the first padding character. +-- This is not a lawful 'Iso'' for arbitrary input. Construction produces +-- canonical padded output tagged as 'NonStandard'. -- --- >>> _Base64UrlLenient # "<>" --- "PDw_Pz4-" +-- >>> _Base64UrlLenient # "Sun" +-- "U3Vu" -- --- >>> "PDw_Pz4-" ^. _Base64UrlLenient --- "<>" +-- >>> view _Base64UrlLenient (assertBase64 "U3!Vu") +-- "Sun" -- -_Base64UrlLenient :: Iso' ShortByteString ShortByteString -_Base64UrlLenient = iso BS64U.decodeBase64Lenient BS64U.encodeBase64' +_Base64UrlLenient :: Iso' (Base64 'NonStandard ShortByteString) ShortByteString +_Base64UrlLenient = iso (BS64U.decodeBase64Lenient . extractBase64) + (coerceBase64 . BS64U.encodeBase64') +{-# INLINE _Base64UrlLenient #-} -- -------------------------------------------------------------------------- -- -- Patterns --- | Bidirectional pattern synonym for base64-encoded 'ShortByteString' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64 :: ShortByteString -> ShortByteString -pattern Base64 a <- (preview _Base64 -> Just a) where +pattern Base64 :: ShortByteString -> Base64 'StdPadded ShortByteString +pattern Base64 a <- (view _Base64 -> a) where Base64 a = _Base64 # a +{-# COMPLETE Base64 #-} --- | Bidirectional pattern synonym for base64url-encoded 'ShortByteString' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64Url :: ShortByteString -> ShortByteString -pattern Base64Url a <- (preview _Base64Url -> Just a) where +pattern Base64Url :: ShortByteString -> Base64 'UrlPadded ShortByteString +pattern Base64Url a <- (view _Base64Url -> a) where Base64Url a = _Base64Url # a +{-# COMPLETE Base64Url #-} --- | Bidirectional pattern synonym for unpadded base64url-encoded 'ShortByteString' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64UrlUnpadded :: ShortByteString -> ShortByteString -pattern Base64UrlUnpadded a <- (preview _Base64UrlUnpadded -> Just a) where +pattern Base64UrlUnpadded :: ShortByteString -> Base64 'UrlUnpadded ShortByteString +pattern Base64UrlUnpadded a <- (view _Base64UrlUnpadded -> a) where Base64UrlUnpadded a = _Base64UrlUnpadded # a +{-# COMPLETE Base64UrlUnpadded #-} --- | Bidirectional pattern synonym for leniently Base64-encoded 'ShortByteString' values +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64Lenient :: ShortByteString -> ShortByteString -pattern Base64Lenient a <- (view (from _Base64Lenient) -> a) where - Base64Lenient a = view _Base64Lenient a +pattern Base64Lenient :: ShortByteString -> Base64 'NonStandard ShortByteString +pattern Base64Lenient a <- (view _Base64Lenient -> a) where + Base64Lenient a = _Base64Lenient # a {-# COMPLETE Base64Lenient #-} --- | Bidirectional pattern synonym for leniently Base64-encoded 'ShortByteString' values +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64UrlLenient :: ShortByteString -> ShortByteString -pattern Base64UrlLenient a <- (view (from _Base64UrlLenient) -> a) where - Base64UrlLenient a = view _Base64UrlLenient a +pattern Base64UrlLenient :: ShortByteString -> Base64 'NonStandard ShortByteString +pattern Base64UrlLenient a <- (view _Base64UrlLenient -> a) where + Base64UrlLenient a = _Base64UrlLenient # a {-# COMPLETE Base64UrlLenient #-} diff --git a/src/Data/Text/Encoding/Base64/Error/Lens.hs b/src/Data/Text/Encoding/Base64/Error/Lens.hs --- a/src/Data/Text/Encoding/Base64/Error/Lens.hs +++ b/src/Data/Text/Encoding/Base64/Error/Lens.hs @@ -1,13 +1,8 @@ -{-# LANGUAGE CPP #-} {-# LANGUAGE LambdaCase #-} -#if MIN_VERSION_lens(5,0,0) {-# LANGUAGE Safe #-} -#else -{-# LANGUAGE Trustworthy #-} -#endif -- | -- Module : Data.Text.Encoding.Base64.Error.Lens --- Copyright : (c) 2019-2021 Emily Pillmore +-- Copyright : (c) 2019-2026 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -24,7 +19,7 @@ ) where -import Control.Lens +import Control.Lens (Prism, Prism', prism, prism') import Data.Text (Text) import Data.Text.Encoding.Base64.Error (Base64Error(..)) @@ -37,9 +32,9 @@ DecodeError t -> Just t ConversionError{} -> Nothing --- | A 'Prism'' into the 'ConversionError' case of a 'Base64Error' +-- | Focus on the 'ConversionError' payload, allowing its type to change. -- -_ConversionError :: Prism' (Base64Error err) err -_ConversionError = prism' ConversionError $ \case - ConversionError err -> Just err - DecodeError{} -> Nothing +_ConversionError :: Prism (Base64Error a) (Base64Error b) a b +_ConversionError = prism ConversionError $ \case + ConversionError err -> Right err + DecodeError t -> Left (DecodeError t) diff --git a/src/Data/Text/Encoding/Base64/Lens.hs b/src/Data/Text/Encoding/Base64/Lens.hs --- a/src/Data/Text/Encoding/Base64/Lens.hs +++ b/src/Data/Text/Encoding/Base64/Lens.hs @@ -1,28 +1,32 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -#if MIN_VERSION_lens(5,0,0) -{-# LANGUAGE Safe #-} -#else {-# LANGUAGE Trustworthy #-} -#endif -- | -- Module : Data.Text.Encoding.Base64.Lens --- Copyright : (c) 2019-2021 Emily Pillmore --- License : BSD-style +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style -- --- Maintainer : Emily Pillmore --- Stability : Experimental --- Portability : non-portable +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : non-portable -- --- This module contains 'Prism's and 'Iso''s Base64-encoding and --- decoding 'Text' values. +-- Optics and patterns for Base64-encoded 'Text' values. +-- The alphabet is recorded in the t'Base64' wrapper. Validate untrusted +-- standard-alphabet input with 'B64T.parseBase64' before decoding, +-- or use '_Base64Untyped' to decode an ordinary string directly. +-- For access to the encoded payload itself, see "Data.Base64.Types.Lens". -- module Data.Text.Encoding.Base64.Lens -( -- * Prisms +( -- * Encoding isomorphisms _Base64 , _Base64Url , _Base64UrlUnpadded + -- * Untyped decoding prisms +, _Base64Untyped +, _Base64UrlUntyped +, _Base64UrlUnpaddedUntyped + -- * Lenient decoding , _Base64Lenient , _Base64UrlLenient -- * Patterns @@ -33,131 +37,174 @@ , pattern Base64UrlLenient ) where -import Control.Lens - +import Control.Lens (Iso', Prism', iso, prism', view, (#)) +import Data.Base64.Types (Alphabet(..), Base64, coerceBase64, extractBase64) import Data.Text (Text) import qualified Data.Text.Encoding.Base64 as B64T import qualified Data.Text.Encoding.Base64.URL as B64TU - -- $setup --- -- >>> import Control.Lens +-- >>> import Data.Base64.Types (assertBase64) -- >>> import Data.Text.Encoding.Base64.Lens --- -- >>> :set -XOverloadedStrings --- >>> :set -XTypeApplications --- -------------------------------------------------------------------------- -- --- Optics - --- | A 'Prism' into the Base64 encoding of a 'Text' value. +-- | Decode standard, padded Base64, or encode in reverse. -- -- >>> _Base64 # "Sun" -- "U3Vu" -- --- >>> "U3Vu" ^? _Base64 --- Just "Sun" +-- >>> (_Base64 # "Sun") ^. _Base64 +-- "Sun" -- -_Base64 :: Prism' Text Text -_Base64 = prism' B64T.encodeBase64 $ \s -> case B64T.decodeBase64 s of - Left _ -> Nothing - Right a -> Just a +_Base64 :: Iso' (Base64 'StdPadded Text) Text +_Base64 = iso B64T.decodeBase64 B64T.encodeBase64 {-# INLINE _Base64 #-} --- | A 'Prism' into the Base64-url encoding of a 'Text' value. +-- | Decode padded URL-safe Base64, or encode in reverse. -- -- >>> _Base64Url # "Sun" -- "U3Vu" -- --- >>> "PDw_Pz8-Pg==" ^? _Base64Url --- Just "<>" +-- >>> (_Base64Url # "Sun") ^. _Base64Url +-- "Sun" -- -_Base64Url :: Prism' Text Text -_Base64Url = prism' B64TU.encodeBase64 $ \s -> case B64TU.decodeBase64 s of - Left _ -> Nothing - Right a -> Just a +_Base64Url :: Iso' (Base64 'UrlPadded Text) Text +_Base64Url = iso B64TU.decodeBase64 B64TU.encodeBase64 {-# INLINE _Base64Url #-} --- | A 'Prism' into the Base64-url encoding of a 'Text' value. --- --- Please note that unpadded variants should only be used --- when assumptions about the data can be made. In particular, if the length of --- the input is divisible by 3, then this is a safe function to call. +-- | Decode unpadded URL-safe Base64, or encode in reverse. -- --- >>> _Base64UrlUnpadded # "<>" --- "PDw_Pz4-" +-- >>> _Base64UrlUnpadded # "Sun" +-- "U3Vu" -- --- >>> "PDw_Pz4-" ^? _Base64UrlUnpadded --- Just "<>" +-- >>> (_Base64UrlUnpadded # "Sun") ^. _Base64UrlUnpadded +-- "Sun" -- -_Base64UrlUnpadded :: Prism' Text Text -_Base64UrlUnpadded = prism' B64TU.encodeBase64Unpadded $ \s -> case B64TU.decodeBase64Unpadded s of - Left _ -> Nothing - Right a -> Just a +_Base64UrlUnpadded :: Iso' (Base64 'UrlUnpadded Text) Text +_Base64UrlUnpadded = iso B64TU.decodeBase64Unpadded B64TU.encodeBase64Unpadded {-# INLINE _Base64UrlUnpadded #-} --- | An 'Iso'' into the Base64 encoding of a 'Text' value --- using lenient decoding. +-- | Decode a canonical, padded standard Base64 string, or encode in reverse. +-- Returns 'Nothing' on a Base64 decoding error. All three untyped prisms +-- retain the decoders' UTF-8 requirement: invalid decoded UTF-8 may throw. -- +-- >>> _Base64Untyped # "Sun" +-- "U3Vu" -- --- _Note:_ This is not a lawful 'Iso' in general. Please take care! +-- >>> "U3Vu" ^? _Base64Untyped +-- Just "Sun" -- +-- >>> "U3V=" ^? _Base64Untyped +-- Nothing +-- +_Base64Untyped :: Prism' Text Text +_Base64Untyped = prism' (extractBase64 . B64T.encodeBase64) + (either (const Nothing) Just . B64T.decodeBase64Untyped) +{-# INLINE _Base64Untyped #-} + +-- | Decode a padded or unpadded URL-safe Base64 string, or encode with padding +-- in reverse. Returns 'Nothing' on a Base64 decoding error. +-- +-- Matching unpadded input and reviewing the result normalizes its padding, +-- so this is not a lawful 'Prism'' over all accepted input. +-- +-- >>> _Base64UrlUntyped # "<>" +-- "PDw_Pz8-Pg==" +-- +-- >>> "PDw_Pz8-Pg" ^? _Base64UrlUntyped +-- Just "<>" +-- +_Base64UrlUntyped :: Prism' Text Text +_Base64UrlUntyped = prism' (extractBase64 . B64TU.encodeBase64) + (either (const Nothing) Just . B64TU.decodeBase64Untyped) +{-# INLINE _Base64UrlUntyped #-} + +-- | Decode a canonical, unpadded URL-safe Base64 string, or encode without +-- padding in reverse. Rejects padded input and other Base64 decoding errors. +-- +-- >>> _Base64UrlUnpaddedUntyped # "f" +-- "Zg" +-- +-- >>> "Zg" ^? _Base64UrlUnpaddedUntyped +-- Just "f" +-- +-- >>> "Zg==" ^? _Base64UrlUnpaddedUntyped +-- Nothing +-- +_Base64UrlUnpaddedUntyped :: Prism' Text Text +_Base64UrlUnpaddedUntyped = prism' (extractBase64 . B64TU.encodeBase64Unpadded) + (either (const Nothing) Just . B64TU.decodeBase64UnpaddedUntyped) +{-# INLINE _Base64UrlUnpaddedUntyped #-} + +-- | Decode lenient standard-alphabet Base64, or encode in reverse. +-- +-- Ignores invalid characters and stops at the first padding character. +-- This is not a lawful 'Iso'' for arbitrary input. Construction produces +-- canonical padded output tagged as 'NonStandard'. +-- -- >>> _Base64Lenient # "Sun" -- "U3Vu" -- --- >>> "U3Vu" ^. _Base64Lenient +-- >>> view _Base64Lenient (assertBase64 "U3!Vu") -- "Sun" -- -_Base64Lenient :: Iso' Text Text -_Base64Lenient = iso B64T.decodeBase64Lenient B64T.encodeBase64 +_Base64Lenient :: Iso' (Base64 'NonStandard Text) Text +_Base64Lenient = iso (B64T.decodeBase64Lenient . extractBase64) + (coerceBase64 . B64T.encodeBase64) +{-# INLINE _Base64Lenient #-} --- | An 'Iso'' into the Base64url encoding of a 'Text' value --- using lenient decoding. --- +-- | Decode lenient URL-safe Base64, or encode in reverse. -- --- _Note:_ This is not a lawful 'Iso' in general. Please take care! +-- Ignores invalid characters and stops at the first padding character. +-- This is not a lawful 'Iso'' for arbitrary input. Construction produces +-- canonical padded output tagged as 'NonStandard'. -- --- >>> _Base64UrlLenient # "<>" --- "PDw_Pz4-" +-- >>> _Base64UrlLenient # "Sun" +-- "U3Vu" -- --- >>> "PDw_Pz4-" ^. _Base64UrlLenient --- "<>" +-- >>> view _Base64UrlLenient (assertBase64 "U3!Vu") +-- "Sun" -- -_Base64UrlLenient :: Iso' Text Text -_Base64UrlLenient = iso B64TU.decodeBase64Lenient B64TU.encodeBase64 +_Base64UrlLenient :: Iso' (Base64 'NonStandard Text) Text +_Base64UrlLenient = iso (B64TU.decodeBase64Lenient . extractBase64) + (coerceBase64 . B64TU.encodeBase64) +{-# INLINE _Base64UrlLenient #-} -- -------------------------------------------------------------------------- -- -- Patterns --- | Unidirectional pattern synonym for base64-encoded 'Text' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64 :: Text -> Text -pattern Base64 a <- (preview _Base64 -> Just a) where +pattern Base64 :: Text -> Base64 'StdPadded Text +pattern Base64 a <- (view _Base64 -> a) where Base64 a = _Base64 # a +{-# COMPLETE Base64 #-} --- | Unidirectional pattern synonym for base64url-encoded 'Text' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64Url :: Text -> Text -pattern Base64Url a <- (preview _Base64Url -> Just a) where +pattern Base64Url :: Text -> Base64 'UrlPadded Text +pattern Base64Url a <- (view _Base64Url -> a) where Base64Url a = _Base64Url # a +{-# COMPLETE Base64Url #-} --- | Unidirectional pattern synonym for unpadded base64url-encoded 'Text' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64UrlUnpadded :: Text -> Text -pattern Base64UrlUnpadded a <- (preview _Base64UrlUnpadded -> Just a) where +pattern Base64UrlUnpadded :: Text -> Base64 'UrlUnpadded Text +pattern Base64UrlUnpadded a <- (view _Base64UrlUnpadded -> a) where Base64UrlUnpadded a = _Base64UrlUnpadded # a +{-# COMPLETE Base64UrlUnpadded #-} --- | Bidirectional pattern synonym for leniently Base64-encoded 'Text' values +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64Lenient :: Text -> Text -pattern Base64Lenient a <- (view (from _Base64Lenient) -> a) where - Base64Lenient a = view _Base64Lenient a +pattern Base64Lenient :: Text -> Base64 'NonStandard Text +pattern Base64Lenient a <- (view _Base64Lenient -> a) where + Base64Lenient a = _Base64Lenient # a {-# COMPLETE Base64Lenient #-} --- | Bidirectional pattern synonym for leniently Base64-encoded 'Text' values +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64UrlLenient :: Text -> Text -pattern Base64UrlLenient a <- (view (from _Base64UrlLenient) -> a) where - Base64UrlLenient a = view _Base64UrlLenient a +pattern Base64UrlLenient :: Text -> Base64 'NonStandard Text +pattern Base64UrlLenient a <- (view _Base64UrlLenient -> a) where + Base64UrlLenient a = _Base64UrlLenient # a {-# COMPLETE Base64UrlLenient #-} diff --git a/src/Data/Text/Lazy/Encoding/Base64/Lens.hs b/src/Data/Text/Lazy/Encoding/Base64/Lens.hs --- a/src/Data/Text/Lazy/Encoding/Base64/Lens.hs +++ b/src/Data/Text/Lazy/Encoding/Base64/Lens.hs @@ -1,28 +1,32 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -#if MIN_VERSION_lens(5,0,0) -{-# LANGUAGE Safe #-} -#else {-# LANGUAGE Trustworthy #-} -#endif -- | -- Module : Data.Text.Lazy.Encoding.Base64.Lens --- Copyright : (c) 2019-2021 Emily Pillmore --- License : BSD-style +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style -- --- Maintainer : Emily Pillmore --- Stability : Experimental --- Portability : non-portable +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : non-portable -- --- This module contains 'Prism's and 'Iso''s Base64-encoding and --- decoding 'Text' values. +-- Optics and patterns for Base64-encoded 'Text' values. +-- The alphabet is recorded in the t'Base64' wrapper. Validate untrusted +-- standard-alphabet input with 'B64TL.parseBase64' before decoding, +-- or use '_Base64Untyped' to decode an ordinary string directly. +-- For access to the encoded payload itself, see "Data.Base64.Types.Lens". -- module Data.Text.Lazy.Encoding.Base64.Lens -( -- * Prisms +( -- * Encoding isomorphisms _Base64 , _Base64Url , _Base64UrlUnpadded + -- * Untyped decoding prisms +, _Base64Untyped +, _Base64UrlUntyped +, _Base64UrlUnpaddedUntyped + -- * Lenient decoding , _Base64Lenient , _Base64UrlLenient -- * Patterns @@ -33,131 +37,174 @@ , pattern Base64UrlLenient ) where -import Control.Lens - +import Control.Lens (Iso', Prism', iso, prism', view, (#)) +import Data.Base64.Types (Alphabet(..), Base64, coerceBase64, extractBase64) import Data.Text.Lazy (Text) import qualified Data.Text.Lazy.Encoding.Base64 as B64TL import qualified Data.Text.Lazy.Encoding.Base64.URL as B64TLU - -- $setup --- -- >>> import Control.Lens +-- >>> import Data.Base64.Types (assertBase64) -- >>> import Data.Text.Lazy.Encoding.Base64.Lens --- -- >>> :set -XOverloadedStrings --- >>> :set -XTypeApplications --- -------------------------------------------------------------------------- -- --- Optics - --- | A 'Prism' into the Base64 encoding of a 'Text' value. +-- | Decode standard, padded Base64, or encode in reverse. -- -- >>> _Base64 # "Sun" -- "U3Vu" -- --- >>> "U3Vu" ^? _Base64 --- Just "Sun" +-- >>> (_Base64 # "Sun") ^. _Base64 +-- "Sun" -- -_Base64 :: Prism' Text Text -_Base64 = prism' B64TL.encodeBase64 $ \s -> case B64TL.decodeBase64 s of - Left _ -> Nothing - Right a -> Just a +_Base64 :: Iso' (Base64 'StdPadded Text) Text +_Base64 = iso B64TL.decodeBase64 B64TL.encodeBase64 {-# INLINE _Base64 #-} --- | A 'Prism' into the Base64-url encoding of a 'Text' value. +-- | Decode padded URL-safe Base64, or encode in reverse. -- -- >>> _Base64Url # "Sun" -- "U3Vu" -- --- >>> "PDw_Pz8-Pg==" ^? _Base64Url --- Just "<>" +-- >>> (_Base64Url # "Sun") ^. _Base64Url +-- "Sun" -- -_Base64Url :: Prism' Text Text -_Base64Url = prism' B64TLU.encodeBase64 $ \s -> case B64TLU.decodeBase64 s of - Left _ -> Nothing - Right a -> Just a +_Base64Url :: Iso' (Base64 'UrlPadded Text) Text +_Base64Url = iso B64TLU.decodeBase64 B64TLU.encodeBase64 {-# INLINE _Base64Url #-} --- | A 'Prism' into the Base64-url encoding of a 'Text' value. --- --- Please note that unpadded variants should only be used --- when assumptions about the data can be made. In particular, if the length of --- the input is divisible by 3, then this is a safe function to call. +-- | Decode unpadded URL-safe Base64, or encode in reverse. -- --- >>> _Base64UrlUnpadded # "<>" --- "PDw_Pz4-" +-- >>> _Base64UrlUnpadded # "Sun" +-- "U3Vu" -- --- >>> "PDw_Pz4-" ^? _Base64UrlUnpadded --- Just "<>" +-- >>> (_Base64UrlUnpadded # "Sun") ^. _Base64UrlUnpadded +-- "Sun" -- -_Base64UrlUnpadded :: Prism' Text Text -_Base64UrlUnpadded = prism' B64TLU.encodeBase64Unpadded $ \s -> case B64TLU.decodeBase64Unpadded s of - Left _ -> Nothing - Right a -> Just a +_Base64UrlUnpadded :: Iso' (Base64 'UrlUnpadded Text) Text +_Base64UrlUnpadded = iso B64TLU.decodeBase64Unpadded B64TLU.encodeBase64Unpadded {-# INLINE _Base64UrlUnpadded #-} --- | An 'Iso'' into the Base64 encoding of a 'Text' value --- using lenient decoding. +-- | Decode a canonical, padded standard Base64 string, or encode in reverse. +-- Returns 'Nothing' on a Base64 decoding error. All three untyped prisms +-- retain the decoders' UTF-8 requirement: invalid decoded UTF-8 may throw. -- +-- >>> _Base64Untyped # "Sun" +-- "U3Vu" -- --- _Note:_ This is not a lawful 'Iso' in general. Please take care! +-- >>> "U3Vu" ^? _Base64Untyped +-- Just "Sun" -- +-- >>> "U3V=" ^? _Base64Untyped +-- Nothing +-- +_Base64Untyped :: Prism' Text Text +_Base64Untyped = prism' (extractBase64 . B64TL.encodeBase64) + (either (const Nothing) Just . B64TL.decodeBase64Untyped) +{-# INLINE _Base64Untyped #-} + +-- | Decode a padded or unpadded URL-safe Base64 string, or encode with padding +-- in reverse. Returns 'Nothing' on a Base64 decoding error. +-- +-- Matching unpadded input and reviewing the result normalizes its padding, +-- so this is not a lawful 'Prism'' over all accepted input. +-- +-- >>> _Base64UrlUntyped # "<>" +-- "PDw_Pz8-Pg==" +-- +-- >>> "PDw_Pz8-Pg" ^? _Base64UrlUntyped +-- Just "<>" +-- +_Base64UrlUntyped :: Prism' Text Text +_Base64UrlUntyped = prism' (extractBase64 . B64TLU.encodeBase64) + (either (const Nothing) Just . B64TLU.decodeBase64Untyped) +{-# INLINE _Base64UrlUntyped #-} + +-- | Decode a canonical, unpadded URL-safe Base64 string, or encode without +-- padding in reverse. Rejects padded input and other Base64 decoding errors. +-- +-- >>> _Base64UrlUnpaddedUntyped # "f" +-- "Zg" +-- +-- >>> "Zg" ^? _Base64UrlUnpaddedUntyped +-- Just "f" +-- +-- >>> "Zg==" ^? _Base64UrlUnpaddedUntyped +-- Nothing +-- +_Base64UrlUnpaddedUntyped :: Prism' Text Text +_Base64UrlUnpaddedUntyped = prism' (extractBase64 . B64TLU.encodeBase64Unpadded) + (either (const Nothing) Just . B64TLU.decodeBase64UnpaddedUntyped) +{-# INLINE _Base64UrlUnpaddedUntyped #-} + +-- | Decode lenient standard-alphabet Base64, or encode in reverse. +-- +-- Ignores invalid characters and stops at the first padding character. +-- This is not a lawful 'Iso'' for arbitrary input. Construction produces +-- canonical padded output tagged as 'NonStandard'. +-- -- >>> _Base64Lenient # "Sun" -- "U3Vu" -- --- >>> "U3Vu" ^. _Base64Lenient +-- >>> view _Base64Lenient (assertBase64 "U3!Vu") -- "Sun" -- -_Base64Lenient :: Iso' Text Text -_Base64Lenient = iso B64TL.decodeBase64Lenient B64TL.encodeBase64 +_Base64Lenient :: Iso' (Base64 'NonStandard Text) Text +_Base64Lenient = iso (B64TL.decodeBase64Lenient . extractBase64) + (coerceBase64 . B64TL.encodeBase64) +{-# INLINE _Base64Lenient #-} --- | An 'Iso'' into the Base64url encoding of a 'Text' value --- using lenient decoding. --- +-- | Decode lenient URL-safe Base64, or encode in reverse. -- --- _Note:_ This is not a lawful 'Iso' in general. Please take care! +-- Ignores invalid characters and stops at the first padding character. +-- This is not a lawful 'Iso'' for arbitrary input. Construction produces +-- canonical padded output tagged as 'NonStandard'. -- --- >>> _Base64UrlLenient # "<>" --- "PDw_Pz4-" +-- >>> _Base64UrlLenient # "Sun" +-- "U3Vu" -- --- >>> "PDw_Pz4-" ^. _Base64UrlLenient --- "<>" +-- >>> view _Base64UrlLenient (assertBase64 "U3!Vu") +-- "Sun" -- -_Base64UrlLenient :: Iso' Text Text -_Base64UrlLenient = iso B64TLU.decodeBase64Lenient B64TLU.encodeBase64 +_Base64UrlLenient :: Iso' (Base64 'NonStandard Text) Text +_Base64UrlLenient = iso (B64TLU.decodeBase64Lenient . extractBase64) + (coerceBase64 . B64TLU.encodeBase64) +{-# INLINE _Base64UrlLenient #-} -- -------------------------------------------------------------------------- -- -- Patterns --- | Unidirectional pattern synonym for base64-encoded 'Text' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64 :: Text -> Text -pattern Base64 a <- (preview _Base64 -> Just a) where +pattern Base64 :: Text -> Base64 'StdPadded Text +pattern Base64 a <- (view _Base64 -> a) where Base64 a = _Base64 # a +{-# COMPLETE Base64 #-} --- | Unidirectional pattern synonym for base64url-encoded 'Text' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64Url :: Text -> Text -pattern Base64Url a <- (preview _Base64Url -> Just a) where +pattern Base64Url :: Text -> Base64 'UrlPadded Text +pattern Base64Url a <- (view _Base64Url -> a) where Base64Url a = _Base64Url # a +{-# COMPLETE Base64Url #-} --- | Unidirectional pattern synonym for unpadded base64url-encoded 'Text' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64UrlUnpadded :: Text -> Text -pattern Base64UrlUnpadded a <- (preview _Base64UrlUnpadded -> Just a) where +pattern Base64UrlUnpadded :: Text -> Base64 'UrlUnpadded Text +pattern Base64UrlUnpadded a <- (view _Base64UrlUnpadded -> a) where Base64UrlUnpadded a = _Base64UrlUnpadded # a +{-# COMPLETE Base64UrlUnpadded #-} --- | Bidirectional pattern synonym for leniently Base64-encoded 'Text' values +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64Lenient :: Text -> Text -pattern Base64Lenient a <- (view (from _Base64Lenient) -> a) where - Base64Lenient a = view _Base64Lenient a +pattern Base64Lenient :: Text -> Base64 'NonStandard Text +pattern Base64Lenient a <- (view _Base64Lenient -> a) where + Base64Lenient a = _Base64Lenient # a {-# COMPLETE Base64Lenient #-} --- | Bidirectional pattern synonym for leniently Base64-encoded 'Text' values +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64UrlLenient :: Text -> Text -pattern Base64UrlLenient a <- (view (from _Base64UrlLenient) -> a) where - Base64UrlLenient a = view _Base64UrlLenient a +pattern Base64UrlLenient :: Text -> Base64 'NonStandard Text +pattern Base64UrlLenient a <- (view _Base64UrlLenient -> a) where + Base64UrlLenient a = _Base64UrlLenient # a {-# COMPLETE Base64UrlLenient #-} diff --git a/src/Data/Text/Short/Encoding/Base64/Lens.hs b/src/Data/Text/Short/Encoding/Base64/Lens.hs --- a/src/Data/Text/Short/Encoding/Base64/Lens.hs +++ b/src/Data/Text/Short/Encoding/Base64/Lens.hs @@ -1,28 +1,32 @@ -{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} {-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE ViewPatterns #-} -#if MIN_VERSION_lens(5,0,0) -{-# LANGUAGE Safe #-} -#else {-# LANGUAGE Trustworthy #-} -#endif -- | -- Module : Data.Text.Short.Encoding.Base64.Lens --- Copyright : (c) 2019-2021 Emily Pillmore --- License : BSD-style +-- Copyright : (c) 2019-2026 Emily Pillmore +-- License : BSD-style -- --- Maintainer : Emily Pillmore --- Stability : Experimental --- Portability : non-portable +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : non-portable -- --- This module contains 'Prism's and 'Iso''s Base64-encoding and --- decoding 'ShortText' values. +-- Optics and patterns for Base64-encoded 'ShortText' values. +-- The alphabet is recorded in the t'Base64' wrapper. Validate untrusted +-- standard-alphabet input with 'TS64.parseBase64' before decoding, +-- or use '_Base64Untyped' to decode an ordinary string directly. +-- For access to the encoded payload itself, see "Data.Base64.Types.Lens". -- module Data.Text.Short.Encoding.Base64.Lens -( -- * Prisms +( -- * Encoding isomorphisms _Base64 , _Base64Url , _Base64UrlUnpadded + -- * Untyped decoding prisms +, _Base64Untyped +, _Base64UrlUntyped +, _Base64UrlUnpaddedUntyped + -- * Lenient decoding , _Base64Lenient , _Base64UrlLenient -- * Patterns @@ -33,131 +37,174 @@ , pattern Base64UrlLenient ) where -import Control.Lens - +import Control.Lens (Iso', Prism', iso, prism', view, (#)) +import Data.Base64.Types (Alphabet(..), Base64, coerceBase64, extractBase64) import Data.Text.Short (ShortText) import qualified Data.Text.Short.Encoding.Base64 as TS64 import qualified Data.Text.Short.Encoding.Base64.URL as TS64U - -- $setup --- -- >>> import Control.Lens +-- >>> import Data.Base64.Types (assertBase64) -- >>> import Data.Text.Short.Encoding.Base64.Lens --- -- >>> :set -XOverloadedStrings --- >>> :set -XTypeApplications --- -------------------------------------------------------------------------- -- --- Optics - --- | A 'Prism' into the Base64 encoding of a 'ShortText' value. +-- | Decode standard, padded Base64, or encode in reverse. -- -- >>> _Base64 # "Sun" -- "U3Vu" -- --- >>> "U3Vu" ^? _Base64 --- Just "Sun" +-- >>> (_Base64 # "Sun") ^. _Base64 +-- "Sun" -- -_Base64 :: Prism' ShortText ShortText -_Base64 = prism' TS64.encodeBase64 $ \s -> case TS64.decodeBase64 s of - Left _ -> Nothing - Right a -> Just a +_Base64 :: Iso' (Base64 'StdPadded ShortText) ShortText +_Base64 = iso TS64.decodeBase64 TS64.encodeBase64 {-# INLINE _Base64 #-} --- | A 'Prism' into the Base64-url encoding of a 'ShortText' value. +-- | Decode padded URL-safe Base64, or encode in reverse. -- -- >>> _Base64Url # "Sun" -- "U3Vu" -- --- >>> "PDw_Pz8-Pg==" ^? _Base64Url --- Just "<>" +-- >>> (_Base64Url # "Sun") ^. _Base64Url +-- "Sun" -- -_Base64Url :: Prism' ShortText ShortText -_Base64Url = prism' TS64U.encodeBase64 $ \s -> case TS64U.decodeBase64 s of - Left _ -> Nothing - Right a -> Just a +_Base64Url :: Iso' (Base64 'UrlPadded ShortText) ShortText +_Base64Url = iso TS64U.decodeBase64 TS64U.encodeBase64 {-# INLINE _Base64Url #-} --- | A 'Prism' into the Base64-url encoding of a 'ShortText' value. --- --- Please note that unpadded variants should only be used --- when assumptions about the data can be made. In particular, if the length of --- the input is divisible by 3, then this is a safe function to call. +-- | Decode unpadded URL-safe Base64, or encode in reverse. -- --- >>> _Base64UrlUnpadded # "<>" --- "PDw_Pz4-" +-- >>> _Base64UrlUnpadded # "Sun" +-- "U3Vu" -- --- >>> "PDw_Pz4-" ^? _Base64UrlUnpadded --- Just "<>" +-- >>> (_Base64UrlUnpadded # "Sun") ^. _Base64UrlUnpadded +-- "Sun" -- -_Base64UrlUnpadded :: Prism' ShortText ShortText -_Base64UrlUnpadded = prism' TS64U.encodeBase64Unpadded $ \s -> case TS64U.decodeBase64Unpadded s of - Left _ -> Nothing - Right a -> Just a +_Base64UrlUnpadded :: Iso' (Base64 'UrlUnpadded ShortText) ShortText +_Base64UrlUnpadded = iso TS64U.decodeBase64Unpadded TS64U.encodeBase64Unpadded {-# INLINE _Base64UrlUnpadded #-} --- | An 'Iso'' into the Base64 encoding of a 'ShortText' value --- using lenient decoding. +-- | Decode a canonical, padded standard Base64 string, or encode in reverse. +-- Returns 'Nothing' on a Base64 decoding error. All three untyped prisms +-- retain the decoders' UTF-8 requirement: invalid decoded UTF-8 may throw. -- +-- >>> _Base64Untyped # "Sun" +-- "U3Vu" -- --- _Note:_ This is not a lawful 'Iso' in general. Please take care! +-- >>> "U3Vu" ^? _Base64Untyped +-- Just "Sun" -- +-- >>> "U3V=" ^? _Base64Untyped +-- Nothing +-- +_Base64Untyped :: Prism' ShortText ShortText +_Base64Untyped = prism' (extractBase64 . TS64.encodeBase64) + (either (const Nothing) Just . TS64.decodeBase64Untyped) +{-# INLINE _Base64Untyped #-} + +-- | Decode a padded or unpadded URL-safe Base64 string, or encode with padding +-- in reverse. Returns 'Nothing' on a Base64 decoding error. +-- +-- Matching unpadded input and reviewing the result normalizes its padding, +-- so this is not a lawful 'Prism'' over all accepted input. +-- +-- >>> _Base64UrlUntyped # "<>" +-- "PDw_Pz8-Pg==" +-- +-- >>> "PDw_Pz8-Pg" ^? _Base64UrlUntyped +-- Just "<>" +-- +_Base64UrlUntyped :: Prism' ShortText ShortText +_Base64UrlUntyped = prism' (extractBase64 . TS64U.encodeBase64) + (either (const Nothing) Just . TS64U.decodeBase64Untyped) +{-# INLINE _Base64UrlUntyped #-} + +-- | Decode a canonical, unpadded URL-safe Base64 string, or encode without +-- padding in reverse. Rejects padded input and other Base64 decoding errors. +-- +-- >>> _Base64UrlUnpaddedUntyped # "f" +-- "Zg" +-- +-- >>> "Zg" ^? _Base64UrlUnpaddedUntyped +-- Just "f" +-- +-- >>> "Zg==" ^? _Base64UrlUnpaddedUntyped +-- Nothing +-- +_Base64UrlUnpaddedUntyped :: Prism' ShortText ShortText +_Base64UrlUnpaddedUntyped = prism' (extractBase64 . TS64U.encodeBase64Unpadded) + (either (const Nothing) Just . TS64U.decodeBase64UnpaddedUntyped) +{-# INLINE _Base64UrlUnpaddedUntyped #-} + +-- | Decode lenient standard-alphabet Base64, or encode in reverse. +-- +-- Ignores invalid characters and stops at the first padding character. +-- This is not a lawful 'Iso'' for arbitrary input. Construction produces +-- canonical padded output tagged as 'NonStandard'. +-- -- >>> _Base64Lenient # "Sun" -- "U3Vu" -- --- >>> "U3Vu" ^. _Base64Lenient +-- >>> view _Base64Lenient (assertBase64 "U3!Vu") -- "Sun" -- -_Base64Lenient :: Iso' ShortText ShortText -_Base64Lenient = iso TS64.decodeBase64Lenient TS64.encodeBase64 +_Base64Lenient :: Iso' (Base64 'NonStandard ShortText) ShortText +_Base64Lenient = iso (TS64.decodeBase64Lenient . extractBase64) + (coerceBase64 . TS64.encodeBase64) +{-# INLINE _Base64Lenient #-} --- | An 'Iso'' into the Base64url encoding of a 'ShortText' value --- using lenient decoding. --- +-- | Decode lenient URL-safe Base64, or encode in reverse. -- --- _Note:_ This is not a lawful 'Iso' in general. Please take care! +-- Ignores invalid characters and stops at the first padding character. +-- This is not a lawful 'Iso'' for arbitrary input. Construction produces +-- canonical padded output tagged as 'NonStandard'. -- --- >>> _Base64UrlLenient # "<>" --- "PDw_Pz4-" +-- >>> _Base64UrlLenient # "Sun" +-- "U3Vu" -- --- >>> "PDw_Pz4-" ^. _Base64UrlLenient --- "<>" +-- >>> view _Base64UrlLenient (assertBase64 "U3!Vu") +-- "Sun" -- -_Base64UrlLenient :: Iso' ShortText ShortText -_Base64UrlLenient = iso TS64U.decodeBase64Lenient TS64U.encodeBase64 +_Base64UrlLenient :: Iso' (Base64 'NonStandard ShortText) ShortText +_Base64UrlLenient = iso (TS64U.decodeBase64Lenient . extractBase64) + (coerceBase64 . TS64U.encodeBase64) +{-# INLINE _Base64UrlLenient #-} -- -------------------------------------------------------------------------- -- -- Patterns --- | Unidirectional pattern synonym for base64-encoded 'ShortText' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64 :: ShortText -> ShortText -pattern Base64 a <- (preview _Base64 -> Just a) where +pattern Base64 :: ShortText -> Base64 'StdPadded ShortText +pattern Base64 a <- (view _Base64 -> a) where Base64 a = _Base64 # a +{-# COMPLETE Base64 #-} --- | Unidirectional pattern synonym for base64url-encoded 'ShortText' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64Url :: ShortText -> ShortText -pattern Base64Url a <- (preview _Base64Url -> Just a) where +pattern Base64Url :: ShortText -> Base64 'UrlPadded ShortText +pattern Base64Url a <- (view _Base64Url -> a) where Base64Url a = _Base64Url # a +{-# COMPLETE Base64Url #-} --- | Unidirectional pattern synonym for unpadded base64url-encoded 'ShortText' values. +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64UrlUnpadded :: ShortText -> ShortText -pattern Base64UrlUnpadded a <- (preview _Base64UrlUnpadded -> Just a) where +pattern Base64UrlUnpadded :: ShortText -> Base64 'UrlUnpadded ShortText +pattern Base64UrlUnpadded a <- (view _Base64UrlUnpadded -> a) where Base64UrlUnpadded a = _Base64UrlUnpadded # a +{-# COMPLETE Base64UrlUnpadded #-} --- | Bidirectional pattern synonym for leniently Base64-encoded 'ShortText' values +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64Lenient :: ShortText -> ShortText -pattern Base64Lenient a <- (view (from _Base64Lenient) -> a) where - Base64Lenient a = view _Base64Lenient a +pattern Base64Lenient :: ShortText -> Base64 'NonStandard ShortText +pattern Base64Lenient a <- (view _Base64Lenient -> a) where + Base64Lenient a = _Base64Lenient # a {-# COMPLETE Base64Lenient #-} --- | Bidirectional pattern synonym for leniently Base64-encoded 'ShortText' values +-- | Construct an encoded value or match its decoded payload. -- -pattern Base64UrlLenient :: ShortText -> ShortText -pattern Base64UrlLenient a <- (view (from _Base64UrlLenient) -> a) where - Base64UrlLenient a = view _Base64UrlLenient a +pattern Base64UrlLenient :: ShortText -> Base64 'NonStandard ShortText +pattern Base64UrlLenient a <- (view _Base64UrlLenient -> a) where + Base64UrlLenient a = _Base64UrlLenient # a {-# COMPLETE Base64UrlLenient #-} diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,320 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} + +module Main (main) where + +import Control.Lens +import Data.Base64.Types (Alphabet(..), Base64, assertBase64, extractBase64) +import qualified Data.Base64.Types.Lens as Wrapped +import Data.String (IsString) +import Data.Word (Word8) +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.ByteString.Short as SBS +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Short as TS +import qualified Data.ByteString.Base64 as Base64 +import qualified Data.ByteString.Base64.Lens as B +import qualified Data.ByteString.Lazy.Base64.Lens as L +import qualified Data.ByteString.Short.Base64.Lens as S +import qualified Data.Text.Encoding.Base64.Lens as U +import qualified Data.Text.Lazy.Encoding.Base64.Lens as V +import qualified Data.Text.Short.Encoding.Base64.Lens as W +import Data.Text.Encoding.Base64.Error (Base64Error(..)) +import Data.Text.Encoding.Base64.Error.Lens +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck + +-- Check both directions of each optic and its corresponding typed pattern. +data Codec k a = Codec + { optic :: Iso' (Base64 k a) a + , construct :: a -> Base64 k a + , deconstruct :: Base64 k a -> a + } + +data Optics a = Optics + { standard :: Codec 'StdPadded a + , url :: Codec 'UrlPadded a + , unpadded :: Codec 'UrlUnpadded a + , lenient :: Codec 'NonStandard a + , urlLenient :: Codec 'NonStandard a + , standardUntyped :: Prism' a a + , urlUntyped :: Prism' a a + , unpaddedUntyped :: Prism' a a + } + +vectors :: IsString a => [(a, a, a)] +vectors = + [ ("", "", ""), ("f", "Zg==", "Zg"), ("fo", "Zm8=", "Zm8") + , ("foo", "Zm9v", "Zm9v"), ("foob", "Zm9vYg==", "Zm9vYg") + , ("fooba", "Zm9vYmE=", "Zm9vYmE"), ("foobar", "Zm9vYmFy", "Zm9vYmFy") + ] + +main :: IO () +main = defaultMain $ testGroup "base64-lens" + [ suite "ByteString" byteStringOptics + , suite "Lazy ByteString" lazyByteStringOptics + , suite "ShortByteString" shortByteStringOptics + , suite "Text" textOptics + , suite "Lazy Text" lazyTextOptics + , suite "ShortText" shortTextOptics + , roundtrips "ByteString binary" byteStringOptics (BS.pack :: [Word8] -> BS.ByteString) + , roundtrips "Lazy ByteString binary, one byte per chunk" lazyByteStringOptics + (BL.fromChunks . map BS.singleton :: [Word8] -> BL.ByteString) + , roundtrips "ShortByteString binary" shortByteStringOptics (SBS.pack :: [Word8] -> SBS.ShortByteString) + , roundtrips "Text Unicode" textOptics T.pack + , roundtrips "Lazy Text Unicode, one character per chunk" lazyTextOptics (TL.fromChunks . map T.singleton) + , roundtrips "ShortText Unicode" shortTextOptics TS.pack + , testGroup "Untyped prisms" + [ untypedSuite "ByteString" byteStringOptics + , untypedSuite "Lazy ByteString" lazyByteStringOptics + , untypedSuite "ShortByteString" shortByteStringOptics + , untypedSuite "Text" textOptics + , untypedSuite "Lazy Text" lazyTextOptics + , untypedSuite "ShortText" shortTextOptics + ] + , chunkedPrismTests + , wrapperTests + , alphabetTests + , errorTests + , testCase "parse untrusted input before typed decoding" $ do + fmap (view B._Base64) (Base64.parseBase64 "U3Vu") @?= Right "Sun" + case Base64.parseBase64 "U3V=" of + Left _ -> pure () + Right _ -> assertFailure "Non-canonical input was accepted" + ] + +suite :: (Eq a, Show a, IsString a) => String -> Optics a -> TestTree +suite name o = testGroup name + [ testGroup "RFC 4648 vectors" + [ testCase (show raw) $ do + check (standard o) raw encoded + check (url o) raw encoded + check (unpadded o) raw bare + check (lenient o) raw encoded + check (urlLenient o) raw encoded + | (raw, encoded, bare) <- vectors + ] + , testCase "distinct alphabets and padding" $ do + check (standard o) "<>" "PDw/Pz8+Pg==" + check (url o) "<>" "PDw_Pz8-Pg==" + check (unpadded o) "<>" "PDw_Pz8-Pg" + check (lenient o) "<>" "PDw/Pz8+Pg==" + check (urlLenient o) "<>" "PDw_Pz8-Pg==" + , testCase "lenient decoding of non-standard wrappers" $ do + view (optic (lenient o)) (assertBase64 "U3!Vu") @?= "Sun" + deconstruct (lenient o) (assertBase64 "U3!Vu") @?= "Sun" + view (optic (urlLenient o)) (assertBase64 "PDw_!Pz8-Pg==") @?= "<>" + deconstruct (urlLenient o) (assertBase64 "PDw_!Pz8-Pg==") @?= "<>" + ] + where + check c raw encoded = do + review (optic c) raw @?= assertBase64 encoded + view (optic c) (assertBase64 encoded) @?= raw + construct c raw @?= assertBase64 encoded + deconstruct c (assertBase64 encoded) @?= raw + +untypedSuite :: (Eq a, Show a, IsString a) => String -> Optics a -> TestTree +untypedSuite name o = testGroup name + [ testGroup "RFC 4648 vectors" + [ testCase (show raw) $ do + review (standardUntyped o) raw @?= padded + preview (standardUntyped o) padded @?= Just raw + review (urlUntyped o) raw @?= padded + preview (urlUntyped o) padded @?= Just raw + preview (urlUntyped o) bare @?= Just raw + review (unpaddedUntyped o) raw @?= bare + preview (unpaddedUntyped o) bare @?= Just raw + | (raw, padded, bare) <- vectors + ] + , testCase "distinct alphabets" $ do + review (standardUntyped o) "<>" @?= "PDw/Pz8+Pg==" + review (urlUntyped o) "<>" @?= "PDw_Pz8-Pg==" + preview (standardUntyped o) "PDw/Pz8+Pg==" @?= Just "<>" + preview (urlUntyped o) "PDw_Pz8-Pg==" @?= Just "<>" + reject (standardUntyped o) "PDw_Pz8-Pg==" + reject (urlUntyped o) "PDw/Pz8+Pg==" + reject (unpaddedUntyped o) "PDw/Pz8+Pg" + , testGroup "malformed standard encoding" + [ testCase (show bad) $ reject (standardUntyped o) bad + | bad <- ["%", "Z", "Zg", "Zg=", "Zg===", "=m9v", "Zm=v", "Zh==", "Zm9=", "Zg==AAAA", "Zm9v\n"] + ] + , testGroup "malformed URL encoding" + [ testCase (show bad) $ reject (urlUntyped o) bad + | bad <- ["%", "Z", "Zg=", "Zg===", "Zh==", "Zh", "Zm9", "Zm9=", "Zg==AAAA", "Zm9v\n"] + ] + , testGroup "malformed unpadded URL encoding" + [ testCase (show bad) $ reject (unpaddedUntyped o) bad + | bad <- ["%", "Z", "Zg==", "Zm8=", "Zh", "Zm9", "Zg==AAAA", "Zm9v\n"] + ] + , testCase "URL matching accepts optional padding; review normalizes it" $ + fmap (review (urlUntyped o)) (preview (urlUntyped o) "Zg") @?= Just "Zg==" + ] + where + -- Failed matches must preserve the original encoded input. + reject p bad = matching p bad @?= Left bad + +chunkedPrismTests :: TestTree +chunkedPrismTests = testGroup "Untyped lazy input across chunk boundaries" + [ testCase "ByteString, valid input" $ do + preview L._Base64Untyped (bytes "Zg==") @?= Just "f" + preview L._Base64UrlUntyped (bytes "Zg==") @?= Just "f" + preview L._Base64UrlUnpaddedUntyped (bytes "Zg") @?= Just "f" + , testCase "ByteString, invalid suffix" $ do + matching L._Base64Untyped (bytes "Zg==AAAA") @?= Left (bytes "Zg==AAAA") + matching L._Base64UrlUntyped (bytes "Zg==AAAA") @?= Left (bytes "Zg==AAAA") + matching L._Base64UrlUnpaddedUntyped (bytes "Zm9v%") @?= Left (bytes "Zm9v%") + , testCase "Text, valid input" $ do + preview V._Base64Untyped (text "Zg==") @?= Just "f" + preview V._Base64UrlUntyped (text "Zg==") @?= Just "f" + preview V._Base64UrlUnpaddedUntyped (text "Zg") @?= Just "f" + , testCase "Text, invalid suffix" $ do + matching V._Base64Untyped (text "Zg==AAAA") @?= Left (text "Zg==AAAA") + matching V._Base64UrlUntyped (text "Zg==AAAA") @?= Left (text "Zg==AAAA") + matching V._Base64UrlUnpaddedUntyped (text "Zm9v%") @?= Left (text "Zm9v%") + ] + where + bytes = BL.fromChunks . map BS.singleton . BS.unpack + text = TL.fromChunks . map T.singleton + +roundtrips :: (Arbitrary b, Show b, Eq a, Show a) => String -> Optics a -> (b -> a) -> TestTree +roundtrips name o pack = testGroup name + [ laws "standard" (standard o) + , laws "padded URL" (url o) + , laws "unpadded URL" (unpadded o) + , laws "lenient, canonical input" (lenient o) + , laws "lenient URL, canonical input" (urlLenient o) + , prismLaws "untyped standard" (standardUntyped o) + , prismLaws "untyped URL, canonical padded input" (urlUntyped o) + , prismLaws "untyped unpadded URL" (unpaddedUntyped o) + ] + where + prismLaws codecName p = testGroup codecName + [ testProperty "preview . review" $ \input -> + let raw = pack input + in preview (clonePrism p) (review (clonePrism p) raw) === Just raw + , testProperty "review . preview, canonical input" $ \input -> + let encoded = review (clonePrism p) (pack input) + in fmap (review (clonePrism p)) (preview (clonePrism p) encoded) === Just encoded + ] + laws codecName c = testGroup codecName + [ testProperty "decode . encode" $ \input -> + let raw = pack input in view (optic c) (review (optic c) raw) === raw + , testProperty "encode . decode" $ \input -> + let encoded = review (optic c) (pack input) + in review (optic c) (view (optic c) encoded) === encoded + , testProperty "pattern match . construct" $ \input -> + let raw = pack input in deconstruct c (construct c raw) === raw + ] + +wrapperTests :: TestTree +wrapperTests = testGroup "Base64 wrapper" + [ testCase "payload access does not decode or validate" $ + view Wrapped._Base64 (assertBase64 "%" :: Base64 'StdPadded BS.ByteString) @?= "%" + , testCase "type-changing payload conversion preserves the alphabet" $ do + let original = Base64.encodeBase64' "Sun" + converted = over Wrapped._Base64 BL.fromStrict original :: Base64 'StdPadded BL.ByteString + view L._Base64 converted @?= "Sun" + extractBase64 converted @?= "U3Vu" + , testCase "Wrapped and Rewrapped instances" $ do + let original = Base64.encodeBase64' "Sun" + converted = over _Wrapped SBS.toShort original :: Base64 'StdPadded SBS.ShortByteString + view S._Base64 converted @?= "Sun" + view _Wrapped' original @?= "U3Vu" + (review _Wrapped' "U3Vu" :: Base64 'StdPadded BS.ByteString) @?= original + , testProperty "wrap . unwrap" $ \bytes -> + let value = assertBase64 (BS.pack bytes) :: Base64 'NonStandard BS.ByteString + in review Wrapped._Base64 (view Wrapped._Base64 value) === value + , testProperty "unwrap . wrap" $ \bytes -> + let raw = BS.pack bytes + in view Wrapped._Base64 (review Wrapped._Base64 raw :: Base64 'NonStandard BS.ByteString) === raw + ] + +alphabetTests :: TestTree +alphabetTests = testGroup "Alphabet prisms" + [ testGroup name + [ testCase "construct and match" $ preview (clonePrism p) (review (clonePrism p) ()) @?= Just () + , testCase "select exactly its constructor" $ + map (preview (clonePrism p)) [StdPadded, UrlPadded, UrlUnpadded, NonStandard] @?= + [if i == target then Just () else Nothing | i <- [0 .. 3 :: Int]] + ] + | (name, p, target) <- + [ ("StdPadded", Wrapped._StdPadded, 0) + , ("UrlPadded", Wrapped._UrlPadded, 1) + , ("UrlUnpadded", Wrapped._UrlUnpadded, 2) + , ("NonStandard", Wrapped._NonStandard, 3) + ] :: [(String, APrism' Alphabet (), Int)] + ] + +errorTests :: TestTree +errorTests = testGroup "Error prisms" + [ testCase "construct and select decode error" $ do + (_DecodeError # "invalid" :: Base64Error Int) @?= DecodeError "invalid" + preview _DecodeError (DecodeError "invalid" :: Base64Error Int) @?= Just "invalid" + preview _DecodeError (ConversionError 42 :: Base64Error Int) @?= Nothing + , testCase "construct and select conversion error" $ do + (_ConversionError # 42 :: Base64Error Int) @?= ConversionError 42 + preview _ConversionError (ConversionError 42 :: Base64Error Int) @?= Just 42 + preview _ConversionError (DecodeError "invalid" :: Base64Error Int) @?= Nothing + , testCase "change conversion error type" $ do + over _ConversionError show (ConversionError 42 :: Base64Error Int) @?= ConversionError "42" + over _ConversionError show (DecodeError "invalid" :: Base64Error Int) @?= DecodeError "invalid" + ] + +byteStringOptics :: Optics BS.ByteString +byteStringOptics = Optics + (Codec B._Base64 B.Base64 (\(B.Base64 a) -> a)) + (Codec B._Base64Url B.Base64Url (\(B.Base64Url a) -> a)) + (Codec B._Base64UrlUnpadded B.Base64UrlUnpadded (\(B.Base64UrlUnpadded a) -> a)) + (Codec B._Base64Lenient B.Base64Lenient (\(B.Base64Lenient a) -> a)) + (Codec B._Base64UrlLenient B.Base64UrlLenient (\(B.Base64UrlLenient a) -> a)) + B._Base64Untyped B._Base64UrlUntyped B._Base64UrlUnpaddedUntyped + +lazyByteStringOptics :: Optics BL.ByteString +lazyByteStringOptics = Optics + (Codec L._Base64 L.Base64 (\(L.Base64 a) -> a)) + (Codec L._Base64Url L.Base64Url (\(L.Base64Url a) -> a)) + (Codec L._Base64UrlUnpadded L.Base64UrlUnpadded (\(L.Base64UrlUnpadded a) -> a)) + (Codec L._Base64Lenient L.Base64Lenient (\(L.Base64Lenient a) -> a)) + (Codec L._Base64UrlLenient L.Base64UrlLenient (\(L.Base64UrlLenient a) -> a)) + L._Base64Untyped L._Base64UrlUntyped L._Base64UrlUnpaddedUntyped + +shortByteStringOptics :: Optics SBS.ShortByteString +shortByteStringOptics = Optics + (Codec S._Base64 S.Base64 (\(S.Base64 a) -> a)) + (Codec S._Base64Url S.Base64Url (\(S.Base64Url a) -> a)) + (Codec S._Base64UrlUnpadded S.Base64UrlUnpadded (\(S.Base64UrlUnpadded a) -> a)) + (Codec S._Base64Lenient S.Base64Lenient (\(S.Base64Lenient a) -> a)) + (Codec S._Base64UrlLenient S.Base64UrlLenient (\(S.Base64UrlLenient a) -> a)) + S._Base64Untyped S._Base64UrlUntyped S._Base64UrlUnpaddedUntyped + +textOptics :: Optics T.Text +textOptics = Optics + (Codec U._Base64 U.Base64 (\(U.Base64 a) -> a)) + (Codec U._Base64Url U.Base64Url (\(U.Base64Url a) -> a)) + (Codec U._Base64UrlUnpadded U.Base64UrlUnpadded (\(U.Base64UrlUnpadded a) -> a)) + (Codec U._Base64Lenient U.Base64Lenient (\(U.Base64Lenient a) -> a)) + (Codec U._Base64UrlLenient U.Base64UrlLenient (\(U.Base64UrlLenient a) -> a)) + U._Base64Untyped U._Base64UrlUntyped U._Base64UrlUnpaddedUntyped + +lazyTextOptics :: Optics TL.Text +lazyTextOptics = Optics + (Codec V._Base64 V.Base64 (\(V.Base64 a) -> a)) + (Codec V._Base64Url V.Base64Url (\(V.Base64Url a) -> a)) + (Codec V._Base64UrlUnpadded V.Base64UrlUnpadded (\(V.Base64UrlUnpadded a) -> a)) + (Codec V._Base64Lenient V.Base64Lenient (\(V.Base64Lenient a) -> a)) + (Codec V._Base64UrlLenient V.Base64UrlLenient (\(V.Base64UrlLenient a) -> a)) + V._Base64Untyped V._Base64UrlUntyped V._Base64UrlUnpaddedUntyped + +shortTextOptics :: Optics TS.ShortText +shortTextOptics = Optics + (Codec W._Base64 W.Base64 (\(W.Base64 a) -> a)) + (Codec W._Base64Url W.Base64Url (\(W.Base64Url a) -> a)) + (Codec W._Base64UrlUnpadded W.Base64UrlUnpadded (\(W.Base64UrlUnpadded a) -> a)) + (Codec W._Base64Lenient W.Base64Lenient (\(W.Base64Lenient a) -> a)) + (Codec W._Base64UrlLenient W.Base64UrlLenient (\(W.Base64UrlLenient a) -> a)) + W._Base64Untyped W._Base64UrlUntyped W._Base64UrlUnpaddedUntyped