diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,16 @@ # Revision history for base64 +## 0.4.2 + +* Added support for `Data.ByteString.Short`, `Data.ByteString.Lazy`, `Data.Text.Short`, and `Data.Text.Lazy`. ([#17](https://github.com/emilypi/base64/pull/17)) +* Optimize decode algorithm (now beats `base64-bytestring` in every category!) - ([#13](https://github.com/emilypi/base64/pull/13)) +* Use `decodeLatin1` when decoding to text, so that functions are total - ([#13](https://github.com/emilypi/base64/pull/13)) +* Added `decodeWith*` variants and a `Base64Error` type to handle decoding errors when decoding base64 values - ([#13](https://github.com/emilypi/base64/pull/13)) +* Improved error reporting: all offsets are now precisely accurate. - ([#13](https://github.com/emilypi/base64/pull/13)) +* Validations added to head, rejecting invalid corner cases (such as bytestrings of length `l == 1 mod 4`, which are never correct) - ([#16](https://github.com/emilypi/base64/pull/16)) +* Added `decodeBase64Padded` for symmetry - ([#13](https://github.com/emilypi/base64/pull/13)) + + ## 0.4.1 -- 2020-02-04 * Optimize loops for 32-bit and 64-bit architectures diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -3,27 +3,26 @@ [![Build Status](https://travis-ci.com/emilypi/base64.svg?branch=master)](https://travis-ci.com/emilypi/base64) [![Hackage](https://img.shields.io/hackage/v/base64.svg)](https://hackage.haskell.org/package/base64) -Padded and unpadded base64 and base64url encoding and decoding for `Text` and `ByteString` values. +Base64 encoding and decodings. For the companion optics and pattern synonyms, see [base64-lens](https://hackage.haskell.org/package/base64-lens). - ### Summary -What does this library provide? Here is the summary: - -- Good performance compared to existing Base64 libraries (see [PERFORMANCE.md](benchmarks/PERFORMANCE.md)) -- Support for padded and unpadded Base64 and Base64url -- Support for `Text` encodings and decodings -- Optics for handling more complex structures with Base64 representations via the `base64-lens` package -- Checks for both valid Base64 and correct Base64 and Base64url encodings +The following types are supported for both std, padded url-safe, and unpadded url-safe alphabets: -There are no dependencies aside from those bundled with GHC: +- `Data.ByteString` +- `Data.ByteString.Lazy` +- `Data.ByteString.Short` +- `Data.Text` +- `Data.Text.Lazy` +- `Data.Text.Short` -![base64 dependencies](https://i.imgur.com/OWW7c5s.png) +Additionally this library has -### Motivation +- Better performance than `base64-bytestring` for encode and decode. +- Optics for handling more complex structures with Base64 representations via the `base64-lens` package +- Checks for both validity and correctness of Base64 and Base64url encodings -Haskell has two main libraries for Base64: `memory`, and `base64-bytestring`. +There are no dependencies aside from those bundled with GHC, and the ultra-minimal `ghc-byteorder`. -Of these, `memory` is geared towards integration with other memory primitives in the library, without much of an eye towards performance, while `base64-bytestring` is built to exclusively address `ByteString` encoding and decoding, and is very performant. Many great strides have been made in the realm of Base64 performance and vectorization just in the past 5 years, which this library attempts to capture. Additionally, we attempt to fix perceived shortcomings with both APIs in the support of unpadded Base64 and Base64-url support (which `memory` provides, but not `base64-bytestring`), as well as supporting `Text` values (neither libraries provide). diff --git a/base64.cabal b/base64.cabal --- a/base64.cabal +++ b/base64.cabal @@ -1,84 +1,110 @@ -cabal-version: 2.0 - -name: base64 -version: 0.4.1 -synopsis: Fast RFC 4648-compliant Base64 encoding +cabal-version: 2.0 +name: base64 +version: 0.4.2 +synopsis: Fast RFC 4648-compliant Base64 encoding description: RFC 4648-compliant padded and unpadded base64 and base64url encoding and decoding. This library provides performant encoding and decoding primitives, as well as support for textual values. -homepage: https://github.com/emilypi/base64 -bug-reports: https://github.com/emilypi/base64/issues -license: BSD3 -license-file: LICENSE -author: Emily Pillmore -maintainer: emilypi@cohomolo.gy -copyright: (c) 2019 Emily Pillmore -category: Data -build-type: Simple + +homepage: https://github.com/emilypi/base64 +bug-reports: https://github.com/emilypi/base64/issues +license: BSD3 +license-file: LICENSE +author: Emily Pillmore +maintainer: emilypi@cohomolo.gy +copyright: (c) 2019-2020 Emily Pillmore +category: Data +build-type: Simple extra-source-files: CHANGELOG.md README.md -tested-with: GHC ==8.8.1 || ==8.6.5 || ==8.6.3 || ==8.4.4 || ==8.4.3 || ==8.2.2 +tested-with: + GHC ==8.2.2 + || ==8.4.3 + || ==8.4.4 + || ==8.6.3 + || ==8.6.5 + || ==8.8.1 + || ==8.10.1 source-repository head type: git location: https://github.com/emilypi/base64.git library - exposed-modules: Data.ByteString.Base64 - , Data.ByteString.Base64.URL - - , Data.Text.Encoding.Base64 - , Data.Text.Encoding.Base64.URL - - other-modules: Data.ByteString.Base64.Internal - Data.ByteString.Base64.Internal.Tail - Data.ByteString.Base64.Internal.Utils - Data.ByteString.Base64.Internal.W32.Loop - Data.ByteString.Base64.Internal.W64.Loop - Data.ByteString.Base64.Internal.W8.Loop + exposed-modules: + Data.ByteString.Base64 + Data.ByteString.Base64.URL + Data.ByteString.Lazy.Base64 + Data.ByteString.Lazy.Base64.URL + Data.ByteString.Short.Base64 + Data.ByteString.Short.Base64.URL + Data.Text.Encoding.Base64 + Data.Text.Encoding.Base64.Error + Data.Text.Encoding.Base64.URL + Data.Text.Lazy.Encoding.Base64 + Data.Text.Lazy.Encoding.Base64.URL + Data.Text.Short.Encoding.Base64 + Data.Text.Short.Encoding.Base64.URL - build-depends: base >=4.10 && <5 - , bytestring ^>=0.10 - , text ^>=1.2 + other-modules: + Data.ByteString.Base64.Internal + Data.ByteString.Base64.Internal.Head + Data.ByteString.Base64.Internal.Tables + Data.ByteString.Base64.Internal.Tail + Data.ByteString.Base64.Internal.Utils + Data.ByteString.Base64.Internal.W16.Loop + Data.ByteString.Base64.Internal.W32.Loop + Data.ByteString.Base64.Internal.W64.Loop - hs-source-dirs: src - default-language: Haskell2010 - ghc-options: -Wall + build-depends: + base >=4.10 && <5 + , bytestring ^>=0.10 + , ghc-byteorder ^>=4.11.0.0 + , text ^>=1.2 + , text-short ^>=0.1 + hs-source-dirs: src + default-language: Haskell2010 + ghc-options: -Wall test-suite tasty - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: test - main-is: Base64Tests.hs - build-depends: base >=4.10 && <5 - , base64 - , base64-bytestring - , bytestring - , random-bytestring - , tasty - , tasty-hunit - , text + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + other-modules: Internal + main-is: Main.hs + build-depends: + base >=4.10 && <5 + , base64 + , base64-bytestring + , bytestring + , QuickCheck + , quickcheck-instances + , random-bytestring + , tasty + , tasty-hunit + , tasty-quickcheck + , text + , text-short - ghc-options: -Wall -threaded -with-rtsopts=-N + ghc-options: -Wall -threaded -with-rtsopts=-N benchmark bench - default-language: Haskell2010 - type: exitcode-stdio-1.0 - hs-source-dirs: benchmarks - main-is: Base64Bench.hs - build-depends: base >=4.10 && <5 - , base64 - , base64-bytestring - , bytestring - , deepseq - , gauge - , memory - , random-bytestring - , text + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: benchmarks + main-is: Base64Bench.hs + build-depends: + base >=4.10 && <5 + , base64 + , base64-bytestring + , bytestring + , criterion + , deepseq + , memory + , random-bytestring + , text - ghc-options: - -Wall - -rtsopts + ghc-options: -Wall -rtsopts diff --git a/benchmarks/Base64Bench.hs b/benchmarks/Base64Bench.hs --- a/benchmarks/Base64Bench.hs +++ b/benchmarks/Base64Bench.hs @@ -17,7 +17,8 @@ ) where -import Gauge.Main +import Criterion +import Criterion.Main import "memory" Data.ByteArray.Encoding as Mem import Data.ByteString @@ -31,36 +32,78 @@ defaultMain [ env bs $ \ ~(bs25,bs100,bs1k,bs10k,bs100k,bs1mm) -> bgroup "encode" - [ bgroup "memory" - [ bench "25" $ whnf ctob bs25 - , bench "100" $ whnf ctob bs100 - , bench "1000" $ whnf ctob bs1k - , bench "10000" $ whnf ctob bs10k - , bench "100000" $ whnf ctob bs100k + [ bgroup "25" + [ bench "memory" $ whnf ctob bs25 + , bench "base64-bytestring" $ whnf Bos.encode bs25 + , bench "base64" $ whnf B64.encodeBase64' bs25 ] - , - bgroup "base64-bytestring" - [ bench "25" $ whnf Bos.encode bs25 - , bench "100" $ whnf Bos.encode bs100 - , bench "1000" $ whnf Bos.encode bs1k - , bench "10000" $ whnf Bos.encode bs10k - , bench "100000" $ whnf Bos.encode bs100k - , bench "1000000" $ whnf Bos.encode bs1mm + , bgroup "100" + [ bench "memory" $ whnf ctob bs100 + , bench "base64-bytestring" $ whnf Bos.encode bs100 + , bench "base64" $ whnf B64.encodeBase64' bs100 ] - , bgroup "base64" - [ bench "25" $ whnf B64.encodeBase64' bs25 - , bench "100" $ whnf B64.encodeBase64' bs100 - , bench "1000" $ whnf B64.encodeBase64' bs1k - , bench "10000" $ whnf B64.encodeBase64' bs10k - , bench "100000" $ whnf B64.encodeBase64' bs100k - , bench "1000000" $ whnf B64.encodeBase64' bs1mm + , bgroup "1k" + [ bench "memory" $ whnf ctob bs1k + , bench "base64-bytestring" $ whnf Bos.encode bs1k + , bench "base64" $ whnf B64.encodeBase64' bs1k ] + , bgroup "10k" + [ bench "memory" $ whnf ctob bs10k + , bench "base64-bytestring" $ whnf Bos.encode bs10k + , bench "base64" $ whnf B64.encodeBase64' bs10k + ] + , bgroup "100k" + [ bench "memory" $ whnf ctob bs100k + , bench "base64-bytestring" $ whnf Bos.encode bs100k + , bench "base64" $ whnf B64.encodeBase64' bs100k + ] + , bgroup "1mm" + [ bench "memory" $ whnf ctob bs1mm + , bench "base64-bytestring" $ whnf Bos.encode bs1mm + , bench "base64" $ whnf B64.encodeBase64' bs1mm + ] ] + , env bs' $ \ ~(bs25,bs100,bs1k,bs10k,bs100k,bs1mm) -> + bgroup "decode" + [ bgroup "25" + [ bench "memory" $ whnf btoc bs25 + , bench "base64-bytestring" $ whnf Bos.decode bs25 + , bench "base64" $ whnf B64.decodeBase64 bs25 + ] + , bgroup "100" + [ bench "memory" $ whnf btoc bs100 + , bench "base64-bytestring" $ whnf Bos.decode bs100 + , bench "base64" $ whnf B64.decodeBase64 bs100 + ] + , bgroup "1k" + [ bench "memory" $ whnf btoc bs1k + , bench "base64-bytestring" $ whnf Bos.decode bs1k + , bench "base64" $ whnf B64.decodeBase64 bs1k + ] + , bgroup "10k" + [ bench "memory" $ whnf btoc bs10k + , bench "base64-bytestring" $ whnf Bos.decode bs10k + , bench "base64" $ whnf B64.decodeBase64 bs10k + ] + , bgroup "100k" + [ bench "memory" $ whnf btoc bs100k + , bench "base64-bytestring" $ whnf Bos.decode bs100k + , bench "base64" $ whnf B64.decodeBase64 bs100k + ] + , bgroup "1mm" + [ bench "memory" $ whnf btoc bs1mm + , bench "base64-bytestring" $ whnf Bos.decode bs1mm + , bench "base64" $ whnf B64.decodeBase64 bs1mm + ] + ] ] where ctob :: ByteString -> ByteString ctob = Mem.convertToBase Mem.Base64 + btoc :: ByteString -> Either String ByteString + btoc = Mem.convertFromBase Mem.Base64 + bs = do a <- random 25 b <- random 100 @@ -68,4 +111,13 @@ d <- random 10000 e <- random 100000 f <- random 1000000 + return (a,b,c,d,e,f) + + bs' = do + a <- B64.encodeBase64' <$> random 25 + b <- B64.encodeBase64' <$> random 100 + c <- B64.encodeBase64' <$> random 1000 + d <- B64.encodeBase64' <$> random 10000 + e <- B64.encodeBase64' <$> random 100000 + f <- B64.encodeBase64' <$> random 1000000 return (a,b,c,d,e,f) diff --git a/src/Data/ByteString/Base64.hs b/src/Data/ByteString/Base64.hs --- a/src/Data/ByteString/Base64.hs +++ b/src/Data/ByteString/Base64.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} -- | -- Module : Data.ByteString.Base64 --- Copyright : (c) 2019 Emily Pillmore +-- Copyright : (c) 2019-2020 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -23,13 +23,17 @@ ) where -import Data.ByteString (ByteString) +import Data.ByteString.Internal (ByteString(..)) 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 +import System.IO.Unsafe + -- | Encode a 'ByteString' value as Base64 'Text' with padding. -- -- See: @@ -50,12 +54,14 @@ -- -- See: -- --- /Note:/ This function is not RFC compliant, and __will__ add padding to an --- unpadded Base64-encoded value for decoding. For strictly RFC-compliant decoding, --- use 'decodeBase64Unpadded'. --- decodeBase64 :: ByteString -> Either Text ByteString -decodeBase64 = decodeBase64_ NoPad decodeB64Table +decodeBase64 bs@(PS _ _ !l) + | r == 1 = Left "Base64-encoded bytestring has invalid size" + | r /= 0 = Left "Base64-encoded bytestring requires padding" + | otherwise = unsafeDupablePerformIO $ decodeBase64_ dlen decodeB64Table bs + where + (!q, !r) = divMod l 4 + !dlen = q * 3 {-# INLINE decodeBase64 #-} -- | Leniently decode an unpadded Base64-encoded 'ByteString' value. This function 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 @@ -6,7 +6,7 @@ {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.ByteString.Base64.Internal --- Copyright : (c) 2019 Emily Pillmore +-- Copyright : (c) 2019-2020 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -17,114 +17,25 @@ -- processes and tables. -- module Data.ByteString.Base64.Internal -( -- * Base64 encoding - encodeBase64_ -, encodeBase64Nopad_ - - -- * Base64 decoding -, Padding(..) -, decodeBase64_ -, decodeBase64Lenient_ - - -- * Decoding Tables - -- ** Standard -, decodeB64Table - -- ** Base64-url -, decodeB64UrlTable - - -- * Encoding Tables - -- ** Standard -, base64Table - - -- ** Base64-url -, base64UrlTable - - -- * Validating Base64 -, validateBase64 +( validateBase64 +, validateLastPad ) where -#include "MachDeps.h" - -import Data.Bits import qualified Data.ByteString as BS -import Data.ByteString.Base64.Internal.Tail -import Data.ByteString.Base64.Internal.Utils -#if WORD_SIZE_IN_BITS == 32 -import Data.ByteString.Base64.Internal.W32.Loop -#elif WORD_SIZE_IN_BITS == 64 -import Data.ByteString.Base64.Internal.W64.Loop -#else -import Data.ByteString.Base64.Internal.W8.Loop -#endif - import Data.ByteString.Internal import Data.Text (Text) -import qualified Data.Text as T + import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable -import GHC.Exts -import GHC.ForeignPtr -import GHC.Word - import System.IO.Unsafe --- -------------------------------------------------------------------------- -- --- Internal data - --- | Only the lookup table need be a foreignptr, --- and then, only so that we can automate some touches to keep it alive --- -data EncodingTable = EncodingTable - {-# UNPACK #-} !(Ptr Word8) - {-# UNPACK #-} !(ForeignPtr Word16) - --- | A type isomorphic to 'Bool' marking support for padding out bytestrings (@Pad), --- or not (@Nopad@). --- -data Padding - = Pad - -- ^ Do we pad out the bytestring? - | NoPad - -- ^ Do we not pad out the bytestring? - deriving Eq - --- | Pack an 'Addr#' into an encoding table of 'Word16's --- -packTable :: Addr# -> EncodingTable -packTable alphabet = etable - where - ix (I# n) = W8# (indexWord8OffAddr# alphabet n) - - !etable = - let bs = concat - [ [ ix i, ix j ] - | !i <- [0..63] - , !j <- [0..63] - ] - in EncodingTable (Ptr alphabet) (writeNPlainForeignPtrBytes 8192 bs) - --- | Base64url encoding table --- -base64UrlTable :: EncodingTable -base64UrlTable = packTable "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"# -{-# NOINLINE base64UrlTable #-} - --- | Base64 std encoding table --- -base64Table :: EncodingTable -base64Table = packTable "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"# -{-# NOINLINE base64Table #-} - --- -------------------------------------------------------------------------- -- --- Validating Base64 - -- | Given a bytestring, check to see that it conforms to a given alphabet -- validateBase64 :: ByteString -> ByteString -> Bool -validateBase64 !alphabet (PS fp off l) = +validateBase64 !alphabet (PS !fp !off !l) = accursedUnutterablePerformIO $ withForeignPtr fp $ \p -> go (plusPtr p off) (plusPtr p (l + off)) where @@ -142,249 +53,31 @@ if f w then go (plusPtr p 1) end else return False {-# INLINE validateBase64 #-} --- -------------------------------------------------------------------------- -- --- Encode Base64 - -encodeBase64_ :: EncodingTable -> ByteString -> ByteString -encodeBase64_ (EncodingTable !aptr !efp) (PS !sfp !soff !slen) = - unsafeCreate dlen $ \dptr -> - withForeignPtr sfp $ \sptr -> - withForeignPtr efp $ \eptr -> do - let !end = plusPtr sptr (soff + slen) - innerLoop - eptr - (plusPtr sptr soff) - (castPtr dptr) - end - (loopTail aptr end) - where - !dlen = 4 * ((slen + 2) `div` 3) - -encodeBase64Nopad_ :: EncodingTable -> ByteString -> ByteString -encodeBase64Nopad_ (EncodingTable !aptr !efp) (PS !sfp !soff !slen) = - unsafeDupablePerformIO $ do - dfp <- mallocPlainForeignPtrBytes dlen - withForeignPtr dfp $ \dptr -> - withForeignPtr efp $ \etable -> - withForeignPtr sfp $ \sptr -> do - let !end = plusPtr sptr (soff + slen) - innerLoopNopad - etable - (plusPtr sptr soff) - (castPtr dptr) - end - (loopTailNoPad dfp aptr end) - where - !dlen = 4 * ((slen + 2) `div` 3) - - --- -------------------------------------------------------------------------- -- --- Decoding Base64 - --- | Non-URLsafe b64 decoding table (naive) +-- | This function checks that the last char of a bytestring is '=' +-- and, if true, fails with a message or completes some io action. -- -decodeB64Table :: ForeignPtr Word8 -decodeB64Table = writeNPlainForeignPtrBytes @Word8 256 - [ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3e,0xff,0xff,0xff,0x3f - , 0x34,0x35,0x36,0x37,0x38,0x39,0x3a,0x3b,0x3c,0x3d,0xff,0xff,0xff,0x63,0xff,0xff - , 0xff,0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a,0x0b,0x0c,0x0d,0x0e - , 0x0f,0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0xff,0xff,0xff,0xff,0xff - , 0xff,0x1a,0x1b,0x1c,0x1d,0x1e,0x1f,0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28 - , 0x29,0x2a,0x2b,0x2c,0x2d,0x2e,0x2f,0x30,0x31,0x32,0x33,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - ] -{-# NOINLINE decodeB64Table #-} - --- | URLsafe b64 decoding table (naive) +-- This is necessary to check when decoding permissively (i.e. filling in padding chars). +-- Consider the following 4 cases of a string of length l: -- -decodeB64UrlTable :: ForeignPtr Word8 -decodeB64UrlTable = writeNPlainForeignPtrBytes @Word8 256 - [ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3e,0xff,0xff - , 0x34,0x35,0x36,0x37,0x38,0x39,0x3a,0x3b,0x3c,0x3d,0xff,0xff,0xff,0x63,0xff,0xff - , 0xff,0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a,0x0b,0x0c,0x0d,0x0e - , 0x0f,0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0xff,0xff,0xff,0xff,0x3f - , 0xff,0x1a,0x1b,0x1c,0x1d,0x1e,0x1f,0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28 - , 0x29,0x2a,0x2b,0x2c,0x2d,0x2e,0x2f,0x30,0x31,0x32,0x33,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff - ] -{-# NOINLINE decodeB64UrlTable #-} - --- | The main decode function. Takes a padding flag, a decoding table, and --- the input value, producing either an error string on the left, or a --- decoded value. +-- l = 0 mod 4: No pad chars are added, since the input is assumed to be good. +-- l = 1 mod 4: Never an admissible length in base64 +-- l = 2 mod 4: 2 padding chars are added. If padding chars are present in the string, they will fail as to decode as final quanta +-- l = 3 mod 4: 1 padding char is added. In this case a string is of the form + . If adding the +-- pad char "completes"" the string so that it is `l = 0 mod 4`, then this may possibly be forming corrupting data. +-- This case is degenerate and should be disallowed. -- --- Note: If 'Padding' ~ Pad, then we pad out the input to a multiple of 4. --- If 'Padding' ~ NoPad, then we do not, and fail if the input is not --- a multiple of 4 in length. +-- Hence, permissive decodes should only fill in padding chars when it makes sense to add them. That is, +-- if an input is degenerate, it should never succeed when we add padding chars. We need the following invariant to hold: -- -decodeBase64_ :: Padding -> ForeignPtr Word8 -> ByteString -> Either Text ByteString -decodeBase64_ pad !dtfp bs@(PS _ _ !slen) = case pad of - Pad -> go (BS.append bs (BS.replicate r 0x3d)) - NoPad - | r /= 0 -> Left "invalid padding" - | otherwise -> go bs - where - (!q, !r) = divMod slen 4 - !dlen = q * 3 - - go (PS !sfp !soff !slen') = unsafeDupablePerformIO $ - withForeignPtr dtfp $ \dtable -> - withForeignPtr sfp $ \sptr -> do - dfp <- mallocPlainForeignPtrBytes dlen - withForeignPtr dfp $ \dptr -> - decodeBase64_' - dtable - (plusPtr sptr soff) - dptr - (plusPtr sptr (soff + slen')) - dfp -{-# INLINE decodeBase64_ #-} - -decodeBase64_' - :: Ptr Word8 - -- ^ decode lookup table - -> Ptr Word8 - -- ^ src pointer - -> Ptr Word8 - -- ^ dst pointer - -> Ptr Word8 - -- ^ end of src ptr - -> ForeignPtr Word8 - -- ^ dst foreign ptr (for consing bs) +-- @ +-- B64U.decodeUnpadded <|> B64U.decodePadded ~ B64U.decodePadded +-- @ +-- +validateLastPad + :: ByteString -> IO (Either Text ByteString) -decodeBase64_' !dtable !sptr !dptr !end !dfp = go dptr sptr 0 - where - err = return . Left . T.pack - {-# INLINE err #-} - - finalize !n = return (Right (PS dfp 0 n)) - {-# INLINE finalize #-} - - look :: Ptr Word8 -> IO Word32 - look p = do - !i <- peekByteOff @Word8 p 0 - !v <- peekByteOff @Word8 dtable (fromIntegral i) - return (fromIntegral v) - - go !dst !src !n - | src >= end = return (Right (PS dfp 0 n)) - | otherwise = do - a <- look src - b <- look (src `plusPtr` 1) - c <- look (src `plusPtr` 2) - d <- look (src `plusPtr` 3) - - if a == 0x63 || b == 0x63 - then err - $ "invalid padding near offset: " - ++ show (minusPtr src sptr) - else - if a .|. b .|. c .|. d == 0xff - then err - $ "invalid base64 encoding near offset: " - ++ show (minusPtr src sptr) - else do - let !w = (shiftL a 18) .|. (shiftL b 12) .|. (shiftL c 6) .|. d - - poke @Word8 dst (fromIntegral (shiftR w 16)) - if c == 0x63 - then finalize (n + 1) - else do - poke @Word8 (plusPtr dst 1) (fromIntegral (shiftR w 8)) - if d == 0x63 - then finalize (n + 2) - else do - poke @Word8 (plusPtr dst 2) (fromIntegral w) - go (plusPtr dst 3) (plusPtr src 4) (n + 3) -{-# INLINE decodeBase64_' #-} - - -decodeBase64Lenient_ :: ForeignPtr Word8 -> ByteString -> ByteString -decodeBase64Lenient_ !dtfp (PS !sfp !soff !slen) = unsafeDupablePerformIO $ - withForeignPtr dtfp $ \dtable -> - withForeignPtr sfp $ \sptr -> do - dfp <- mallocPlainForeignPtrBytes dlen - withForeignPtr dfp $ \dptr -> - decodeBase64Lenient_' - dtable - (plusPtr sptr soff) - dptr - (plusPtr sptr (soff + slen)) - dfp - where - !dlen = ((slen + 3) `div` 4) * 3 -{-# INLINE decodeBase64Lenient_ #-} - - -decodeBase64Lenient_' - :: Ptr Word8 - -- ^ decode lookup table - -> Ptr Word8 - -- ^ src pointer - -> Ptr Word8 - -- ^ dst pointer - -> Ptr Word8 - -- ^ end of src ptr - -> ForeignPtr Word8 - -- ^ dst foreign ptr (for consing bs) - -> IO ByteString -decodeBase64Lenient_' !dtable !sptr !dptr !end !dfp = go dptr sptr 0 - where - finalize !n = return (PS dfp 0 n) - {-# INLINE finalize #-} - - look skip !p_ f = k p_ - where - k !p - | p >= end = f (plusPtr end (-1)) (0x63 :: Word32) - | otherwise = do - !i <- peekByteOff @Word8 p 0 - !v <- peekByteOff @Word8 dtable (fromIntegral i) - - if - | v == 0xff -> k (plusPtr p 1) - | v == 0x63, skip -> k (plusPtr p 1) - | otherwise -> f (plusPtr p 1) (fromIntegral v) - - go !dst !src !n - | src >= end = finalize n - | otherwise = - look True src $ \ap a -> - look True ap $ \bp b -> - if - | a == 0x63 -> finalize n - | b == 0x63 -> finalize n - | otherwise -> - look False bp $ \cp c -> - look False cp $ \dp d -> do - let !w = (shiftL a 18) .|. (shiftL b 12) .|. (shiftL c 6) .|. d - - poke @Word8 dst (fromIntegral (shiftR w 16)) - if c == 0x63 - then finalize (n + 1) - else do - poke @Word8 (plusPtr dst 1) (fromIntegral (w `shiftR` 8)) - if d == 0x63 - then finalize (n + 2) - else do - poke @Word8 (plusPtr dst 2) (fromIntegral w) - go (plusPtr dst 3) dp (n + 3) -{-# INLINE decodeBase64Lenient_' #-} + -> Either Text ByteString +validateLastPad !bs io + | BS.last bs == 0x3d = Left "Base64-encoded bytestring has invalid padding" + | otherwise = unsafeDupablePerformIO io +{-# INLINE validateLastPad #-} diff --git a/src/Data/ByteString/Base64/Internal/Head.hs b/src/Data/ByteString/Base64/Internal/Head.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base64/Internal/Head.hs @@ -0,0 +1,124 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.ByteString.Base64.Internal.Head +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- Shared internal utils +-- +module Data.ByteString.Base64.Internal.Head +( encodeBase64_ +, encodeBase64Nopad_ +, decodeBase64_ +, decodeBase64Lenient_ +) where + +#include "MachDeps.h" + +import Data.ByteString.Base64.Internal.Tail +import Data.ByteString.Base64.Internal.Utils +#if WORD_SIZE_IN_BITS == 32 +import Data.ByteString.Base64.Internal.W32.Loop +#elif WORD_SIZE_IN_BITS >= 64 +import Data.ByteString.Base64.Internal.W64.Loop +#else +import Data.ByteString.Base64.Internal.W16.Loop +#endif +import Data.ByteString.Internal +import Data.Text (Text) + +import Foreign.ForeignPtr +import Foreign.Ptr + +import GHC.ForeignPtr +import GHC.Word + +import System.IO.Unsafe + + +encodeBase64_ :: EncodingTable -> ByteString -> ByteString +encodeBase64_ (EncodingTable !aptr !efp) (PS !sfp !soff !slen) = + unsafeDupablePerformIO $ do + dfp <- mallocPlainForeignPtrBytes dlen + withForeignPtr dfp $ \dptr -> + withForeignPtr sfp $ \sptr -> + withForeignPtr efp $ \eptr -> do + let !end = plusPtr sptr (soff + slen) + innerLoop + eptr + (castPtr (plusPtr sptr soff)) + (castPtr dptr) + end + (loopTail dfp aptr dptr (castPtr end)) + where + !dlen = 4 * ((slen + 2) `div` 3) +{-# inline encodeBase64_ #-} + +encodeBase64Nopad_ :: EncodingTable -> ByteString -> ByteString +encodeBase64Nopad_ (EncodingTable !aptr !efp) (PS !sfp !soff !slen) = + unsafeDupablePerformIO $ do + dfp <- mallocPlainForeignPtrBytes dlen + withForeignPtr dfp $ \dptr -> + withForeignPtr efp $ \etable -> + withForeignPtr sfp $ \sptr -> do + let !end = plusPtr sptr (soff + slen) + innerLoop + etable + (castPtr (plusPtr sptr soff)) + (castPtr dptr) + end + (loopTailNoPad dfp aptr dptr (castPtr end)) + where + !dlen = 4 * ((slen + 2) `div` 3) +{-# inline encodeBase64Nopad_ #-} + +-- | The main decode function. Takes a padding flag, a decoding table, and +-- the input value, producing either an error string on the left, or a +-- decoded value. +-- +-- Note: If 'Padding' ~ 'Don\'tCare', then we pad out the input to a multiple of 4. +-- If 'Padding' ~ 'Padded', then we do not, and fail if the input is not +-- a multiple of 4 in length. If 'Padding' ~ 'Unpadded', then we validate +-- correctness of length and the absence of padding and then treat as a std +-- padded string. +-- +decodeBase64_ + :: Int + -> ForeignPtr Word8 + -> ByteString + -> IO (Either Text ByteString) +decodeBase64_ _ _ (PS _ _ 0) = return $ Right mempty +decodeBase64_ !dlen !dtfp (PS !sfp !soff !slen) = + withForeignPtr dtfp $ \dtable -> + withForeignPtr sfp $ \sptr -> do + dfp <- mallocPlainForeignPtrBytes dlen + withForeignPtr dfp $ \dptr -> + decodeLoop + dtable + (plusPtr sptr soff) + dptr + (plusPtr sptr (soff + slen)) + (decodeTail dfp dtable sptr dptr) +{-# inline decodeBase64_ #-} + +decodeBase64Lenient_ :: ForeignPtr Word8 -> ByteString -> ByteString +decodeBase64Lenient_ !dtfp (PS !sfp !soff !slen) = unsafeDupablePerformIO $ + withForeignPtr dtfp $ \dtable -> + withForeignPtr sfp $ \sptr -> do + dfp <- mallocPlainForeignPtrBytes dlen + withForeignPtr dfp $ \dptr -> + lenientLoop + dtable + (plusPtr sptr soff) + dptr + (plusPtr sptr (soff + slen)) + dfp + where + !dlen = ((slen + 3) `div` 4) * 3 diff --git a/src/Data/ByteString/Base64/Internal/Tables.hs b/src/Data/ByteString/Base64/Internal/Tables.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base64/Internal/Tables.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MagicHash #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.ByteString.Base64.Internal.Tables +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- Shared internal tables +-- +module Data.ByteString.Base64.Internal.Tables +( base64Table +, base64UrlTable +, decodeB64Table +, decodeB64UrlTable +) where + + +import Data.ByteString.Base64.Internal.Utils + +import Foreign.ForeignPtr + +import GHC.Word + +-- | Base64url encoding table +-- +base64UrlTable :: EncodingTable +base64UrlTable = packTable "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"# +{-# NOINLINE base64UrlTable #-} + +-- | Base64 std encoding table +-- +base64Table :: EncodingTable +base64Table = packTable "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"# +{-# NOINLINE base64Table #-} + +-- | Non-URLsafe b64 decoding table (naive) +-- +decodeB64Table :: ForeignPtr Word8 +decodeB64Table = writeNPlainForeignPtrBytes @Word8 256 + [ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3e,0xff,0xff,0xff,0x3f + , 0x34,0x35,0x36,0x37,0x38,0x39,0x3a,0x3b,0x3c,0x3d,0xff,0xff,0xff,0x63,0xff,0xff + , 0xff,0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a,0x0b,0x0c,0x0d,0x0e + , 0x0f,0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0xff,0xff,0xff,0xff,0xff + , 0xff,0x1a,0x1b,0x1c,0x1d,0x1e,0x1f,0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28 + , 0x29,0x2a,0x2b,0x2c,0x2d,0x2e,0x2f,0x30,0x31,0x32,0x33,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + ] +{-# NOINLINE decodeB64Table #-} + +-- | URLsafe b64 decoding table (naive) +-- +decodeB64UrlTable :: ForeignPtr Word8 +decodeB64UrlTable = writeNPlainForeignPtrBytes @Word8 256 + [ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0x3e,0xff,0xff + , 0x34,0x35,0x36,0x37,0x38,0x39,0x3a,0x3b,0x3c,0x3d,0xff,0xff,0xff,0x63,0xff,0xff + , 0xff,0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a,0x0b,0x0c,0x0d,0x0e + , 0x0f,0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0xff,0xff,0xff,0xff,0x3f + , 0xff,0x1a,0x1b,0x1c,0x1d,0x1e,0x1f,0x20,0x21,0x22,0x23,0x24,0x25,0x26,0x27,0x28 + , 0x29,0x2a,0x2b,0x2c,0x2d,0x2e,0x2f,0x30,0x31,0x32,0x33,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff + ] +{-# NOINLINE decodeB64UrlTable #-} diff --git a/src/Data/ByteString/Base64/Internal/Tail.hs b/src/Data/ByteString/Base64/Internal/Tail.hs --- a/src/Data/ByteString/Base64/Internal/Tail.hs +++ b/src/Data/ByteString/Base64/Internal/Tail.hs @@ -1,8 +1,9 @@ {-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.ByteString.Base64.Internal.W32.Loop --- Copyright : (c) 2019 Emily Pillmore +-- Copyright : (c) 2019-2020 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -14,11 +15,14 @@ module Data.ByteString.Base64.Internal.Tail ( loopTail , loopTailNoPad +, decodeTail ) where import Data.Bits import Data.ByteString.Internal import Data.ByteString.Base64.Internal.Utils +import Data.Text (Text) +import qualified Data.Text as T import Foreign.ForeignPtr import Foreign.Ptr @@ -30,33 +34,44 @@ -- | Finalize an encoded bytestring by filling in the remaining -- bytes and any padding -- -loopTail :: Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 -> IO () -loopTail (Ptr !alpha) !end !src !dst - | src == end = return () - | otherwise = do - !k <- peekByteOff src 0 +loopTail + :: ForeignPtr Word8 + -> Ptr Word8 + -> Ptr Word8 + -> Ptr Word8 + -> Ptr Word8 + -> Ptr Word8 + -> IO ByteString +loopTail !dfp (Ptr !alpha) !dptr !end !src !dst + | src == end = return (PS dfp 0 (minusPtr dst dptr)) + | plusPtr src 1 == end = do + !x <- peek @Word8 src - let !a = shiftR (k .&. 0xfc) 2 - !b = shiftL (k .&. 0x03) 4 + let !a = shiftR (x .&. 0xfc) 2 + !b = shiftL (x .&. 0x03) 4 - pokeByteOff dst 0 (aix a alpha) + poke @Word8 dst (aix a alpha) + poke @Word8 (plusPtr dst 1) (aix b alpha) + poke @Word8 (plusPtr dst 2) 0x3d + poke @Word8 (plusPtr dst 3) 0x3d + return (PS dfp 0 (4 + minusPtr dst dptr)) - if plusPtr src 2 /= end - then do - pokeByteOff dst 1 (aix b alpha) - pokeByteOff @Word8 dst 2 0x3d - pokeByteOff @Word8 dst 3 0x3d - else do - !k' <- peekByteOff src 1 + | otherwise = do + !x <- peek @Word8 src + !y <- peek @Word8 (plusPtr src 1) - let !b' = shiftR (k' .&. 0xf0) 4 .|. b - !c' = shiftL (k' .&. 0x0f) 2 + let !a = shiftR (x .&. 0xfc) 2 + !b = shiftL (x .&. 0x03) 4 - pokeByteOff dst 1 (aix b' alpha) - pokeByteOff dst 2 (aix c' alpha) - pokeByteOff @Word8 dst 3 0x3d -{-# INLINE loopTail #-} + let !c = shiftR (y .&. 0xf0) 4 .|. b + !d = shiftL (y .&. 0x0f) 2 + poke @Word8 dst (aix a alpha) + poke @Word8 (plusPtr dst 1) (aix c alpha) + poke @Word8 (plusPtr dst 2) (aix d alpha) + poke @Word8 (plusPtr dst 3) 0x3d + return (PS dfp 0 (4 + minusPtr dst dptr)) +{-# inline loopTail #-} -- | Finalize a bytestring by filling out the remaining bits -- without padding. @@ -67,29 +82,94 @@ -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 - -> Int + -> Ptr Word8 -> IO ByteString -loopTailNoPad !dfp (Ptr !alpha) !end !src !dst !n - | src == end = return (PS dfp 0 n) +loopTailNoPad !dfp (Ptr !alpha) !dptr !end !src !dst + | src == end = return (PS dfp 0 (minusPtr dst dptr)) + | plusPtr src 1 == end = do + !x <- peek @Word8 src + + let !a = shiftR (x .&. 0xfc) 2 + !b = shiftL (x .&. 0x03) 4 + + poke @Word8 dst (aix a alpha) + poke @Word8 (plusPtr dst 1) (aix b alpha) + return (PS dfp 0 (2 + (minusPtr dst dptr))) | otherwise = do - !k <- peekByteOff src 0 + !x <- peek @Word8 src + !y <- peek @Word8 (plusPtr src 1) - let !a = shiftR (k .&. 0xfc) 2 - !b = shiftL (k .&. 0x03) 4 + let !a = shiftR (x .&. 0xfc) 2 + !b = shiftL (x .&. 0x03) 4 - pokeByteOff dst 0 (aix a alpha) + let !c = shiftR (y .&. 0xf0) 4 .|. b + !d = shiftL (y .&. 0x0f) 2 - if plusPtr src 2 /= end - then do - pokeByteOff dst 1 (aix b alpha) - return (PS dfp 0 (n + 2)) - else do - !k' <- peekByteOff src 1 + poke @Word8 dst (aix a alpha) + poke @Word8 (plusPtr dst 1) (aix c alpha) + poke @Word8 (plusPtr dst 2) (aix d alpha) + return (PS dfp 0 (3 + (minusPtr dst dptr))) +{-# inline loopTailNoPad #-} - let !b' = shiftR (k' .&. 0xf0) 4 .|. b - !c' = shiftL (k' .&. 0x0f) 2 +decodeTail + :: ForeignPtr Word8 + -- ^ dst bytestring foreign ptr + -> Ptr Word8 + -- ^ decode table + -> Ptr Word8 + -- ^ original decode static pointer + -> Ptr Word8 + -- ^ original source pointer (for offset calculation) + -> Ptr Word8 + -- ^ dst ptr + -> Ptr Word8 + -- ^ src ptr + -> IO (Either Text ByteString) +decodeTail !dfp !dtable !sptr !dptr !dst !src = do + !w <- peek @Word8 src + !x <- peek @Word8 (plusPtr src 1) + !y <- peek @Word8 (plusPtr src 2) + !z <- peek @Word8 (plusPtr src 3) - pokeByteOff dst 1 (aix b' alpha) - pokeByteOff dst 2 (aix c' alpha) - return (PS dfp 0 (n + 3)) -{-# INLINE loopTailNoPad #-} + !a <- w32 <$> peekByteOff @Word8 dtable (fromIntegral w) + !b <- w32 <$> peekByteOff @Word8 dtable (fromIntegral x) + !c <- w32 <$> peekByteOff @Word8 dtable (fromIntegral y) + !d <- w32 <$> peekByteOff @Word8 dtable (fromIntegral z) + + if + | a == 0xff -> err src + | b == 0xff -> err (plusPtr src 1) + | c == 0xff -> err (plusPtr src 2) + | d == 0xff -> err (plusPtr src 3) + | a == 0x63 -> padErr src + | b == 0x63 -> padErr (plusPtr src 1) + | c == 0x63, d /= 0x63 -> padErr (plusPtr src 3) + | otherwise -> do + + let !ww = (unsafeShiftL a 18) + .|. (unsafeShiftL b 12) + .|. (unsafeShiftL c 6) + .|. d + + if + | c == 0x63, d == 0x63 -> do + poke @Word8 dst (fromIntegral (unsafeShiftR ww 16)) + return $ Right (PS dfp 0 (1 + (minusPtr dst dptr))) + | d == 0x63 -> do + poke @Word8 dst (fromIntegral (unsafeShiftR ww 16)) + poke @Word8 (plusPtr dst 1) (fromIntegral (unsafeShiftR ww 8)) + return $ Right (PS dfp 0 (2 + (minusPtr dst dptr))) + | otherwise -> do + poke @Word8 dst (fromIntegral (unsafeShiftR ww 16)) + poke @Word8 (plusPtr dst 1) (fromIntegral (unsafeShiftR ww 8)) + poke @Word8 (plusPtr dst 2) (fromIntegral ww) + return $ Right (PS dfp 0 (3 + (minusPtr dst dptr))) + where + err p = return . Left . T.pack + $ "invalid character at offset: " + ++ show (p `minusPtr` sptr) + + padErr p = return . Left . T.pack + $ "invalid padding at offset: " + ++ show (p `minusPtr` sptr) +{-# inline decodeTail #-} diff --git a/src/Data/ByteString/Base64/Internal/Utils.hs b/src/Data/ByteString/Base64/Internal/Utils.hs --- a/src/Data/ByteString/Base64/Internal/Utils.hs +++ b/src/Data/ByteString/Base64/Internal/Utils.hs @@ -2,7 +2,7 @@ {-# LANGUAGE MagicHash #-} -- | -- Module : Data.ByteString.Base64.Internal --- Copyright : (c) 2019 Emily Pillmore +-- Copyright : (c) 2019-2020 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -12,22 +12,42 @@ -- Shared internal utils -- module Data.ByteString.Base64.Internal.Utils -( aix +( EncodingTable(..) +, aix +, packTable +, peekWord32BE +, peekWord64BE +, reChunkN , w32 +, w64 +, w32_16 +, w64_16 , writeNPlainForeignPtrBytes ) where -import System.IO.Unsafe +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS + import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable +import GHC.ByteOrder import GHC.Exts import GHC.ForeignPtr import GHC.Word +import System.IO.Unsafe + +-- | Only the lookup table need be a foreignptr, +-- and then, only so that we can automate some touches to keep it alive +-- +data EncodingTable = EncodingTable + {-# UNPACK #-} !(Ptr Word8) + {-# UNPACK #-} !(ForeignPtr Word16) + -- | Read 'Word8' index off alphabet addr -- aix :: Word8 -> Addr# -> Word8 @@ -40,6 +60,22 @@ w32 = fromIntegral {-# INLINE w32 #-} +-- | Convert 'Word8''s into 'Word32''s +-- +w64 :: Word8 -> Word64 +w64 = fromIntegral +{-# INLINE w64 #-} + +-- | Convert 'Word8''s into 'Word32''s +-- +w64_16 :: Word16 -> Word64 +w64_16 = fromIntegral +{-# INLINE w64_16 #-} + +w32_16 :: Word16 -> Word32 +w32_16 = fromIntegral +{-# INLINE w32_16 #-} + -- | Allocate and fill @n@ bytes with some data -- writeNPlainForeignPtrBytes @@ -56,3 +92,53 @@ where go !_ [] = return () go !p (x:xs) = poke p x >> go (plusPtr p 1) xs + +-- | Pack an 'Addr#' into an encoding table of 'Word16's +-- +packTable :: Addr# -> EncodingTable +packTable alphabet = etable + where + ix (I# n) = W8# (indexWord8OffAddr# alphabet n) + + !etable = + let bs = concat + [ [ ix i, ix j ] + | !i <- [0..63] + , !j <- [0..63] + ] + in EncodingTable (Ptr alphabet) (writeNPlainForeignPtrBytes 8192 bs) + +-- | Rechunk a list of bytestrings in multiples of 4 +-- +reChunkN :: Int -> [ByteString] -> [ByteString] +reChunkN n = go + where + go [] = [] + go (b:bs) = case divMod (BS.length b) n of + (_, 0) -> b : go bs + (d, _) -> case BS.splitAt (d * n) b of + ~(h, t) -> h : accum t bs + + accum acc [] = [acc] + accum acc (c:cs) = + case BS.splitAt (n - BS.length acc) c of + ~(h, t) -> + let acc' = BS.append acc h + in if BS.length acc' == n + then + let cs' = if BS.null t then cs else t : cs + in acc' : go cs' + else accum acc' cs +{-# INLINE reChunkN #-} + +peekWord32BE :: Ptr Word32 -> IO Word32 +peekWord32BE p = case targetByteOrder of + LittleEndian -> byteSwap32 <$> peek p + BigEndian -> peek p +{-# inline peekWord32BE #-} + +peekWord64BE :: Ptr Word64 -> IO Word64 +peekWord64BE p = case targetByteOrder of + LittleEndian -> byteSwap64 <$> peek p + BigEndian -> peek p +{-# inline peekWord64BE #-} diff --git a/src/Data/ByteString/Base64/Internal/W16/Loop.hs b/src/Data/ByteString/Base64/Internal/W16/Loop.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base64/Internal/W16/Loop.hs @@ -0,0 +1,176 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Data.ByteString.Base64.Internal.W16.Loop +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- 'Word8' fallback loop +-- +module Data.ByteString.Base64.Internal.W16.Loop +( innerLoop +, decodeLoop +, lenientLoop +) where + + +import Data.Bits +import Data.ByteString.Internal +import Data.ByteString.Base64.Internal.Utils +import Data.Text (Text) +import qualified Data.Text as T + +import Foreign.ForeignPtr +import Foreign.Ptr +import Foreign.Storable + +import GHC.Word + + +-- | Encoding inner loop. Packs 3 bytes from src pointer into +-- the first 6 bytes of 4 'Word8''s (using the encoding table, +-- as 2 'Word12''s ), writing these to the dst pointer. +-- +innerLoop + :: Ptr Word16 + -> Ptr Word8 + -> Ptr Word16 + -> Ptr Word8 + -> (Ptr Word8 -> Ptr Word8 -> IO ByteString) + -> IO ByteString +innerLoop !etable !sptr !dptr !end finish = go sptr dptr + where + go !src !dst + | plusPtr src 2 >= end = finish src (castPtr dst) + | otherwise = do + + !i <- w32 <$> peek src + !j <- w32 <$> peek (plusPtr src 1) + !k <- w32 <$> peek (plusPtr src 2) + + let !w = (shiftL i 16) .|. (shiftL j 8) .|. k + + !x <- peekElemOff etable (fromIntegral (shiftR w 12)) + !y <- peekElemOff etable (fromIntegral (w .&. 0xfff)) + + poke dst x + poke (plusPtr dst 2) y + + go (plusPtr src 3) (plusPtr dst 4) +{-# inline innerLoop #-} + +decodeLoop + :: Ptr Word8 + -- ^ decode lookup table + -> Ptr Word8 + -- ^ src pointer + -> Ptr Word8 + -- ^ dst pointer + -> Ptr Word8 + -- ^ end of src ptr + -> (Ptr Word8 -> Ptr Word8 -> IO (Either Text ByteString)) + -> IO (Either Text ByteString) +decodeLoop !dtable !sptr !dptr !end finish = go dptr sptr + where + err p = return . Left . T.pack + $ "invalid character at offset: " + ++ show (p `minusPtr` sptr) + + padErr p = return . Left . T.pack + $ "invalid padding at offset: " + ++ show (p `minusPtr` sptr) + + look :: Ptr Word8 -> IO Word32 + look !p = do + !i <- peekByteOff @Word8 p 0 + !v <- peekByteOff @Word8 dtable (fromIntegral i) + return (fromIntegral v) + + go !dst !src + | plusPtr src 4 >= end = finish dst src + | otherwise = do + !a <- look src + !b <- look (src `plusPtr` 1) + !c <- look (src `plusPtr` 2) + !d <- look (src `plusPtr` 3) + + if + | a == 0x63 -> padErr src + | b == 0x63 -> padErr (plusPtr src 1) + | c == 0x63 -> padErr (plusPtr src 2) + | d == 0x63 -> padErr (plusPtr src 3) + | a == 0xff -> err src + | b == 0xff -> err (plusPtr src 1) + | c == 0xff -> err (plusPtr src 2) + | d == 0xff -> err (plusPtr src 3) + | otherwise -> do + + let !w = (unsafeShiftL a 18) + .|. (unsafeShiftL b 12) + .|. (unsafeShiftL c 6) + .|. d + + poke @Word8 dst (fromIntegral (unsafeShiftR w 16)) + poke @Word8 (plusPtr dst 1) (fromIntegral (unsafeShiftR w 8)) + poke @Word8 (plusPtr dst 2) (fromIntegral w) + go (plusPtr dst 3) (plusPtr src 4) +{-# inline decodeLoop #-} + +lenientLoop + :: Ptr Word8 + -- ^ decode lookup table + -> Ptr Word8 + -- ^ src pointer + -> Ptr Word8 + -- ^ dst pointer + -> Ptr Word8 + -- ^ end of src ptr + -> ForeignPtr Word8 + -- ^ dst foreign ptr (for consing bs) + -> IO ByteString +lenientLoop !dtable !sptr !dptr !end !dfp = go dptr sptr 0 + where + finalize !n = return $ PS dfp 0 n + {-# INLINE finalize #-} + + look !skip !p_ f = k p_ + where + k !p + | p >= end = f (plusPtr end (-1)) (0x63 :: Word32) + | otherwise = do + !i <- peekByteOff @Word8 p 0 + !v <- peekByteOff @Word8 dtable (fromIntegral i) + + if + | v == 0xff -> k (plusPtr p 1) + | v == 0x63, skip -> k (plusPtr p 1) + | otherwise -> f (plusPtr p 1) (fromIntegral v) + + go !dst !src !n + | src >= end = finalize n + | otherwise = + look True src $ \ap a -> + look True ap $ \bp b -> + if + | a == 0x63 -> finalize n + | b == 0x63 -> finalize n + | otherwise -> + look False bp $ \cp c -> + look False cp $ \dp d -> do + let !w = (shiftL a 18) .|. (shiftL b 12) .|. (shiftL c 6) .|. d + + poke @Word8 dst (fromIntegral (shiftR w 16)) + if c == 0x63 + then finalize (n + 1) + else do + poke @Word8 (plusPtr dst 1) (fromIntegral (w `shiftR` 8)) + if d == 0x63 + then finalize (n + 2) + else do + poke @Word8 (plusPtr dst 2) (fromIntegral w) + go (plusPtr dst 3) dp (n + 3) diff --git a/src/Data/ByteString/Base64/Internal/W32/Loop.hs b/src/Data/ByteString/Base64/Internal/W32/Loop.hs --- a/src/Data/ByteString/Base64/Internal/W32/Loop.hs +++ b/src/Data/ByteString/Base64/Internal/W32/Loop.hs @@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.ByteString.Base64.Internal.W32.Loop @@ -14,13 +14,18 @@ -- module Data.ByteString.Base64.Internal.W32.Loop ( innerLoop -, innerLoopNopad +, decodeLoop +, lenientLoop ) where import Data.Bits import Data.ByteString.Internal +import Data.ByteString.Base64.Internal.Utils +import qualified Data.ByteString.Base64.Internal.W16.Loop as W16 +import Data.Text (Text) +import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable @@ -33,61 +38,55 @@ -- innerLoop :: Ptr Word16 - -> Ptr Word8 - -> Ptr Word16 - -> Ptr Word8 - -> (Ptr Word8 -> Ptr Word8 -> IO ()) - -> IO () -innerLoop !etable !sptr !dptr !end finish = go (castPtr sptr) dptr + -> Ptr Word32 + -> Ptr Word32 + -> Ptr Word32 + -> (Ptr Word8 -> Ptr Word8 -> IO ByteString) + -> IO ByteString +innerLoop !etable !sptr !dptr !end finish = go sptr dptr where go !src !dst - | plusPtr src 2 >= end = finish (castPtr src) (castPtr dst) + | plusPtr src 3 >= end = + W16.innerLoop etable (castPtr src) (castPtr dst) (castPtr end) finish | otherwise = do -#ifdef WORDS_BIGENDIAN - !w <- peek @Word32 src -#else - !w <- byteSwap32 <$> peek @Word32 src -#endif - let !a = (unsafeShiftR w 20) .&. 0xfff - !b = (unsafeShiftR w 8) .&. 0xfff + !w <- peekWord32BE src - !x <- peekElemOff etable (fromIntegral a) - !y <- peekElemOff etable (fromIntegral b) + let !a = unsafeShiftR w 20 + !b = unsafeShiftR w 8 - poke dst x - poke (plusPtr dst 2) y + !x <- w32_16 <$> peekElemOff etable (fromIntegral a) + !y <- w32_16 <$> peekElemOff etable (fromIntegral b) + let !z = x .|. (unsafeShiftL y 16) + poke dst (fromIntegral z) + go (plusPtr src 3) (plusPtr dst 4) + {-# INLINE go #-} {-# INLINE innerLoop #-} --- | Unpadded encoding loop, finalized as a bytestring using the --- resultant length count. --- -innerLoopNopad - :: Ptr Word16 +decodeLoop + :: Ptr Word8 -> Ptr Word8 - -> Ptr Word16 + -- ^ src pointer -> Ptr Word8 - -> (Ptr Word8 -> Ptr Word8 -> Int -> IO ByteString) - -> IO ByteString -innerLoopNopad !etable !sptr !dptr !end finish = go (castPtr sptr) dptr 0 - where - go !src !dst !n - | plusPtr src 2 >= end = finish (castPtr src) (castPtr dst) n - | otherwise = do -#ifdef WORDS_BIGENDIAN - w <- peek @Word32 src -#else - w <- byteSwap32 <$> peek @Word32 src -#endif - let !a = (unsafeShiftR w 20) .&. 0xfff - !b = (unsafeShiftR w 8) .&. 0xfff - - !x <- peekElemOff etable (fromIntegral a) - !y <- peekElemOff etable (fromIntegral b) - - poke dst x - poke (plusPtr dst 2) y + -- ^ dst pointer + -> Ptr Word8 + -- ^ end of src ptr + -> (Ptr Word8 -> Ptr Word8 -> IO (Either Text ByteString)) + -> IO (Either Text ByteString) +decodeLoop = W16.decodeLoop +{-# INLINE decodeLoop #-} - go (plusPtr src 3) (plusPtr dst 4) (n + 4) -{-# INLINE innerLoopNopad #-} +lenientLoop + :: Ptr Word8 + -- ^ decode lookup table + -> Ptr Word8 + -- ^ src pointer + -> Ptr Word8 + -- ^ dst pointer + -> Ptr Word8 + -- ^ end of src ptr + -> ForeignPtr Word8 + -- ^ dst foreign ptr (for consing bs) + -> IO ByteString +lenientLoop = W16.lenientLoop diff --git a/src/Data/ByteString/Base64/Internal/W64/Loop.hs b/src/Data/ByteString/Base64/Internal/W64/Loop.hs --- a/src/Data/ByteString/Base64/Internal/W64/Loop.hs +++ b/src/Data/ByteString/Base64/Internal/W64/Loop.hs @@ -1,5 +1,5 @@ {-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeApplications #-} -- | -- Module : Data.ByteString.Base64.Internal.W64.Loop @@ -14,13 +14,18 @@ -- module Data.ByteString.Base64.Internal.W64.Loop ( innerLoop -, innerLoopNopad +, decodeLoop +, lenientLoop ) where import Data.Bits import Data.ByteString.Internal +import Data.ByteString.Base64.Internal.Utils +import qualified Data.ByteString.Base64.Internal.W16.Loop as W16 +import Data.Text (Text) +import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable @@ -33,111 +38,64 @@ -- innerLoop :: Ptr Word16 - -> Ptr Word8 - -> Ptr Word16 - -> Ptr Word8 - -> (Ptr Word8 -> Ptr Word8 -> IO ()) - -> IO () -innerLoop !etable !sptr !dptr !end finish = go (castPtr sptr) dptr + -> Ptr Word64 + -> Ptr Word64 + -> Ptr Word64 + -> (Ptr Word8 -> Ptr Word8 -> IO ByteString) + -> IO ByteString +innerLoop !etable !sptr !dptr !end finish = go sptr dptr where - tailRound !src !dst - | plusPtr src 2 >= end = finish src (castPtr dst) - | otherwise = do -#ifdef WORDS_BIGENDIAN - !w <- peek @Word32 (castPtr src) -#else - !w <- byteSwap32 <$> peek @Word32 (castPtr src) -#endif - let !a = (unsafeShiftR w 20) .&. 0xfff - !b = (unsafeShiftR w 8) .&. 0xfff - - !x <- peekElemOff etable (fromIntegral a) - !y <- peekElemOff etable (fromIntegral b) - - poke dst x - poke (plusPtr dst 2) y - - finish (plusPtr src 3) (castPtr (plusPtr dst 4)) - go !src !dst - | plusPtr src 5 >= end = tailRound (castPtr src) dst + | plusPtr src 7 >= end = + W16.innerLoop etable (castPtr src) (castPtr dst) (castPtr end) finish | otherwise = do -#ifdef WORDS_BIGENDIAN - !t <- peek @Word64 src -#else - !t <- byteSwap64 <$> peek @Word64 src -#endif + !t <- peekWord64BE src + let !a = (unsafeShiftR t 52) .&. 0xfff !b = (unsafeShiftR t 40) .&. 0xfff !c = (unsafeShiftR t 28) .&. 0xfff !d = (unsafeShiftR t 16) .&. 0xfff - w <- peekElemOff etable (fromIntegral a) - x <- peekElemOff etable (fromIntegral b) - y <- peekElemOff etable (fromIntegral c) - z <- peekElemOff etable (fromIntegral d) + !w <- w64_16 <$> peekElemOff etable (fromIntegral a) + !x <- w64_16 <$> peekElemOff etable (fromIntegral b) + !y <- w64_16 <$> peekElemOff etable (fromIntegral c) + !z <- w64_16 <$> peekElemOff etable (fromIntegral d) - poke dst w - poke (plusPtr dst 2) x - poke (plusPtr dst 4) y - poke (plusPtr dst 6) z + let !xx = w + .|. (unsafeShiftL x 16) + .|. (unsafeShiftL y 32) + .|. (unsafeShiftL z 48) + poke dst (fromIntegral xx) + go (plusPtr src 6) (plusPtr dst 8) -{-# INLINE innerLoop #-} +{-# inline innerLoop #-} --- | Unpadded encoding loop, finalized as a bytestring using the --- resultant length count. --- -innerLoopNopad - :: Ptr Word16 +decodeLoop + :: Ptr Word8 + -- ^ decode lookup table -> Ptr Word8 - -> Ptr Word16 + -- ^ src pointer -> Ptr Word8 - -> (Ptr Word8 -> Ptr Word8 -> Int -> IO ByteString) - -> IO ByteString -innerLoopNopad !etable !sptr !dptr !end finish = go (castPtr sptr) dptr 0 - where - tailRound !src !dst !n - | plusPtr src 2 >= end = finish src (castPtr dst) n - | otherwise = do -#ifdef WORDS_BIGENDIAN - !w <- peek @Word32 (castPtr src) -#else - !w <- byteSwap32 <$> peek @Word32 (castPtr src) -#endif - let !a = (unsafeShiftR w 20) .&. 0xfff - !b = (unsafeShiftR w 8) .&. 0xfff - - !x <- peekElemOff etable (fromIntegral a) - !y <- peekElemOff etable (fromIntegral b) - - poke dst x - poke (plusPtr dst 2) y - - finish (plusPtr src 3) (castPtr (plusPtr dst 4)) (n + 4) - - go !src !dst !n - | plusPtr src 5 >= end = tailRound (castPtr src) dst n - | otherwise = do -#ifdef WORDS_BIGENDIAN - !t <- peek @Word64 src -#else - !t <- byteSwap64 <$> peek @Word64 src -#endif - let !a = (unsafeShiftR t 52) .&. 0xfff - !b = (unsafeShiftR t 40) .&. 0xfff - !c = (unsafeShiftR t 28) .&. 0xfff - !d = (unsafeShiftR t 16) .&. 0xfff - - w <- peekElemOff etable (fromIntegral a) - x <- peekElemOff etable (fromIntegral b) - y <- peekElemOff etable (fromIntegral c) - z <- peekElemOff etable (fromIntegral d) - - poke dst w - poke (plusPtr dst 2) x - poke (plusPtr dst 4) y - poke (plusPtr dst 6) z + -- ^ dst pointer + -> Ptr Word8 + -- ^ end of src ptr + -> (Ptr Word8 -> Ptr Word8 -> IO (Either Text ByteString)) + -- ^ dst foreign ptr (for consing bs) + -> IO (Either Text ByteString) +decodeLoop = W16.decodeLoop +{-# inline decodeLoop #-} - go (plusPtr src 6) (plusPtr dst 8) (n + 8) -{-# INLINE innerLoopNopad #-} +lenientLoop + :: Ptr Word8 + -- ^ decode lookup table + -> Ptr Word8 + -- ^ src pointer + -> Ptr Word8 + -- ^ dst pointer + -> Ptr Word8 + -- ^ end of src ptr + -> ForeignPtr Word8 + -- ^ dst foreign ptr (for consing bs) + -> IO ByteString +lenientLoop = W16.lenientLoop diff --git a/src/Data/ByteString/Base64/Internal/W8/Loop.hs b/src/Data/ByteString/Base64/Internal/W8/Loop.hs deleted file mode 100644 --- a/src/Data/ByteString/Base64/Internal/W8/Loop.hs +++ /dev/null @@ -1,88 +0,0 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE CPP #-} -{-# LANGUAGE TypeApplications #-} --- | --- Module : Data.ByteString.Base64.Internal.W32.Loop --- Copyright : (c) 2019-2020 Emily Pillmore --- License : BSD-style --- --- Maintainer : Emily Pillmore --- Stability : Experimental --- Portability : portable --- --- 'Word8' fallback loop --- -module Data.ByteString.Base64.Internal.W8.Loop -( innerLoop -, innerLoopNopad -) where - - -import Data.Bits -import Data.ByteString.Internal -import Data.ByteString.Base64.Internal.Utils - -import Foreign.Ptr -import Foreign.Storable - -import GHC.Word - - --- | Encoding inner loop. Packs 3 bytes from src pointer into --- the first 6 bytes of 4 'Word8''s (using the encoding table, --- as 2 'Word12''s ), writing these to the dst pointer. --- -innerLoop - :: Ptr Word16 - -> Ptr Word8 - -> Ptr Word16 - -> Ptr Word8 - -> (Ptr Word8 -> Ptr Word8 -> IO ()) - -> IO () -innerLoop etable sptr dptr end finish = go sptr dptr - where - go !src !dst - | plusPtr src 2 >= end = finish src (castPtr dst) - | otherwise = do - - !i <- w32 <$> peek src - !j <- w32 <$> peek (plusPtr src 1) - !k <- w32 <$> peek (plusPtr src 2) - - let !w = (shiftL i 16) .|. (shiftL j 8) .|. k - - !x <- peekElemOff etable (fromIntegral (shiftR w 12)) - !y <- peekElemOff etable (fromIntegral (w .&. 0xfff)) - - poke dst x - poke (plusPtr dst 2) y - - go (plusPtr src 3) (plusPtr dst 4) - --- | Unpadded encoding loop, finalized as a bytestring using the --- resultant length count. --- -innerLoopNopad - :: Ptr Word16 - -> Ptr Word8 - -> Ptr Word16 - -> Ptr Word8 - -> (Ptr Word8 -> Ptr Word8 -> Int -> IO ByteString) - -> IO ByteString -innerLoopNopad etable sptr dptr end finish = go sptr dptr 0 - where - go !src !dst !n - | plusPtr src 2 >= end = finish src (castPtr dst) n - | otherwise = do - !i <- w32 <$> peek src - !j <- w32 <$> peek (plusPtr src 1) - !k <- w32 <$> peek (plusPtr src 2) - - let !w = (shiftL i 16) .|. (shiftL j 8) .|. k - !x <- peekElemOff etable (fromIntegral (shiftR w 12)) - !y <- peekElemOff etable (fromIntegral (w .&. 0xfff)) - - poke dst x - poke (plusPtr dst 2) y - - go (plusPtr src 3) (plusPtr dst 4) (n + 4) diff --git a/src/Data/ByteString/Base64/URL.hs b/src/Data/ByteString/Base64/URL.hs --- a/src/Data/ByteString/Base64/URL.hs +++ b/src/Data/ByteString/Base64/URL.hs @@ -1,8 +1,9 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeApplications #-} -- | -- Module : Data.ByteString.Base64.URL --- Copyright : (c) 2019 Emily Pillmore +-- Copyright : (c) 2019-2020 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -20,18 +21,25 @@ , encodeBase64Unpadded , encodeBase64Unpadded' , decodeBase64Unpadded +, decodeBase64Padded , decodeBase64Lenient , isBase64Url , isValidBase64Url ) where -import Data.ByteString (ByteString) + +import qualified Data.ByteString as BS +import Data.ByteString.Internal (ByteString(..)) 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 +import System.IO.Unsafe + -- | Encode a 'ByteString' value as a Base64url 'Text' value with padding. -- -- See: @@ -56,7 +64,15 @@ -- See: -- decodeBase64 :: ByteString -> Either Text ByteString -decodeBase64 = decodeBase64_ Pad decodeB64UrlTable +decodeBase64 bs@(PS _ _ !l) + | l == 0 = Right bs + | r == 0 = unsafeDupablePerformIO $ decodeBase64_ dlen decodeB64UrlTable bs + | r == 2 = unsafeDupablePerformIO $ decodeBase64_ dlen decodeB64UrlTable (BS.append bs "==") + | r == 3 = validateLastPad bs $ decodeBase64_ dlen decodeB64UrlTable (BS.append bs "=") + | otherwise = Left "Base64-encoded bytestring has invalid size" + where + (!q, !r) = divMod l 4 + !dlen = q * 3 {-# INLINE decodeBase64 #-} -- | Encode a 'ByteString' value as Base64url 'Text' without padding. Note that for Base64url, @@ -78,9 +94,9 @@ encodeBase64Unpadded' :: ByteString -> ByteString encodeBase64Unpadded' = encodeBase64Nopad_ base64UrlTable --- | Decode a padded Base64url-encoded 'ByteString' value. If its length is not a multiple --- of 4, then padding chars will /not/ be added to fill out the input to a multiple of --- 4. +-- | Decode an unpadded Base64url-encoded 'ByteString' value. Input strings are +-- required to be unpadded, and will undergo validation prior to decoding to +-- confirm. -- -- In general, unless unpadded Base64url is explicitly required, it is -- safer to call 'decodeBase64'. @@ -88,8 +104,36 @@ -- See: -- decodeBase64Unpadded :: ByteString -> Either Text ByteString -decodeBase64Unpadded = decodeBase64_ NoPad decodeB64UrlTable +decodeBase64Unpadded bs@(PS _ _ !l) + | l == 0 = Right bs + | r == 0 = validateLastPad bs $ decodeBase64_ dlen decodeB64UrlTable bs + | r == 2 = validateLastPad bs $ decodeBase64_ dlen decodeB64UrlTable (BS.append bs "==") + | r == 3 = validateLastPad bs $ decodeBase64_ dlen decodeB64UrlTable (BS.append bs "=") + | otherwise = Left "Base64-encoded bytestring has invalid size" + where + (!q, !r) = divMod l 4 + !dlen = q * 3 {-# INLINE decodeBase64Unpadded #-} + +-- | Decode a padded Base64url-encoded 'ByteString' value. Input strings are +-- required to be correctly padded, and will be validated prior to decoding +-- to confirm. +-- +-- In general, unless padded Base64url is explicitly required, it is +-- safer to call 'decodeBase64'. +-- +-- See: +-- +decodeBase64Padded :: ByteString -> Either Text ByteString +decodeBase64Padded bs@(PS !_ _ !l) + | l == 0 = Right bs + | r == 1 = Left "Base64-encoded bytestring has invalid size" + | r /= 0 = Left "Base64-encoded bytestring requires padding" + | otherwise = unsafeDupablePerformIO $ decodeBase64_ dlen decodeB64UrlTable bs + where + (!q, !r) = divMod l 4 + !dlen = q * 3 +{-# INLINE decodeBase64Padded #-} -- | Leniently decode an unpadded Base64url-encoded 'ByteString'. This function -- will not generate parse errors. If input data contains padding chars, diff --git a/src/Data/ByteString/Lazy/Base64.hs b/src/Data/ByteString/Lazy/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Lazy/Base64.hs @@ -0,0 +1,102 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Data.ByteString.Lazy.Base64 +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- This module contains the combinators implementing the +-- RFC 4648 specification for the Base64 encoding including +-- unpadded and lenient variants +-- +module Data.ByteString.Lazy.Base64 +( encodeBase64 +, encodeBase64' +, decodeBase64 +, decodeBase64Lenient +, isBase64 +, isValidBase64 +) where + + +import Prelude hiding (all, elem) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64 as B64 +import Data.ByteString.Base64.Internal.Utils (reChunkN) +import Data.ByteString.Lazy (elem, fromChunks, toChunks) +import Data.ByteString.Lazy.Internal (ByteString(..)) +import Data.Either (isRight) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + +-- | Encode a 'ByteString' value as Base64 'Text' with padding. +-- +-- See: +-- +encodeBase64 :: ByteString -> TL.Text +encodeBase64 = TL.decodeUtf8 . encodeBase64' +{-# INLINE encodeBase64 #-} + +-- | Encode a 'ByteString' value as a Base64 'ByteString' value with padding. +-- +-- See: +-- +encodeBase64' :: ByteString -> ByteString +encodeBase64' = fromChunks + . fmap B64.encodeBase64' + . reChunkN 3 + . toChunks +{-# INLINE encodeBase64' #-} + +-- | Decode a padded Base64-encoded 'ByteString' value. +-- +-- See: +-- +decodeBase64 :: ByteString -> Either T.Text ByteString +decodeBase64 = fmap (fromChunks . (:[])) + . B64.decodeBase64 + . BS.concat + . toChunks +{-# INLINE decodeBase64 #-} + +-- | Leniently decode an unpadded Base64-encoded 'ByteString' value. This function +-- will not generate parse errors. If input data contains padding chars, +-- then the input will be parsed up until the first pad character. +-- +-- __Note:__ This is not RFC 4648-compliant. +-- +decodeBase64Lenient :: ByteString -> ByteString +decodeBase64Lenient = fromChunks + . fmap B64.decodeBase64Lenient + . reChunkN 4 + . fmap (BS.filter (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/=")) + . toChunks +{-# INLINE decodeBase64Lenient #-} + +-- | Tell whether a 'ByteString' value is base64 encoded. +-- +isBase64 :: ByteString -> Bool +isBase64 bs = isValidBase64 bs && isRight (decodeBase64 bs) +{-# INLINE isBase64 #-} + +-- | Tell whether a 'ByteString' value is a valid Base64 format. +-- +-- This will not tell you whether or not this is a correct Base64url representation, +-- only that it conforms to the correct shape. To check whether it is a true +-- Base64 encoded 'ByteString' value, use 'isBase64'. +-- +isValidBase64 :: ByteString -> Bool +isValidBase64 = go . toChunks + where + go [] = True + go [c] = B64.isValidBase64 c + go (c:cs) = -- note the lack of padding char + BS.all (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/") c + && go cs +{-# INLINE isValidBase64 #-} diff --git a/src/Data/ByteString/Lazy/Base64/URL.hs b/src/Data/ByteString/Lazy/Base64/URL.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Lazy/Base64/URL.hs @@ -0,0 +1,164 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Data.ByteString.Lazy.Base64.URL +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- This module contains the combinators implementing the +-- RFC 4648 specification for the Base64 encoding including +-- unpadded and lenient variants +-- +module Data.ByteString.Lazy.Base64.URL +( encodeBase64 +, encodeBase64' +, encodeBase64Unpadded +, encodeBase64Unpadded' +, decodeBase64 +, decodeBase64Padded +, decodeBase64Unpadded +, decodeBase64Lenient +, isBase64Url +, isValidBase64Url +) where + + +import Prelude hiding (all, elem) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base64.URL as B64U +import Data.ByteString.Base64.Internal.Utils (reChunkN) +import Data.ByteString.Lazy (elem, fromChunks, toChunks) +import Data.ByteString.Lazy.Internal (ByteString(..)) +import Data.Either (isRight) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + + +-- | Encode a 'ByteString' value as a Base64url 'Text' value with padding. +-- +-- See: +-- +encodeBase64 :: ByteString -> TL.Text +encodeBase64 = TL.decodeUtf8 . encodeBase64' +{-# INLINE encodeBase64 #-} + +-- | Encode a 'ByteString' as a Base64url 'ByteString' value with padding. +-- +-- See: +-- +encodeBase64' :: ByteString -> ByteString +encodeBase64' = fromChunks + . fmap B64U.encodeBase64' + . reChunkN 3 + . toChunks + +-- | Decode a padded Base64url encoded 'ByteString' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as Base64url-encoded values are optionally padded. +-- +-- For a decoder that fails on unpadded input of incorrect size, use 'decodeBase64Unpadded'. +-- +-- See: +-- +decodeBase64 :: ByteString -> Either T.Text ByteString +decodeBase64 = fmap (fromChunks . (:[])) + . B64U.decodeBase64 + . BS.concat + . toChunks +{-# INLINE decodeBase64 #-} + +-- | Encode a 'ByteString' value as Base64url 'Text' without padding. Note that for Base64url, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base64url and stripping padding chars from the output. +-- +-- See: +-- +encodeBase64Unpadded :: ByteString -> TL.Text +encodeBase64Unpadded = TL.decodeUtf8 . encodeBase64Unpadded' +{-# INLINE encodeBase64Unpadded #-} + +-- | Encode a 'ByteString' value as Base64url without padding. Note that for Base64url, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base64url and stripping padding chars from the output. +-- +-- See: +-- +encodeBase64Unpadded' :: ByteString -> ByteString +encodeBase64Unpadded' = fromChunks + . fmap B64U.encodeBase64Unpadded' + . reChunkN 3 + . toChunks + +-- | Decode an unpadded Base64url-encoded 'ByteString' value. Input strings are +-- required to be unpadded, and will undergo validation prior to decoding to +-- confirm. +-- +-- In general, unless unpadded Base64url is explicitly required, it is +-- safer to call 'decodeBase64'. +-- +-- See: +-- +decodeBase64Unpadded :: ByteString -> Either T.Text ByteString +decodeBase64Unpadded = fmap (fromChunks . (:[])) + . B64U.decodeBase64Unpadded + . BS.concat + . toChunks +{-# INLINE decodeBase64Unpadded #-} + +-- | Decode a padded Base64url-encoded 'ByteString' value. Input strings are +-- required to be correctly padded, and will be validated prior to decoding +-- to confirm. +-- +-- In general, unless padded Base64url is explicitly required, it is +-- safer to call 'decodeBase64'. +-- +-- See: +-- +decodeBase64Padded :: ByteString -> Either T.Text ByteString +decodeBase64Padded = fmap (fromChunks . (:[])) + . B64U.decodeBase64Padded + . BS.concat + . toChunks +{-# INLINE decodeBase64Padded #-} + +-- | Leniently decode an unpadded Base64url-encoded 'ByteString'. This function +-- will not generate parse errors. If input data contains padding chars, +-- then the input will be parsed up until the first pad character. +-- +-- __Note:__ This is not RFC 4648-compliant. +-- +decodeBase64Lenient :: ByteString -> ByteString +decodeBase64Lenient = fromChunks + . fmap B64U.decodeBase64Lenient + . reChunkN 4 + . fmap (BS.filter (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_=")) + . toChunks +{-# INLINE decodeBase64Lenient #-} + +-- | Tell whether a 'ByteString' is Base64url-encoded. +-- +isBase64Url :: ByteString -> Bool +isBase64Url bs = isValidBase64Url bs && isRight (decodeBase64 bs) +{-# INLINE isBase64Url #-} + +-- | Tell whether a 'ByteString' is a valid Base64url format. +-- +-- This will not tell you whether or not this is a correct Base64url representation, +-- only that it conforms to the correct shape. To check whether it is a true +-- Base64 encoded 'ByteString' value, use 'isBase64Url'. +-- +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 (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_") c + && go cs +{-# INLINE isValidBase64Url #-} diff --git a/src/Data/ByteString/Short/Base64.hs b/src/Data/ByteString/Short/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Short/Base64.hs @@ -0,0 +1,78 @@ +-- | +-- Module : Data.ByteString.Short.Base64 +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- This module contains the combinators implementing the +-- RFC 4648 specification for the Base64 encoding including +-- unpadded and lenient variants +-- +module Data.ByteString.Short.Base64 +( encodeBase64 +, encodeBase64' +, decodeBase64 +, decodeBase64Lenient +, isBase64 +, isValidBase64 +) where + + +import qualified Data.ByteString.Base64 as B64 +import Data.ByteString.Short (ShortByteString, fromShort, toShort) +import Data.Text (Text) +import Data.Text.Short (ShortText) +import Data.Text.Short.Unsafe (fromShortByteStringUnsafe) + +-- | Encode a 'ShortByteString' value as Base64 'Text' with padding. +-- +-- See: +-- +encodeBase64 :: ShortByteString -> ShortText +encodeBase64 = fromShortByteStringUnsafe . encodeBase64' +{-# INLINE encodeBase64 #-} + +-- | Encode a 'ShortByteString' value as a Base64 'ShortByteString' value with padding. +-- +-- See: +-- +encodeBase64' :: ShortByteString -> ShortByteString +encodeBase64' = toShort . B64.encodeBase64' . fromShort +{-# INLINE encodeBase64' #-} + +-- | Decode a padded Base64-encoded 'ShortByteString' value. +-- +-- See: +-- +decodeBase64 :: ShortByteString -> Either Text ShortByteString +decodeBase64 = fmap toShort . B64.decodeBase64 . fromShort +{-# INLINE decodeBase64 #-} + +-- | Leniently decode an unpadded Base64-encoded 'ShortByteString' value. This function +-- will not generate parse errors. If input data contains padding chars, +-- then the input will be parsed up until the first pad character. +-- +-- __Note:__ This is not RFC 4648-compliant. +-- +decodeBase64Lenient :: ShortByteString -> ShortByteString +decodeBase64Lenient = toShort . B64.decodeBase64Lenient . fromShort +{-# INLINE decodeBase64Lenient #-} + +-- | Tell whether a 'ShortByteString' value is base64 encoded. +-- +isBase64 :: ShortByteString -> Bool +isBase64 = B64.isBase64 . fromShort +{-# INLINE isBase64 #-} + +-- | Tell whether a 'ShortByteString' value is a valid Base64 format. +-- +-- This will not tell you whether or not this is a correct Base64url representation, +-- only that it conforms to the correct shape. To check whether it is a true +-- Base64 encoded 'ShortByteString' value, use 'isBase64'. +-- +isValidBase64 :: ShortByteString -> Bool +isValidBase64 = B64.isValidBase64 . fromShort +{-# INLINE isValidBase64 #-} diff --git a/src/Data/ByteString/Short/Base64/URL.hs b/src/Data/ByteString/Short/Base64/URL.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Short/Base64/URL.hs @@ -0,0 +1,131 @@ +-- | +-- Module : Data.ByteString.Short.Base64.URL +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- This module contains the combinators implementing the +-- RFC 4648 specification for the Base64url encoding including +-- unpadded and lenient variants +-- +module Data.ByteString.Short.Base64.URL +( encodeBase64 +, encodeBase64Unpadded +, encodeBase64' +, encodeBase64Unpadded' +, decodeBase64 +, decodeBase64Padded +, decodeBase64Unpadded +, decodeBase64Lenient +, isBase64Url +, isValidBase64Url +) where + + +import qualified Data.ByteString.Base64.URL as B64U +import Data.ByteString.Short (ShortByteString, fromShort, toShort) +import Data.Text (Text) +import Data.Text.Short (ShortText) +import Data.Text.Short.Unsafe (fromShortByteStringUnsafe) + +-- | Encode a 'ShortByteString' value as a Base64url 'Text' value with padding. +-- +-- See: +-- +encodeBase64 :: ShortByteString -> ShortText +encodeBase64 = fromShortByteStringUnsafe . encodeBase64' +{-# INLINE encodeBase64 #-} + +-- | Encode a 'ShortByteString' as a Base64url 'ShortByteString' value with padding. +-- +-- See: +-- +encodeBase64' :: ShortByteString -> ShortByteString +encodeBase64' = toShort . B64U.encodeBase64' . fromShort + +-- | Decode a padded Base64url encoded 'ShortByteString' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as Base64url-encoded values are optionally padded. +-- +-- For a decoder that fails on unpadded input of incorrect size, use 'decodeBase64Unpadded'. +-- +-- See: +-- +decodeBase64 :: ShortByteString -> Either Text ShortByteString +decodeBase64 = fmap toShort . B64U.decodeBase64 . fromShort + +{-# INLINE decodeBase64 #-} + +-- | Encode a 'ShortByteString' value as Base64url 'Text' without padding. Note that for Base64url, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base64url and stripping padding chars from the output. +-- +-- See: +-- +encodeBase64Unpadded :: ShortByteString -> ShortText +encodeBase64Unpadded = fromShortByteStringUnsafe . encodeBase64Unpadded' +{-# INLINE encodeBase64Unpadded #-} + +-- | Encode a 'ShortByteString' value as Base64url without padding. Note that for Base64url, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base64url and stripping padding chars from the output. +-- +-- See: +-- +encodeBase64Unpadded' :: ShortByteString -> ShortByteString +encodeBase64Unpadded' = toShort . B64U.encodeBase64Unpadded' . fromShort + +-- | Decode an unpadded Base64url-encoded 'ShortByteString' value. Input strings are +-- required to be unpadded, and will undergo validation prior to decoding to +-- confirm. +-- +-- In general, unless unpadded Base64url is explicitly required, it is +-- safer to call 'decodeBase64'. +-- +-- See: +-- +decodeBase64Unpadded :: ShortByteString -> Either Text ShortByteString +decodeBase64Unpadded = fmap toShort . B64U.decodeBase64Unpadded . fromShort +{-# INLINE decodeBase64Unpadded #-} + +-- | Decode a padded Base64url-encoded 'ShortByteString' value. Input strings are +-- required to be correctly padded, and will be validated prior to decoding +-- to confirm. +-- +-- In general, unless padded Base64url is explicitly required, it is +-- safer to call 'decodeBase64'. +-- +-- See: +-- +decodeBase64Padded :: ShortByteString -> Either Text ShortByteString +decodeBase64Padded = fmap toShort . B64U.decodeBase64Padded . fromShort +{-# INLINE decodeBase64Padded #-} + +-- | Leniently decode an unpadded Base64url-encoded 'ShortByteString'. This function +-- will not generate parse errors. If input data contains padding chars, +-- then the input will be parsed up until the first pad character. +-- +-- __Note:__ This is not RFC 4648-compliant. +-- +decodeBase64Lenient :: ShortByteString -> ShortByteString +decodeBase64Lenient = toShort . B64U.decodeBase64Lenient . fromShort +{-# INLINE decodeBase64Lenient #-} + +-- | Tell whether a 'ShortByteString' is Base64url-encoded. +-- +isBase64Url :: ShortByteString -> Bool +isBase64Url = B64U.isBase64Url . fromShort +{-# INLINE isBase64Url #-} + +-- | Tell whether a 'ShortByteString' is a valid Base64url format. +-- +-- This will not tell you whether or not this is a correct Base64url representation, +-- only that it conforms to the correct shape. To check whether it is a true +-- Base64 encoded 'ShortByteString' value, use 'isBase64Url'. +-- +isValidBase64Url :: ShortByteString -> Bool +isValidBase64Url = B64U.isValidBase64Url . fromShort +{-# INLINE isValidBase64Url #-} diff --git a/src/Data/Text/Encoding/Base64.hs b/src/Data/Text/Encoding/Base64.hs --- a/src/Data/Text/Encoding/Base64.hs +++ b/src/Data/Text/Encoding/Base64.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -- | -- Module : Data.Text.Encoding.Base64 --- Copyright : (c) 2019 Emily Pillmore +-- Copyright : (c) 2019-2020 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -15,16 +15,20 @@ module Data.Text.Encoding.Base64 ( encodeBase64 , decodeBase64 +, decodeBase64With , decodeBase64Lenient , isBase64 , isValidBase64 ) where +import Data.Bifunctor (first) +import Data.ByteString (ByteString) import qualified Data.ByteString.Base64 as B64 import Data.Text (Text) import qualified Data.Text.Encoding as T +import Data.Text.Encoding.Base64.Error -- | Encode a 'Text' value in Base64 with padding. -- @@ -34,14 +38,44 @@ encodeBase64 = B64.encodeBase64 . T.encodeUtf8 {-# INLINE encodeBase64 #-} --- | Decode a padded Base64-encoded 'Text' value +-- | Decode a padded Base64-encoded 'Text' value. -- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase64With` +-- and pass in a custom decode function. +-- -- See: -- decodeBase64 :: Text -> Either Text Text -decodeBase64 = fmap T.decodeUtf8 . B64.decodeBase64 . T.encodeUtf8 +decodeBase64 = fmap T.decodeLatin1 . B64.decodeBase64 . T.encodeUtf8 {-# INLINE decodeBase64 #-} +-- | Attempt to decode a 'Text' value as Base64, converting from +-- 'ByteString' to 'Text' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- Example: +-- +-- @ +-- 'decodeBase64With' 'T.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'Text' +-- @ +-- +decodeBase64With + :: (ByteString -> Either err Text) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base64Error err) Text +decodeBase64With f t = case B64.decodeBase64 t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase64With #-} + -- | Leniently decode a Base64-encoded 'Text' value. This function -- will not generate parse errors. If input data contains padding chars, -- then the input will be parsed up until the first pad character. @@ -49,11 +83,10 @@ -- __Note:__ This is not RFC 4648-compliant. -- decodeBase64Lenient :: Text -> Text -decodeBase64Lenient = T.decodeUtf8 +decodeBase64Lenient = T.decodeLatin1 . B64.decodeBase64Lenient . T.encodeUtf8 {-# INLINE decodeBase64Lenient #-} - -- | Tell whether a 'Text' value is Base64-encoded. -- diff --git a/src/Data/Text/Encoding/Base64/Error.hs b/src/Data/Text/Encoding/Base64/Error.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Encoding/Base64/Error.hs @@ -0,0 +1,32 @@ +-- | +-- Module : Data.Text.Encoding.Base64.Error +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- This module contains the error types raised (not as exceptions!) +-- in the decoding process. +-- +module Data.Text.Encoding.Base64.Error +( Base64Error(..) +) where + + +import Data.Text (Text) + +-- | This data type represents the type of decoding errors of +-- various kinds as they pertain to decoding 'Text' values. +-- Namely, to distinguish between decoding errors from opaque +-- unicode exceptions caught in the unicode decoding process. +-- +data Base64Error e + = DecodeError Text + -- ^ The error associated with decoding failure + -- as a result of the Base64 decoding process + | ConversionError e + -- ^ The error associated with the decoding failure + -- as a result of the conversion process + deriving (Eq, Show) diff --git a/src/Data/Text/Encoding/Base64/URL.hs b/src/Data/Text/Encoding/Base64/URL.hs --- a/src/Data/Text/Encoding/Base64/URL.hs +++ b/src/Data/Text/Encoding/Base64/URL.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} -- | -- Module : Data.Text.Encoding.Base64.URL --- Copyright : (c) 2019 Emily Pillmore +-- Copyright : (c) 2019-2020 Emily Pillmore -- License : BSD-style -- -- Maintainer : Emily Pillmore @@ -14,18 +14,25 @@ module Data.Text.Encoding.Base64.URL ( encodeBase64 , decodeBase64 +, decodeBase64With , encodeBase64Unpadded , decodeBase64Unpadded +, decodeBase64UnpaddedWith +, decodeBase64Padded +, decodeBase64PaddedWith , decodeBase64Lenient , isBase64Url , isValidBase64Url ) where +import Data.Bifunctor (first) +import Data.ByteString (ByteString) import qualified Data.ByteString.Base64.URL as B64U import Data.Text (Text) import qualified Data.Text.Encoding as T +import Data.Text.Encoding.Base64.Error -- | Encode a 'Text' value in Base64url with padding. -- @@ -39,14 +46,44 @@ -- of 4, then padding chars will be added to fill out the input to a multiple of -- 4 for safe decoding as base64url encodings are optionally padded. -- --- For a decoder that fails on unpadded input of incorrect size, use 'decodeBase64Unpadded'. +-- For a decoder that fails on unpadded input, use 'decodeBase64Unpadded' -- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase64With` +-- and pass in a custom decode function. +-- -- See: -- decodeBase64 :: Text -> Either Text Text -decodeBase64 = fmap T.decodeUtf8 . B64U.decodeBase64 . T.encodeUtf8 +decodeBase64 = fmap T.decodeLatin1 . B64U.decodeBase64 . T.encodeUtf8 {-# INLINE decodeBase64 #-} +-- | Attempt to decode a 'ByteString' value as Base64url, converting from +-- 'ByteString' to 'Text' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- Example: +-- +-- @ +-- 'decodeBase64With' 'T.decodeUtf8'' +-- :: 'Text' -> 'Either' ('Base64Error' 'UnicodeException') 'Text' +-- @ +-- +decodeBase64With + :: (ByteString -> Either err Text) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base64Error err) Text +decodeBase64With f t = case B64U.decodeBase64 t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase64With #-} + -- | Encode a 'Text' value in Base64url without padding. Note that for Base64url, -- padding is optional. If you call this function, you will simply be encoding -- as Base64url and stripping padding chars from the output. @@ -57,16 +94,86 @@ encodeBase64Unpadded = B64U.encodeBase64Unpadded . T.encodeUtf8 {-# INLINE encodeBase64Unpadded #-} --- | Decode an unpadded Base64url encoded 'Text' value +-- | Decode an unpadded Base64url encoded 'Text' value. -- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to +-- 'decodeBase64UnpaddedWith' and pass in a custom decode function. +-- -- See: -- decodeBase64Unpadded :: Text -> Either Text Text -decodeBase64Unpadded = fmap T.decodeUtf8 +decodeBase64Unpadded = fmap T.decodeLatin1 . B64U.decodeBase64Unpadded . T.encodeUtf8 {-# INLINE decodeBase64Unpadded #-} +-- | Attempt to decode an unpadded 'ByteString' value as Base64url, converting from +-- 'ByteString' to 'Text' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- Example: +-- +-- @ +-- 'decodeBase64With' 'T.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'Text' +-- @ +-- +decodeBase64UnpaddedWith + :: (ByteString -> Either err Text) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base64Error err) Text +decodeBase64UnpaddedWith f t = case B64U.decodeBase64Unpadded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase64UnpaddedWith #-} + +-- | Decode an padded Base64url encoded 'Text' value +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to 'decodeBase64PaddedWith' +-- and pass in a custom decode function. +-- +-- See: +-- +decodeBase64Padded :: Text -> Either Text Text +decodeBase64Padded = fmap T.decodeLatin1 + . B64U.decodeBase64Padded + . T.encodeUtf8 +{-# INLINE decodeBase64Padded #-} + +-- | Attempt to decode a padded 'ByteString' value as Base64url, converting from +-- 'ByteString' to 'Text' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- Example: +-- +-- @ +-- 'decodeBase64With' 'T.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'Text' +-- @ +-- +decodeBase64PaddedWith + :: (ByteString -> Either err Text) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base64Error err) Text +decodeBase64PaddedWith f t = case B64U.decodeBase64Padded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase64PaddedWith #-} + -- | Leniently decode an unpadded Base64url-encoded 'Text'. This function -- will not generate parse errors. If input data contains padding chars, -- then the input will be parsed up until the first pad character. @@ -74,7 +181,7 @@ -- __Note:__ This is not RFC 4648-compliant. -- decodeBase64Lenient :: Text -> Text -decodeBase64Lenient = T.decodeUtf8 +decodeBase64Lenient = T.decodeLatin1 . B64U.decodeBase64Lenient . T.encodeUtf8 {-# INLINE decodeBase64Lenient #-} diff --git a/src/Data/Text/Lazy/Encoding/Base64.hs b/src/Data/Text/Lazy/Encoding/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Lazy/Encoding/Base64.hs @@ -0,0 +1,105 @@ +-- | +-- Module : Data.Text.Lazy.Encoding.Base64 +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- This module contains the combinators implementing the +-- RFC 4648 specification for the Base64 encoding including +-- unpadded and lenient variants +-- +module Data.Text.Lazy.Encoding.Base64 +( encodeBase64 +, decodeBase64 +, decodeBase64With +, decodeBase64Lenient +, isBase64 +, isValidBase64 +) where + + +import Data.Bifunctor (first) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Base64 as BL64 + +import qualified Data.Text as T +import Data.Text.Encoding.Base64.Error +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + +-- | Encode a 'TL.Text' value in Base64 with padding. +-- +-- See: +-- +encodeBase64 :: TL.Text -> TL.Text +encodeBase64 = BL64.encodeBase64 . TL.encodeUtf8 +{-# INLINE encodeBase64 #-} + +-- | Decode a padded Base64-encoded 'TL.Text' value +-- +-- See: +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase64With` +-- and pass in a custom decode function. +-- +decodeBase64 :: TL.Text -> Either T.Text TL.Text +decodeBase64 = fmap TL.decodeLatin1 . BL64.decodeBase64 . TL.encodeUtf8 +{-# INLINE decodeBase64 #-} + +-- | Attempt to decode a 'ByteString' value as Base64, converting from +-- 'ByteString' to 'TL.Text' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- Example: +-- +-- @ +-- 'decodeBase64With' 'TL.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'TL.Text' +-- @ +-- +decodeBase64With + :: (ByteString -> Either err TL.Text) + -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base64Error err) TL.Text +decodeBase64With f t = case BL64.decodeBase64 t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase64With #-} + +-- | Leniently decode a Base64-encoded 'TL.Text' value. This function +-- will not generate parse errors. If input data contains padding chars, +-- then the input will be parsed up until the first pad character. +-- +-- __Note:__ This is not RFC 4648-compliant. +-- +decodeBase64Lenient :: TL.Text -> TL.Text +decodeBase64Lenient = TL.decodeLatin1 + . BL64.decodeBase64Lenient + . TL.encodeUtf8 +{-# INLINE decodeBase64Lenient #-} + +-- | Tell whether a 'TL.Text' value is Base64-encoded. +-- +isBase64 :: TL.Text -> Bool +isBase64 = BL64.isBase64 . TL.encodeUtf8 +{-# INLINE isBase64 #-} + +-- | Tell whether a 'TL.Text' value is a valid Base64 format. +-- +-- This will not tell you whether or not this is a correct Base64 representation, +-- only that it conforms to the correct shape. To check whether it is a true +-- Base64 encoded 'TL.Text' value, use 'isBase64'. +-- +isValidBase64 :: TL.Text -> Bool +isValidBase64 = BL64.isValidBase64 . TL.encodeUtf8 +{-# INLINE isValidBase64 #-} diff --git a/src/Data/Text/Lazy/Encoding/Base64/URL.hs b/src/Data/Text/Lazy/Encoding/Base64/URL.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Lazy/Encoding/Base64/URL.hs @@ -0,0 +1,204 @@ +-- | +-- Module : Data.Text.Lazy.Encoding.Base64.URL +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- This module contains the combinators implementing the +-- RFC 4648 specification for the Base64-URL encoding including +-- unpadded and lenient variants +-- +module Data.Text.Lazy.Encoding.Base64.URL +( encodeBase64 +, decodeBase64 +, decodeBase64With +, encodeBase64Unpadded +, decodeBase64Unpadded +, decodeBase64UnpaddedWith +, decodeBase64Padded +, decodeBase64PaddedWith +, decodeBase64Lenient +, isBase64Url +, isValidBase64Url +) where + + +import Data.Bifunctor (first) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Base64.URL as BL64U + +import qualified Data.Text as T +import Data.Text.Encoding.Base64.Error +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + +-- | Encode a 'TL.Text' value in Base64url with padding. +-- +-- See: +-- +encodeBase64 :: TL.Text -> TL.Text +encodeBase64 = BL64U.encodeBase64 . TL.encodeUtf8 +{-# INLINE encodeBase64 #-} + +-- | Decode a padded Base64url-encoded 'TL.Text' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as base64url encodings are optionally padded. +-- +-- For a decoder that fails on unpadded input, use 'decodeBase64Unpadded'. +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase64With` +-- and pass in a custom decode function. +-- +-- See: +-- +decodeBase64 :: TL.Text -> Either T.Text TL.Text +decodeBase64 = fmap TL.decodeLatin1 . BL64U.decodeBase64 . TL.encodeUtf8 +{-# INLINE decodeBase64 #-} + +-- | Attempt to decode a lazy 'ByteString' value as Base64url, converting from +-- 'ByteString' to 'TL.Text' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- Example: +-- +-- @ +-- 'decodeBase64With' 'TL.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'TL.Text' +-- @ +-- +decodeBase64With + :: (ByteString -> Either err TL.Text) + -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base64Error err) TL.Text +decodeBase64With f t = case BL64U.decodeBase64 t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase64With #-} + +-- | Encode a 'TL.Text' value in Base64url without padding. Note that for Base64url, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base64url and stripping padding chars from the output. +-- +-- See: +-- +encodeBase64Unpadded :: TL.Text -> TL.Text +encodeBase64Unpadded = BL64U.encodeBase64Unpadded . TL.encodeUtf8 +{-# INLINE encodeBase64Unpadded #-} + +-- | Decode an unpadded Base64url encoded 'TL.Text' value. +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase64WUnpaddedWith` +-- and pass in a custom decode function. +-- +-- See: +-- +decodeBase64Unpadded :: TL.Text -> Either T.Text TL.Text +decodeBase64Unpadded = fmap TL.decodeLatin1 + . BL64U.decodeBase64Unpadded + . TL.encodeUtf8 +{-# INLINE decodeBase64Unpadded #-} + +-- | Attempt to decode an unpadded lazy 'ByteString' value as Base64url, converting from +-- 'ByteString' to 'TL.Text' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- Example: +-- +-- @ +-- 'decodeBase64With' 'TL.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'TL.Text' +-- @ +-- +decodeBase64UnpaddedWith + :: (ByteString -> Either err TL.Text) + -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base64Error err) TL.Text +decodeBase64UnpaddedWith f t = case BL64U.decodeBase64Unpadded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase64UnpaddedWith #-} + +-- | Decode an padded Base64url encoded 'TL.Text' value +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase64PaddedWith` +-- and pass in a custom decode function. +-- +-- See: +-- +decodeBase64Padded :: TL.Text -> Either T.Text TL.Text +decodeBase64Padded = fmap TL.decodeLatin1 + . BL64U.decodeBase64Padded + . TL.encodeUtf8 +{-# INLINE decodeBase64Padded #-} + +-- | Attempt to decode a padded lazy 'ByteString' value as Base64url, converting from +-- 'ByteString' to 'TL.Text' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- Example: +-- +-- @ +-- 'decodeBase64With' 'TL.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'TL.Text' +-- @ +-- +decodeBase64PaddedWith + :: (ByteString -> Either err TL.Text) + -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base64Error err) TL.Text +decodeBase64PaddedWith f t = case BL64U.decodeBase64Padded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase64PaddedWith #-} + +-- | Leniently decode an unpadded Base64url-encoded 'TL.Text'. This function +-- will not generate parse errors. If input data contains padding chars, +-- then the input will be parsed up until the first pad character. +-- +-- __Note:__ This is not RFC 4648-compliant. +-- +decodeBase64Lenient :: TL.Text -> TL.Text +decodeBase64Lenient = TL.decodeLatin1 + . BL64U.decodeBase64Lenient + . TL.encodeUtf8 +{-# INLINE decodeBase64Lenient #-} + +-- | Tell whether a 'TL.Text' value is Base64url-encoded. +-- +isBase64Url :: TL.Text -> Bool +isBase64Url = BL64U.isBase64Url . TL.encodeUtf8 +{-# INLINE isBase64Url #-} + +-- | Tell whether a 'TL.Text' value is a valid Base64url format. +-- +-- This will not tell you whether or not this is a correct Base64url representation, +-- only that it conforms to the correct shape. To check whether it is a true +-- Base64 encoded 'TL.Text' value, use 'isBase64Url'. +-- +isValidBase64Url :: TL.Text -> Bool +isValidBase64Url = BL64U.isValidBase64Url . TL.encodeUtf8 +{-# INLINE isValidBase64Url #-} diff --git a/src/Data/Text/Short/Encoding/Base64.hs b/src/Data/Text/Short/Encoding/Base64.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Short/Encoding/Base64.hs @@ -0,0 +1,107 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Data.Text.Encoding.Base64 +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- This module contains the combinators implementing the +-- RFC 4648 specification for the Base64 encoding including +-- unpadded and lenient variants +-- +module Data.Text.Short.Encoding.Base64 +( encodeBase64 +, decodeBase64 +, decodeBase64With +, decodeBase64Lenient +, isBase64 +, isValidBase64 +) where + + +import Data.Bifunctor (first) +import qualified Data.ByteString.Base64 as B64 +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short.Base64 as BS64 +import Data.Text (Text) +import qualified Data.Text.Encoding.Base64 as B64T +import Data.Text.Encoding.Base64.Error +import Data.Text.Short +import Data.Text.Short.Unsafe + +-- | Encode a 'ShortText' value in Base64 with padding. +-- +-- See: +-- +encodeBase64 :: ShortText -> ShortText +encodeBase64 = fromByteStringUnsafe + . B64.encodeBase64' + . toByteString +{-# INLINE encodeBase64 #-} + +-- | Decode a padded Base64-encoded 'ShortText' value +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase64With` +-- and pass in a custom decode function. +-- +-- See: +-- +decodeBase64 :: ShortText -> Either Text ShortText +decodeBase64 = fmap fromText . B64T.decodeBase64 . toText +{-# INLINE decodeBase64 #-} + +-- | Attempt to decode a 'ShortByteString' value as Base64, converting from +-- 'ByteString' to 'ShortText' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- Example: +-- +-- @ +-- 'decodeBase64With' 'T.decodeUtf8'' +-- :: 'ShortByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'ShortText' +-- @ +-- +decodeBase64With + :: (ShortByteString -> Either err ShortText) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ShortByteString + -- ^ Input text to decode + -> Either (Base64Error err) ShortText +decodeBase64With f t = case BS64.decodeBase64 t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase64With #-} + +-- | Leniently decode a Base64-encoded 'ShortText' value. This function +-- will not generate parse errors. If input data contains padding chars, +-- then the input will be parsed up until the first pad character. +-- +-- __Note:__ This is not RFC 4648-compliant. +-- +decodeBase64Lenient :: ShortText -> ShortText +decodeBase64Lenient = fromText . B64T.decodeBase64Lenient . toText +{-# INLINE decodeBase64Lenient #-} + +-- | Tell whether a 'ShortText' value is Base64-encoded. +-- +isBase64 :: ShortText -> Bool +isBase64 = B64.isBase64 . toByteString +{-# INLINE isBase64 #-} + +-- | Tell whether a 'ShortText' value is a valid Base64 format. +-- +-- This will not tell you whether or not this is a correct Base64 representation, +-- only that it conforms to the correct shape. To check whether it is a true +-- Base64 encoded 'ShortText' value, use 'isBase64'. +-- +isValidBase64 :: ShortText -> Bool +isValidBase64 = B64.isValidBase64 . toByteString +{-# INLINE isValidBase64 #-} diff --git a/src/Data/Text/Short/Encoding/Base64/URL.hs b/src/Data/Text/Short/Encoding/Base64/URL.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Short/Encoding/Base64/URL.hs @@ -0,0 +1,202 @@ +-- | +-- Module : Data.Text.Short.Encoding.Base64.URL +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- This module contains the combinators implementing the +-- RFC 4648 specification for the Base64-URL encoding including +-- unpadded and lenient variants +module Data.Text.Short.Encoding.Base64.URL +( encodeBase64 +, decodeBase64 +, decodeBase64With +, encodeBase64Unpadded +, decodeBase64Unpadded +, decodeBase64UnpaddedWith +, decodeBase64Padded +, decodeBase64PaddedWith +, decodeBase64Lenient +, isBase64Url +, isValidBase64Url +) where + + +import Data.Bifunctor (first) +import qualified Data.ByteString.Base64.URL as B64U +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short.Base64.URL as BS64U +import Data.Text (Text) +import qualified Data.Text.Encoding.Base64.URL as B64TU +import Data.Text.Encoding.Base64.Error +import Data.Text.Short +import Data.Text.Short.Unsafe + +-- | Encode a 'ShortText' value in Base64url with padding. +-- +-- See: +-- +encodeBase64 :: ShortText -> ShortText +encodeBase64 = fromByteStringUnsafe + . B64U.encodeBase64' + . toByteString +{-# INLINE encodeBase64 #-} + +-- | Decode a padded Base64url-encoded 'ShortText' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as base64url encodings are optionally padded. +-- +-- For a decoder that fails on unpadded input, use 'decodeBase64Unpadded'. +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase64With` +-- and pass in a custom decode function. +-- +-- See: +-- +decodeBase64 :: ShortText -> Either Text ShortText +decodeBase64 = fmap fromText . B64TU.decodeBase64 . toText +{-# INLINE decodeBase64 #-} + +-- | Attempt to decode a 'ShortByteString' value as Base64url, converting from +-- 'ByteString' to 'ShortText' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- Example: +-- +-- @ +-- 'decodeBase64With' 'T.decodeUtf8'' +-- :: 'ShortByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'ShortText' +-- @ +-- +decodeBase64With + :: (ShortByteString -> Either err ShortText) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ShortByteString + -- ^ Input text to decode + -> Either (Base64Error err) ShortText +decodeBase64With f t = case BS64U.decodeBase64 t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase64With #-} + +-- | Encode a 'ShortText' value in Base64url without padding. Note that for Base64url, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base64url and stripping padding chars from the output. +-- +-- See: +-- +encodeBase64Unpadded :: ShortText -> ShortText +encodeBase64Unpadded = fromByteStringUnsafe + . B64U.encodeBase64Unpadded' + . toByteString +{-# INLINE encodeBase64Unpadded #-} + +-- | Decode an unpadded Base64url encoded 'ShortText' value. +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase64UnpaddedWith` +-- and pass in a custom decode function. +-- +-- See: +-- +decodeBase64Unpadded :: ShortText -> Either Text ShortText +decodeBase64Unpadded = fmap fromText . B64TU.decodeBase64Unpadded . toText +{-# INLINE decodeBase64Unpadded #-} + +-- | Attempt to decode an unpadded 'ShortByteString' value as Base64url, converting from +-- 'ShortByteString' to 'ShortText' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- Example: +-- +-- @ +-- 'decodeBase64With' 'T.decodeUtf8'' +-- :: 'ShortByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'ShortText' +-- @ +-- +decodeBase64UnpaddedWith + :: (ShortByteString -> Either err ShortText) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ShortByteString + -- ^ Input text to decode + -> Either (Base64Error err) ShortText +decodeBase64UnpaddedWith f t = case BS64U.decodeBase64Unpadded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase64UnpaddedWith #-} + +-- | Decode an padded Base64url encoded 'ShortText' value +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base64-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase64PaddedWith` +-- and pass in a custom decode function. +-- +-- See: +-- +decodeBase64Padded :: ShortText -> Either Text ShortText +decodeBase64Padded = fmap fromText . B64TU.decodeBase64Padded . toText +{-# INLINE decodeBase64Padded #-} + +-- | Attempt to decode a padded 'ShortByteString' value as Base64url, converting from +-- 'ByteString' to 'ShortText' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- Example: +-- +-- @ +-- 'decodeBase64With' 'T.decodeUtf8'' +-- :: 'ShortByteString' -> 'Either' ('Base64Error' 'UnicodeException') 'ShortText' +-- @ +-- +decodeBase64PaddedWith + :: (ShortByteString -> Either err ShortText) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ShortByteString + -- ^ Input text to decode + -> Either (Base64Error err) ShortText +decodeBase64PaddedWith f t = case BS64U.decodeBase64Padded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase64PaddedWith #-} + +-- | Leniently decode an unpadded Base64url-encoded 'ShortText'. This function +-- will not generate parse errors. If input data contains padding chars, +-- then the input will be parsed up until the first pad character. +-- +-- __Note:__ This is not RFC 4648-compliant. +-- +decodeBase64Lenient :: ShortText -> ShortText +decodeBase64Lenient = fromText . B64TU.decodeBase64Lenient . toText +{-# INLINE decodeBase64Lenient #-} + +-- | Tell whether a 'ShortText' value is Base64url-encoded. +-- +isBase64Url :: ShortText -> Bool +isBase64Url = B64U.isBase64Url . toByteString +{-# INLINE isBase64Url #-} + +-- | Tell whether a 'ShortText' value is a valid Base64url format. +-- +-- This will not tell you whether or not this is a correct Base64url representation, +-- only that it conforms to the correct shape. To check whether it is a true +-- Base64 encoded 'ShortText' value, use 'isBase64Url'. +-- +isValidBase64Url :: ShortText -> Bool +isValidBase64Url = B64U.isValidBase64Url . toByteString +{-# INLINE isValidBase64Url #-} diff --git a/test/Base64Tests.hs b/test/Base64Tests.hs deleted file mode 100644 --- a/test/Base64Tests.hs +++ /dev/null @@ -1,142 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PackageImports #-} -module Main -( main -, tests -) where - - -import "base64" Data.ByteString.Base64 as B64 -import "base64" Data.ByteString.Base64.URL as B64U -import "base64-bytestring" Data.ByteString.Base64 as Bos -import Data.ByteString.Random (random) -import Data.Functor (void) - -import Test.Tasty -import Test.Tasty.HUnit - - -main :: IO () -main = defaultMain tests - - -tests :: TestTree -tests = testGroup "Base64 Tests" - [ testVectors - , sanityTests - , alphabetTests - ] - -testVectors :: TestTree -testVectors = testGroup "RFC 4648 Test Vectors" - [ testGroup "encode/decode" - [ testCaseB64 "" "" - , testCaseB64 "f" "Zg==" - , testCaseB64 "fo" "Zm8=" - , testCaseB64 "foo" "Zm9v" - , testCaseB64 "foob" "Zm9vYg==" - , testCaseB64 "fooba" "Zm9vYmE=" - , testCaseB64 "foobar" "Zm9vYmFy" - ] - , testGroup "encode/decode url-safe" - [ testCaseB64' "" "" - , testCaseB64' "<" "PA==" - , testCaseB64' "<<" "PDw=" - , testCaseB64' "<" "PDw_Pz4=" - , testCaseB64' "<>" "PDw_Pz4-" - ] - ] - where - testCaseB64 s t = - testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do - let t' = B64.encodeBase64' s - s' = B64.decodeBase64 t' - - step "compare encoding w/ padding" - t @=? t' - - step "compare decoding w/ padding" - Right s @=? s' - - testCaseB64' s t = - testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do - let t' = B64U.encodeBase64' s - s' = B64U.decodeBase64 t' - u = B64U.encodeBase64Unpadded' s - v = B64U.decodeBase64 u - - step "compare url-safe encoding w/ padding" - t @=? t' - - step "compare url-safe decoding w/ padding" - Right s @=? s' - - step "compare url-safe encoding w/o padding" - t @=? t' - - step "compare url-safe decoding w/o padding" - Right s @=? v - -sanityTests :: TestTree -sanityTests = testGroup "Sanity tests" - [ testGroup "very large bytestrings don't segfault" - [ chonk - ] - , testGroup "`base64-bytestring` sanity checks" - [ compare64 3 - , compare64 4 - , compare64 5 - , compare64 6 - , compare64 1000 - , compare64 100000 - ] - , testGroup "roundtrip encode/decode" - [ roundtrip 3 - , roundtrip 4 - , roundtrip 5 - , roundtrip 1000 - , roundtrip 100000 - ] - ] - where - chonk = testCase ("Encoding huge bytestrings doesn't result in OOM or segfault") $ do - bs <- random 1000000 - void $ return $ B64.encodeBase64' bs - void $ return $ B64U.encodeBase64' bs - - compare64 n = testCase ("Testing " ++ show n ++ "-sized bytestrings") $ do - bs <- random n - B64.encodeBase64' bs @=? Bos.encode bs - - roundtrip n = testCase ("Roundtrip encode/decode for " ++ show n ++ "-sized bytestrings") $ do - bs <- random n - B64.decodeBase64 (B64.encodeBase64' bs) @=? Right bs - B64U.decodeBase64 (B64U.encodeBase64' bs) @=? Right bs - -alphabetTests :: TestTree -alphabetTests = testGroup "Alphabet tests" - [ base64Tests 0 - , base64Tests 4 - , base64Tests 5 - , base64Tests 6 - , base64Tests 100 - , base64UrlTests 0 - , base64UrlTests 4 - , base64UrlTests 5 - , base64UrlTests 6 - , base64UrlTests 100 - ] - where - base64Tests n = testCase ("Conforms to Base64 alphabet: " ++ show n) $ do - bs <- random n - let b = B64.encodeBase64' bs - assertBool ("failed validity: " ++ show b) $ B64.isValidBase64 b - assertBool ("failed correctness: " ++ show b) $ B64.isBase64 b - - base64UrlTests n = testCase ("Conforms to Base64url alphabet: " ++ show n) $ do - bs <- random n - let b = B64U.encodeBase64' bs - assertBool ("failed validity: " ++ show b) $ B64U.isValidBase64Url b - assertBool ("failed correctness: " ++ show b) $ B64U.isBase64Url b diff --git a/test/Internal.hs b/test/Internal.hs new file mode 100644 --- /dev/null +++ b/test/Internal.hs @@ -0,0 +1,226 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Main +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- This module contains internal test harnesses for `base64` +-- +module Internal where + + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Short as SBS +import "base64" Data.ByteString.Base64 as B64 +import "base64" Data.ByteString.Base64.URL as B64U +import "base64" Data.ByteString.Lazy.Base64 as LB64 +import "base64" Data.ByteString.Lazy.Base64.URL as LB64U +import "base64" Data.ByteString.Short.Base64 as SB64 +import "base64" Data.ByteString.Short.Base64.URL as SB64U +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import "base64" Data.Text.Encoding.Base64 as T64 +import "base64" Data.Text.Encoding.Base64.URL as T64U +import Data.Text.Encoding.Base64.Error (Base64Error(..)) +import qualified Data.Text.Lazy as TL +import "base64" Data.Text.Lazy.Encoding.Base64 as TL64 +import "base64" Data.Text.Lazy.Encoding.Base64.URL as TL64U +import qualified Data.Text.Short as TS +import "base64" Data.Text.Short.Encoding.Base64 as TS64 +import "base64" Data.Text.Short.Encoding.Base64.URL as TS64U + +import Test.QuickCheck hiding (label) +import Test.QuickCheck.Instances + +-- ------------------------------------------------------------------ -- +-- Test Harnesses + +data B64 +data LB64 +data SB64 +data T64 +data TL64 +data TS64 + +-- | This class provides the generic API definition for +-- the base64 std alphabet +-- +class + ( Eq bs + , Show bs + , Arbitrary bs + , CoArbitrary bs + , IsString bs + ) => Harness a bs | a -> bs, bs -> a + where + + label :: String + encode :: bs -> bs + encodeUrl :: bs -> bs + encodeUrlNopad :: bs -> bs + + decode :: bs -> Either Text bs + decodeUrl :: bs -> Either Text bs + decodeUrlPad :: bs -> Either Text bs + decodeUrlNopad :: bs -> Either Text bs + + lenientUrl :: bs -> bs + lenient :: bs -> bs + + correct :: bs -> Bool + correctUrl :: bs -> Bool + validate :: bs -> Bool + validateUrl :: bs -> Bool + + +instance Harness B64 BS.ByteString where + label = "ByteString" + + encode = B64.encodeBase64' + decode = B64.decodeBase64 + lenient = B64.decodeBase64Lenient + correct = B64.isBase64 + validate = B64.isValidBase64 + encodeUrl = B64U.encodeBase64' + encodeUrlNopad = B64U.encodeBase64Unpadded' + decodeUrl = B64U.decodeBase64 + decodeUrlPad = B64U.decodeBase64Padded + decodeUrlNopad = B64U.decodeBase64Unpadded + lenientUrl = B64U.decodeBase64Lenient + correctUrl = B64U.isBase64Url + validateUrl = B64U.isValidBase64Url + +instance Harness LB64 LBS.ByteString where + label = "Lazy ByteString" + + encode = LB64.encodeBase64' + decode = LB64.decodeBase64 + lenient = LB64.decodeBase64Lenient + correct = LB64.isBase64 + validate = LB64.isValidBase64 + encodeUrl = LB64U.encodeBase64' + encodeUrlNopad = LB64U.encodeBase64Unpadded' + decodeUrl = LB64U.decodeBase64 + decodeUrlPad = LB64U.decodeBase64Padded + decodeUrlNopad = LB64U.decodeBase64Unpadded + lenientUrl = LB64U.decodeBase64Lenient + correctUrl = LB64U.isBase64Url + validateUrl = LB64U.isValidBase64Url + +instance Harness SB64 SBS.ShortByteString where + label = "Short ByteString" + + encode = SB64.encodeBase64' + decode = SB64.decodeBase64 + lenient = SB64.decodeBase64Lenient + correct = SB64.isBase64 + validate = SB64.isValidBase64 + encodeUrl = SB64U.encodeBase64' + encodeUrlNopad = SB64U.encodeBase64Unpadded' + decodeUrl = SB64U.decodeBase64 + decodeUrlPad = SB64U.decodeBase64Padded + decodeUrlNopad = SB64U.decodeBase64Unpadded + lenientUrl = SB64U.decodeBase64Lenient + correctUrl = SB64U.isBase64Url + validateUrl = SB64U.isValidBase64Url + +instance Harness T64 Text where + label = "Text" + + encode = T64.encodeBase64 + decode = T64.decodeBase64 + lenient = T64.decodeBase64Lenient + correct = T64.isBase64 + encodeUrl = T64U.encodeBase64 + encodeUrlNopad = T64U.encodeBase64Unpadded + decodeUrl = T64U.decodeBase64 + decodeUrlPad = T64U.decodeBase64Padded + decodeUrlNopad = T64U.decodeBase64Unpadded + lenientUrl = T64U.decodeBase64Lenient + correctUrl = T64U.isBase64Url + validateUrl = T64U.isValidBase64Url + validate = T64.isValidBase64 + +instance Harness TL64 TL.Text where + label = "Lazy Text" + + encode = TL64.encodeBase64 + decode = TL64.decodeBase64 + lenient = TL64.decodeBase64Lenient + correct = TL64.isBase64 + encodeUrl = TL64U.encodeBase64 + encodeUrlNopad = TL64U.encodeBase64Unpadded + decodeUrl = TL64U.decodeBase64 + decodeUrlPad = TL64U.decodeBase64Padded + decodeUrlNopad = TL64U.decodeBase64Unpadded + lenientUrl = TL64U.decodeBase64Lenient + correctUrl = TL64U.isBase64Url + validateUrl = TL64U.isValidBase64Url + validate = TL64.isValidBase64 + +instance Harness TS64 TS.ShortText where + label = "Short Text" + + encode = TS64.encodeBase64 + decode = TS64.decodeBase64 + lenient = TS64.decodeBase64Lenient + correct = TS64.isBase64 + encodeUrl = TS64U.encodeBase64 + encodeUrlNopad = TS64U.encodeBase64Unpadded + decodeUrl = TS64U.decodeBase64 + decodeUrlPad = TS64U.decodeBase64Padded + decodeUrlNopad = TS64U.decodeBase64Unpadded + lenientUrl = TS64U.decodeBase64Lenient + correctUrl = TS64U.isBase64Url + validateUrl = TS64U.isValidBase64Url + validate = TS64.isValidBase64 + +class Harness a cs => TextHarness a cs bs | a -> cs, bs -> cs, cs -> a, cs -> bs where + decodeWith_ :: (bs -> Either err cs) -> bs -> Either (Base64Error err) cs + decodeUrlWith_ :: (bs -> Either err cs) -> bs -> Either (Base64Error err) cs + decodeUrlPaddedWith_ :: (bs -> Either err cs) -> bs -> Either (Base64Error err) cs + decodeUrlUnpaddedWith_ :: (bs -> Either err cs) -> bs -> Either (Base64Error err) cs + +instance TextHarness T64 Text BS.ByteString where + decodeWith_ = T64.decodeBase64With + decodeUrlWith_ = T64U.decodeBase64With + decodeUrlPaddedWith_ = T64U.decodeBase64PaddedWith + decodeUrlUnpaddedWith_ = T64U.decodeBase64UnpaddedWith + +instance TextHarness TL64 TL.Text LBS.ByteString where + decodeWith_ = TL64.decodeBase64With + decodeUrlWith_ = TL64U.decodeBase64With + decodeUrlPaddedWith_ = TL64U.decodeBase64PaddedWith + decodeUrlUnpaddedWith_ = TL64U.decodeBase64UnpaddedWith + +instance TextHarness TS64 TS.ShortText SBS.ShortByteString where + decodeWith_ = TS64.decodeBase64With + decodeUrlWith_ = TS64U.decodeBase64With + decodeUrlPaddedWith_ = TS64U.decodeBase64PaddedWith + decodeUrlUnpaddedWith_ = TS64U.decodeBase64UnpaddedWith + +-- ------------------------------------------------------------------ -- +-- Quickcheck instances + +instance Arbitrary TS.ShortText where + arbitrary = TS.fromText <$> arbitrary + shrink xs = fmap TS.fromText $ shrink (TS.toText xs) + +instance CoArbitrary TS.ShortText where + coarbitrary = coarbitrary . TS.toText + +instance Function TS.ShortText where + function = functionMap + (T.unpack . TS.toText) + (TS.fromText . T.pack) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,445 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Main +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- This module contains the test implementation for the `base64` package +-- +module Main +( main +) where + + +import Prelude hiding (length) + +import Data.Bifunctor (second) +import qualified Data.ByteString as BS +import Data.ByteString.Internal (c2w) +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Short as SBS +import "base64" Data.ByteString.Base64 as B64 +import "base64" Data.ByteString.Base64.URL as B64U +import qualified "base64-bytestring" Data.ByteString.Base64 as Bos +import qualified "base64-bytestring" Data.ByteString.Base64.URL as BosU +import Data.Proxy +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Text.Encoding.Base64.Error (Base64Error(..)) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Text.Short as TS +import Data.Word + +import Internal + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck (testProperty) + + +main :: IO () +main = defaultMain tests + + +tests :: TestTree +tests = testGroup "Base64 Tests" + [ mkTree (Proxy :: Proxy B64) + [ mkPropTree + , mkUnitTree BS.last BS.length + ] + , mkTree (Proxy :: Proxy LB64) + [ mkPropTree + , mkUnitTree LBS.last (fromIntegral . LBS.length) + ] + , mkTree (Proxy :: Proxy SB64) + [ mkPropTree + , mkUnitTree (BS.last . SBS.fromShort) SBS.length + ] + , mkTree (Proxy :: Proxy T64) + [ mkPropTree + , mkUnitTree (c2w . T.last) T.length + , mkDecodeTree T.decodeUtf8' (Proxy :: Proxy B64) + ] + , mkTree (Proxy :: Proxy TL64) + [ mkPropTree + , mkUnitTree (c2w . TL.last) (fromIntegral . TL.length) + , mkDecodeTree TL.decodeUtf8' (Proxy :: Proxy LB64) + ] + , mkTree (Proxy :: Proxy TS64) + [ mkPropTree + , mkUnitTree (c2w . T.last . TS.toText) TS.length + , mkDecodeTree + (second TS.fromText . T.decodeUtf8' . SBS.fromShort) (Proxy :: Proxy SB64) + ] + ] + +-- ---------------------------------------------------------------- -- +-- Test tree generation + +-- | Make a test tree for a given label +-- +mkTree + :: forall a b proxy + . Harness a b + => proxy a + -> [proxy a -> TestTree] + -> TestTree +mkTree a = testGroup (label @a) . fmap ($ a) + +-- | Make a test group with some name, lifting a test tree up to the correct +-- type information via some Harness +-- +mkTests + :: forall a b proxy + . Harness a b + => String + -> [proxy a -> TestTree] + -> proxy a + -> TestTree +mkTests context ts = testGroup context . (<*>) ts . pure + +-- | Make property tests for a given harness instance +-- +mkPropTree :: forall a b proxy. Harness a b => proxy a -> TestTree +mkPropTree = mkTests "Property Tests" + [ prop_roundtrip + , prop_correctness + , prop_url_padding + , const prop_bos_coherence + ] + +-- | Make unit tests for a given harness instance +-- +mkUnitTree + :: forall a b proxy + . Harness a b + => (b -> Word8) + -> (b -> Int) + -> proxy a + -> TestTree +mkUnitTree last_ length_ = mkTests "Unit tests" + [ paddingTests last_ length_ + , rfcVectors + , offsetVectors + ] + +-- | Make unit tests for textual 'decode*With' functions +-- +mkDecodeTree + :: forall t a b c e proxy + . ( TextHarness a b c + , Harness t c + , Show e + ) + => (c -> Either e b) + -> proxy t + -> proxy a + -> TestTree +mkDecodeTree utf8 t = mkTests "Decoding tests" + [ decodeWithVectors utf8 t + ] + +-- ---------------------------------------------------------------- -- +-- Property tests + +prop_roundtrip :: forall a b proxy. Harness a b => proxy a -> TestTree +prop_roundtrip _ = testGroup "prop_roundtrip" + [ testProperty "prop_std_roundtrip" $ \(bs :: b) -> + Right (encode bs) == decode (encode (encode bs)) + , testProperty "prop_url_roundtrip" $ \(bs :: b) -> + Right (encodeUrl bs) == decodeUrl (encodeUrl (encodeUrl bs)) + , testProperty "prop_url_roundtrip_nopad" $ \(bs :: b) -> + Right (encodeUrlNopad bs) + == decodeUrlNopad (encodeUrlNopad (encodeUrlNopad bs)) + , testProperty "prop_std_lenient_roundtrip" $ \(bs :: b) -> + encode bs == lenient (encode (encode bs)) + , testProperty "prop_url_lenient_roundtrip" $ \(bs :: b) -> + encodeUrl bs == lenientUrl (encodeUrl (encodeUrl bs)) + ] + +prop_correctness :: forall a b proxy. Harness a b => proxy a -> TestTree +prop_correctness _ = testGroup "prop_validity" + [ testProperty "prop_std_valid" $ \(bs :: b) -> + validate (encode bs) + , testProperty "prop_url_valid" $ \(bs :: b) -> + validateUrl (encodeUrl bs) + , testProperty "prop_std_correct" $ \(bs :: b) -> + correct (encode bs) + , testProperty "prop_url_correct" $ \(bs :: b) -> + correctUrl (encodeUrl bs) + ] + +prop_url_padding :: forall a b proxy. Harness a b => proxy a -> TestTree +prop_url_padding _ = testGroup "prop_url_padding" + [ testProperty "prop_url_nopad_roundtrip" $ \(bs :: b) -> + Right (encodeUrlNopad bs) + == decodeUrlNopad (encodeUrlNopad (encodeUrlNopad bs)) + + , testProperty "prop_url_pad_roundtrip" $ \(bs :: b) -> + Right (encodeUrl bs) == decodeUrlPad (encodeUrl (encodeUrl bs)) + + , testProperty "prop_url_decode_invariant" $ \(bs :: b) -> + ( decodeUrlNopad (encodeUrlNopad (encodeUrlNopad bs)) + == decodeUrl (encodeUrl (encodeUrl bs)) + ) || + ( decodeUrlPad (encodeUrl (encodeUrl bs)) + == decodeUrl (encodeUrl (encodeUrl bs)) + ) + + -- NOTE: we need to fix the bitmasking issue for "impossible" + -- inputs + + , testProperty "prop_url_padding_coherence" $ \(bs :: b) -> + Right (encodeUrl bs) == decodeUrl (encodeUrl (encodeUrl bs)) + && Right (encodeUrl bs) == decodeUrlPad (encodeUrl (encodeUrl bs)) + + , testProperty "prop_url_nopadding_coherence" $ \(bs :: b) -> + Right (encodeUrlNopad bs) == decodeUrlNopad (encodeUrlNopad (encodeUrlNopad bs)) + && Right (encodeUrlNopad bs) == decodeUrl (encodeUrlNopad (encodeUrlNopad bs)) + ] + +-- | just a sanity check against `base64-bytestring` +-- +prop_bos_coherence :: TestTree +prop_bos_coherence = testGroup "prop_bos_coherence" + [ testProperty "prop_std_bos_coherence" $ \bs -> + Right bs == B64.decodeBase64 (B64.encodeBase64' bs) + && Right bs == Bos.decode (Bos.encode bs) + , testProperty "prop_url_bos_coherence" $ \bs -> + Right bs == B64U.decodeBase64 (B64U.encodeBase64' bs) + && Right bs == BosU.decode (BosU.encode bs) + ] + +-- ---------------------------------------------------------------- -- +-- Unit tests + +-- | RFC 4648 test vectors +-- +rfcVectors :: forall a b proxy. Harness a b => proxy a -> TestTree +rfcVectors _ = testGroup "RFC 4648 Test Vectors" + [ testGroup "std alphabet" + [ testCaseStd "" "" + , testCaseStd "f" "Zg==" + , testCaseStd "f" "Zg==" + , testCaseStd "fo" "Zm8=" + , testCaseStd "foo" "Zm9v" + , testCaseStd "foob" "Zm9vYg==" + , testCaseStd "fooba" "Zm9vYmE=" + , testCaseStd "foobar" "Zm9vYmFy" + ] + , testGroup "url-safe alphabet" + [ testCaseUrl "" "" + , testCaseUrl "<" "PA==" + , testCaseUrl "<<" "PDw=" + , testCaseUrl "<" "PDw_Pz4=" + , testCaseUrl "<>" "PDw_Pz4-" + ] + ] + where + testCaseStd s t = + testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do + step "encode is sound" + t @=? encode @a s + + step "decode is sound" + Right s @=? decode (encode s) + + testCaseUrl s t = + testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do + step "encode is sound" + t @=? encodeUrl @a s + + step "decode is sound" + Right s @=? decodeUrlPad t + +-- | Url-safe padding unit tests (stresses entire alphabet) +-- +paddingTests + :: forall a b proxy + . Harness a b + => (b -> Word8) + -> (b -> Int) + -> proxy a + -> TestTree +paddingTests last_ length_ _ = testGroup "Padding tests" + [ testGroup "URL decodePadding coherence" + [ ptest "<" "PA==" + , ptest "<<" "PDw=" + , ptest "<" "PDw_Pz4=" + , ptest "<>" "PDw_Pz4-" + ] + , testGroup "URL decodeUnpadded coherence" + [ utest "<" "PA" + , utest "<<" "PDw" + , utest "<" "PDw_Pz4" + , utest "<>" "PDw_Pz4-" + ] + , testGroup "url-safe padding case unit tests" + [ testCase "stress arbitarily padded URL strings" $ do + decodeUrl @a "P" @=? Left "Base64-encoded bytestring has invalid size" + decodeUrl @a "PA" @=? Right "<" + decodeUrl @a "PDw" @=? Right "<<" + decodeUrl @a "PDw_" @=? Right "< do + let u = decodeUrlNopad t + v = decodeUrlPad t + + if last_ t == 0x3d then do + step "Padding required: no padding fails" + u @=? Left "Base64-encoded bytestring has invalid padding" + + step "Padding required: padding succeeds" + v @=? Right s + else do + step "String has no padding: decodes should coincide" + u @=? Right s + v @=? Right s + v @=? u + + utest s t = + testCaseSteps (show $ if t == "" then "empty" else t) $ \step -> do + let u = decodeUrlPad t + v = decodeUrlNopad t + + if length_ t `mod` 4 == 0 then do + step "String has no padding: decodes should coincide" + u @=? Right s + v @=? Right s + v @=? u + else do + step "Unpadded required: padding fails" + u @=? Left "Base64-encoded bytestring requires padding" + + step "Unpadded required: unpadding succeeds" + v @=? Right s + +-- | Offset test vectors. This stresses the invalid char + incorrect padding +-- offset error messages +-- +offsetVectors :: forall a b proxy. Harness a b => proxy a -> TestTree +offsetVectors _ = testGroup "Offset tests" + [ testCase "Invalid staggered padding" $ do + decodeUrl @a "=A==" @=? Left "invalid padding at offset: 0" + decodeUrl @a "P===" @=? Left "invalid padding at offset: 1" + , testCase "Invalid character coverage - final chunk" $ do + decodeUrl @a "%D==" @=? Left "invalid character at offset: 0" + decodeUrl @a "P%==" @=? Left "invalid character at offset: 1" + decodeUrl @a "PD%=" @=? Left "invalid character at offset: 2" + decodeUrl @a "PA=%" @=? Left "invalid character at offset: 3" + decodeUrl @a "PDw%" @=? Left "invalid character at offset: 3" + , testCase "Invalid character coverage - decode chunk" $ do + decodeUrl @a "%Dw_PDw_" @=? Left "invalid character at offset: 0" + decodeUrl @a "P%w_PDw_" @=? Left "invalid character at offset: 1" + decodeUrl @a "PD%_PDw_" @=? Left "invalid character at offset: 2" + decodeUrl @a "PDw%PDw_" @=? Left "invalid character at offset: 3" + , testCase "Invalid padding in body" $ do + decodeUrl @a "PD=_PDw_" @=? Left "invalid padding at offset: 2" + decodeUrl @a "PDw=PDw_" @=? Left "invalid padding at offset: 3" + , testCase "Padding fails everywhere but end" $ do + decode @a "=eAoeAo=" @=? Left "invalid padding at offset: 0" + decode @a "e=AoeAo=" @=? Left "invalid padding at offset: 1" + decode @a "eA=oeAo=" @=? Left "invalid padding at offset: 2" + decode @a "eAo=eAo=" @=? Left "invalid padding at offset: 3" + decode @a "eAoe=Ao=" @=? Left "invalid padding at offset: 4" + decode @a "eAoeA=o=" @=? Left "invalid padding at offset: 5" + ] + +-- | Unit test trees for the `decode*With` family of text-valued functions +-- +decodeWithVectors + :: forall t a b c e proxy + . ( TextHarness a c b + , Harness t b + , Show e + ) + => (b -> Either e c) + -- ^ utf8 + -> proxy t + -- ^ witness to the bytestring-ey dictionaries + -> proxy a + -- ^ witness to the text dictionaries + -> TestTree +decodeWithVectors utf8 _ _ = testGroup "DecodeWith* unit tests" + [ testGroup "decodeWith negative tests" + [ testCase "decodeWith non-utf8 inputs on decodeUtf8" $ do + case decodeWith_ @a utf8 "\1079743" of + Left (DecodeError _) -> return () + _ -> assertFailure "decoding phase" + , testCase "decodeWith valid utf8 inputs on decodeUtf8" $ do + case decodeWith_ @a utf8 (encode @t "\1079743") of + Left (ConversionError _) -> return () + _ -> assertFailure "conversion phase" + , testCase "decodeUrlWith non-utf8 inputs on decodeUtf8" $ do + case decodeUrlWith_ @a utf8 "\1079743" of + Left (DecodeError _) -> return () + _ -> assertFailure "decoding phase" + , testCase "decodeUrlWith valid utf8 inputs on decodeUtf8" $ do + case decodeUrlWith_ @a utf8 (encodeUrl @t "\1079743") of + Left (ConversionError _) -> return () + _ -> assertFailure "conversion phase" + , testCase "decodeUrlPaddedWith non-utf8 inputs on decodeUtf8" $ do + case decodeUrlPaddedWith_ @a utf8 "\1079743" of + Left (DecodeError _) -> return () + _ -> assertFailure "decoding phase" + , testCase "decodePaddedWith valid utf8 inputs on decodeUtf8" $ do + case decodeUrlPaddedWith_ @a utf8 (encodeUrl @t "\1079743") of + Left (ConversionError _) -> return () + _ -> assertFailure "conversion phase" + , testCase "decodeUnpaddedWith non-utf8 inputs on decodeUtf8" $ do + case decodeUrlUnpaddedWith_ @a utf8 "\1079743" of + Left (DecodeError _) -> return () + _ -> assertFailure "decoding phase" + , testCase "decodeUnpaddedWith valid utf8 inputs on decodeUtf8" $ do + case decodeUrlUnpaddedWith_ @a utf8 (encodeUrlNopad @t "\1079743") of + Left (ConversionError _) -> return () + _ -> assertFailure "conversion phase" + ] + , testGroup "decodeWith positive tests" + [ testCase "decodeWith utf8 inputs on decodeUtf8" $ do + a <- either (assertFailure . show) pure $ decode @a "Zm9vYmFy" + b <- either (assertFailure . show) pure $ decodeWith_ @a utf8 "Zm9vYmFy" + a @=? b + , testCase "decodeUrlWith utf8 inputs on decodeUtf8" $ do + a <- either (assertFailure . show) pure $ decodeUrl @a "PDw_Pz4-" + b <- either (assertFailure . show) pure $ decodeUrlWith_ @a utf8 "PDw_Pz4-" + a @=? b + , testCase "decodeUrlPaddedWith utf8 inputs on decodeUtf8" $ do + a <- either (assertFailure . show) pure $ decodeUrlPad @a "PDw_Pz4-" + b <- either (assertFailure . show) pure $ decodeUrlPaddedWith_ @a utf8 "PDw_Pz4-" + a @=? b + , testCase "decodeUrlUnpaddedWith utf8 inputs on decodeUtf8" $ do + a <- either (assertFailure . show) pure $ decodeUrlNopad @a "PDw_Pz4-" + b <- either (assertFailure . show) pure $ decodeUrlUnpaddedWith_ @a utf8 "PDw_Pz4-" + a @=? b + ] + ]