base64 (empty) → 0.0.1.0
raw patch · 14 files changed
+1159/−0 lines, 14 filesdep +basedep +base64dep +base64-bytestringsetup-changed
Dependencies added: base, base64, base64-bytestring, bytestring, criterion, deepseq, lens, memory, random-bytestring, tasty, tasty-hunit, text
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +51/−0
- Setup.hs +2/−0
- base64.cabal +102/−0
- benchmarks/Base64Bench.hs +97/−0
- src/Data/ByteString/Base64.hs +66/−0
- src/Data/ByteString/Base64/Internal.hs +373/−0
- src/Data/ByteString/Base64/Lens.hs +105/−0
- src/Data/ByteString/Base64/URL.hs +61/−0
- src/Data/Text/Encoding/Base64.hs +66/−0
- src/Data/Text/Encoding/Base64/Lens.hs +56/−0
- src/Data/Text/Encoding/Base64/URL.hs +65/−0
- test/Base64Tests.hs +80/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for base64++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, Emily Pillmore++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Emily Pillmore nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,51 @@+# Base64++[](https://travis-ci.com/emilypi/base64)++Padded and unpadded base64 and base64url encodings for `Text` and `ByteString` values, along with their optics.+++### Why?++Haskell has two main libraries for Base64: `memory`, and `base64-bytestring`.++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 percieved 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), and also supplying some nice compositional optics for composing structures with Base64-encodable/decodable focii (neither libraries provide).++### Optics++Structs may want to support encoding and decoding their substructures, which is supported with the following prismatic typeclass:++```haskell+class AsBase64 s where+ type Base64 s+ -- | A prism into a base64-encoded focus of+ -- some type+ --+ _Base64 :: Prism' s (Base64 s)++ -- | A prism into the base64url-encoded focus of+ -- some type+ --+ _Base64Url :: Prism' s (Base64 s)+```++The data of a `Prism` naturally conforms to this "encoding/decoding" dichotomy, where the `Review`, or "builder" half of the `Prism` of type `b -> t` is an encoding, and the "Matcher" half of the prism, of type `s -> Either t a`, represents a decoding of a similar structure. Monomorphizing for `t ~ s` and `a ~ b`, a simple `Prism` is formed:++```haskell+>>> _Base64 @Text # "<<???>>"+"PDw/Pz8+Pg=="++>>> "PDw/Pz8+Pg==" ^? _Base64 @Text+Just "<<???>>"+```++The two most obvious types for which we have an instance are those that are supported natively by the library: `ByteString` and `Text`. Trivially, their instances consist of the functions provided here in this library.++### Summary++What does this library provide? Here is the summary:++- Better performance over existing Base64 libraries (2x and 3x for most use-cases - see [PERFORMANCE.md](benchmarks/PERFORMANCE.md))+- Support for unpadded Base64 and Base64-url+- Support for `Text` encodings and decodings+- Classy optics for handling more complex structures with Base64 representations
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ base64.cabal view
@@ -0,0 +1,102 @@+cabal-version: 2.4++name: base64+version: 0.0.1.0+synopsis: RFC 4648-compliant padded and unpadded base64 and base64url encodings+description:+ RFC 4648-compliant padded and unpadded base64 and base64url encoding and decoding.+homepage: https://github.com/emilypi/base64+bug-reports: https://github.com/emilypi/base64/issues+license: BSD-3-Clause+license-file: LICENSE+author: Emily Pillmore+maintainer: emilypi@cohomolo.gy+copyright: (c) 2019 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.0.2++source-repository head+ type: git+ location: https://github.com/emilypi/base64.git+++flag optics+ description: Enable optics for base64-encoding text and bytestrings+ manual: True+ default: True++flag perf-flags+ description: Performance tuning flags and information+ manual: True+ default: False+++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++ build-depends: base >=4.9 && <5+ , bytestring+ , deepseq+ , text++ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -Wall++ if flag(optics)+ exposed-modules: Data.ByteString.Base64.Lens+ , Data.Text.Encoding.Base64.Lens+ build-depends: lens ^>= 4.18++ if flag(perf-flags)+ ghc-options: -ddump-simpl+ -ddump-to-file+ -ddump-stranal+++test-suite tasty+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Base64Tests.hs+ build-depends: base >=4.9 && <5+ , base64+ , base64-bytestring+ , random-bytestring+ , tasty+ , tasty-hunit+ , text++ 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.9 && <5+ , base64+ , base64-bytestring+ , bytestring+ , deepseq+ , criterion+ , memory+ , random-bytestring+ , text++ ghc-options:+ -Wall+ -threaded+ -rtsopts+ -with-rtsopts=-N
+ benchmarks/Base64Bench.hs view
@@ -0,0 +1,97 @@+{-# LANGUAGE AllowAmbiguousTypes #-}+{-# LANGUAGE DataKinds #-}+{-# LANGUAGE FlexibleContexts #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE KindSignatures #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE TypeFamilies #-}+module Main+( main+) where+++import Control.DeepSeq++import Criterion+import Criterion.Main++import "memory" Data.ByteArray.Encoding as Mem+import Data.ByteString+import "base64-bytestring" Data.ByteString.Base64 as Bos+import "base64" Data.ByteString.Base64 as B64+import Data.ByteString.Random (random)+import Data.Kind+import Data.Text (Text)+import qualified Data.Text.Encoding.Base64 as B64T+++main :: IO ()+main = defaultMain $ fmap benchN [25,100,1000,10000,100000]+ where+ benchN n = env (random n) $ bgroup (show n) . bgroup_+ bgroup_ e =+ [ bgroup "encode"+ [ encodeBench @'Mem e+ , encodeBench @'Bos e+ , encodeBench @'B64 e+ ]+ -- , bgroup "base64 decode"+ -- [ decodeBench @'Mem e+ -- , decodeBench @'Bos e+ -- , decodeBench @'B64 e+ -- ]+ ]++encodeBench :: forall a. Harness a => Base64 a -> Benchmark+encodeBench = bench (label @a) . nf (encoder @a)++decodeBench :: forall a. Harness a => Base64 a -> Benchmark+decodeBench = bench (label @a) . nf (decoder @a)+++data Bench where+ Mem :: Bench+ Bos :: Bench+ B64 :: Bench+ T64 :: Bench++class (NFData (Base64 a), NFData (Err a)) => Harness (a :: Bench) where+ type Base64 a :: Type+ type Err a :: Type+ label :: String+ encoder :: Base64 a -> Base64 a+ decoder :: Base64 a -> Either (Err a) (Base64 a)++instance Harness 'Mem where+ type Base64 'Mem = ByteString+ type Err 'Mem = String+ label = "memory"+ encoder = Mem.convertToBase Mem.Base64+ decoder = Mem.convertFromBase Mem.Base64++instance Harness 'Bos where+ type Base64 'Bos = ByteString+ type Err 'Bos = String+ label = "base64-bytestring"+ encoder = Bos.encode+ decoder = Bos.decode++instance Harness 'B64 where+ type Base64 'B64 = ByteString+ type Err 'B64 = Text+ label = "base64"+ encoder = B64.encodeBase64+ decoder = B64.decodeBase64++instance Harness 'T64 where+ type Base64 'T64 = Text+ type Err 'T64 = Text+ label = "base64-text"+ encoder = B64T.encodeBase64+ decoder = B64T.decodeBase64
+ src/Data/ByteString/Base64.hs view
@@ -0,0 +1,66 @@+-- |+-- Module : Data.ByteString.Base64+-- Copyright : (c) 2019 Emily Pillmore+-- License : BSD-style+--+-- Maintainer : Emily Pillmore <emilypi@cohomolo.gy>+-- 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.Base64+( encodeBase64+, decodeBase64+, encodeBase64Unpadded+, decodeBase64Unpadded+) where+++import Data.ByteString (ByteString)+import Data.ByteString.Base64.Internal+import Data.Text (Text)+++-- | Encode a 'ByteString' in base64 with padding.+--+-- See: RFC-4648 section 4+--+encodeBase64 :: ByteString -> ByteString+encodeBase64 = encodeB64Padded base64Table+{-# INLINE encodeBase64 #-}++-- | Decode a padded base64-encoded 'ByteString'+--+-- See: RFC-4648 section 4+--+decodeBase64 :: ByteString -> Either Text ByteString+decodeBase64 = decodeB64 decodeB64Table+{-# INLINE decodeBase64 #-}++-- | Encode a 'ByteString' in base64 without padding.+--+-- Note: in some circumstances, the use of padding ("=") in base-encoded data+-- is not required or used. This is not one of them. If you are absolutely sure+-- the length of your bytestring is divisible by 3, this function will be the same+-- as 'encodeBase64' with padding, however, if not, you may see garbage appended to+-- your bytestring in the form of "\NUL".+--+-- Only call unpadded variants when you can make assumptions about the length of+-- your input data.+--+-- See: RFC-4648 section 3.2+--+encodeBase64Unpadded :: ByteString -> ByteString+encodeBase64Unpadded = encodeB64Unpadded base64Table+{-# INLINE encodeBase64Unpadded #-}++-- | Decode an unpadded base64-encoded 'ByteString'+--+-- See: RFC-4648 section 3.2+--+decodeBase64Unpadded :: ByteString -> Either Text ByteString+decodeBase64Unpadded = decodeB64 decodeB64Table+{-# INLINE decodeBase64Unpadded #-}
+ src/Data/ByteString/Base64/Internal.hs view
@@ -0,0 +1,373 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module : Data.ByteString.Base64.Internal+-- Copyright : (c) 2019 Emily Pillmore+-- License : BSD-style+--+-- Maintainer : Emily Pillmore <emilypi@cohomolo.gy>+-- Stability : Experimental+-- Portability : portable+--+-- Internal module defining the encoding and decoding+-- processes and tables.+--+module Data.ByteString.Base64.Internal+( -- * Base64 encoding+ encodeB64Padded+, encodeB64Unpadded++ -- * Base64 decoding+, decodeB64++ -- * Decoding Tables+ -- ** Standard+, decodeB64Table+ -- ** Base64-url+, decodeB64UrlTable++ -- * Encoding Tables+ -- ** Standard+, base64Table++ -- ** Base64-url+, base64UrlTable+) where+++import Data.Bits+import Data.ByteString (ByteString)+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)++-- | Allocate and fill @n@ bytes with some data+--+writeNPlainForeignPtrBytes+ :: ( Storable a+ , Storable b+ )+ => Int+ -> [a]+ -> ForeignPtr b+writeNPlainForeignPtrBytes !n as = unsafeDupablePerformIO $ do+ fp <- mallocPlainForeignPtrBytes n+ withForeignPtr fp $ \p -> go p as+ return (castForeignPtr fp)+ where+ go !_ [] = return ()+ go !p (x:xs) = poke p x >> go (plusPtr p 1) xs++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)+{-# INLINE packTable #-}++base64UrlTable :: EncodingTable+base64UrlTable = packTable "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789-_"#+{-# NOINLINE base64UrlTable #-}++base64Table :: EncodingTable+base64Table = packTable "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"#+{-# NOINLINE base64Table #-}+++-- -------------------------------------------------------------------------- --+-- Unpadded Base64++encodeB64Unpadded :: EncodingTable -> ByteString -> ByteString+encodeB64Unpadded (EncodingTable _ !efp) (PS sfp !soff !slen) =+ unsafeCreate dlen $ \dptr ->+ withForeignPtr sfp $ \sptr ->+ withForeignPtr efp $ \eptr ->+ encodeB64UnpaddedInternal+ eptr+ (plusPtr sptr soff)+ (castPtr dptr)+ (plusPtr sptr (soff + slen))+ where+ !dlen = 4 * ((slen + 2) `div` 3)+{-# INLINE encodeB64Unpadded #-}++-- | Unpadded Base64. The implicit assumption is that the input+-- data has a length that is a multiple of 3+--+encodeB64UnpaddedInternal+ :: Ptr Word16+ -> Ptr Word8+ -> Ptr Word16+ -> Ptr Word8+ -> IO ()+encodeB64UnpaddedInternal etable sptr dptr end = go sptr dptr+ where+ w32 :: Word8 -> Word32+ w32 i = fromIntegral i+ {-# INLINE w32 #-}++ go !src !dst+ | src >= end = return ()+ | 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 encodeB64UnpaddedInternal #-}++-- -------------------------------------------------------------------------- --+-- Padded Base64++encodeB64Padded :: EncodingTable -> ByteString -> ByteString+encodeB64Padded (EncodingTable !aptr !efp) (PS !sfp !soff !slen) =+ unsafeCreate dlen $ \dptr ->+ withForeignPtr sfp $ \sptr ->+ withForeignPtr efp $ \eptr ->+ encodeB64PaddedInternal+ aptr+ eptr+ (plusPtr sptr soff)+ (castPtr dptr)+ (plusPtr sptr (soff + slen))+ where+ dlen :: Int+ !dlen = 4 * ((slen + 2) `div` 3)+{-# INLINE encodeB64Padded #-}++encodeB64PaddedInternal+ :: Ptr Word8+ -> Ptr Word16+ -> Ptr Word8+ -> Ptr Word16+ -> Ptr Word8+ -> IO ()+encodeB64PaddedInternal (Ptr !alpha) !etable !sptr !dptr !end = go sptr dptr+ where+ ix (W8# i) = W8# (indexWord8OffAddr# alpha (word2Int# i))+ {-# INLINE ix #-}++ w32 :: Word8 -> Word32+ w32 = fromIntegral+ {-# INLINE w32 #-}++ go !src !dst+ | plusPtr src 2 >= end = finalize src (castPtr dst)+ | otherwise = do++ -- ideally, we want to do single read @uint32_t w = src[0..3]@ and simply+ -- discard the upper bits. TODO.+ --+ !i <- w32 <$> peek src+ !j <- w32 <$> peek (plusPtr src 1)+ !k <- w32 <$> peek (plusPtr src 2)++ -- pack 3 'Word8's into a the first 24 bits of a 'Word32'+ --+ let !w = (shiftL i 16) .|. (shiftL j 8) .|. k++ -- ideally, we'd want to pack this is in a single read, then+ -- a single write+ --+ !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)+++ finalize :: Ptr Word8 -> Ptr Word8 -> IO ()+ finalize !src !dst+ | src == end = return ()+ | otherwise = do+ !k <- peekByteOff src 0++ let !a = shiftR (k .&. 0xfc) 2+ !b = shiftL (k .&. 0x03) 4++ pokeByteOff dst 0 (ix a)++ if plusPtr src 2 == end+ then do+ !k' <- peekByteOff src 1++ let !b' = shiftR (k' .&. 0xf0) 4 .|. b+ !c' = shiftL (k' .&. 0x0f) 2++ -- ideally, we'd want to pack these is in a single write+ --+ pokeByteOff dst 1 (ix b')+ pokeByteOff dst 2 (ix c')+ else do+ pokeByteOff dst 1 (ix b)+ pokeByteOff @Word8 dst 2 0x3d++ pokeByteOff @Word8 dst 3 0x3d+{-# INLINE encodeB64PaddedInternal #-}++-- -------------------------------------------------------------------------- --+-- Decoding Base64++-- | 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 #-}++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 #-}++decodeB64 :: ForeignPtr Word8 -> ByteString -> Either Text ByteString+decodeB64 !dtfp (PS !sfp !soff !slen)+ | r /= 0 = Left "invalid padding"+ | otherwise = unsafeDupablePerformIO $+ withForeignPtr dtfp $ \dtable ->+ withForeignPtr sfp $ \sptr -> do+ dfp <- mallocPlainForeignPtrBytes dlen+ withForeignPtr dfp $ \dptr ->+ decodeB64Internal+ dtable+ (plusPtr sptr soff)+ dptr+ (plusPtr sptr (soff + slen))+ dfp+ where+ (!q, !r) = divMod slen 4+ !dlen = q * 3+{-# INLINE decodeB64 #-}++decodeB64Internal+ :: 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 (Either Text ByteString)+decodeB64Internal !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)+ {-# INLINE look #-}++ 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 (src `minusPtr` sptr)+ else+ if a .|. b .|. c .|. d == 0xff+ then err+ $ "invalid base64 encoding near offset: "+ ++ show (src `minusPtr` sptr)+ else do+ let !w = (a `shiftL` 18)+ .|. (b `shiftL` 12)+ .|. (c `shiftL` 6)+ .|. d++ poke @Word8 dst (fromIntegral (w `shiftR` 16))+ if c == 0x63+ then finalize (n + 1)+ else do+ poke @Word8 (dst `plusPtr` 1) (fromIntegral (w `shiftR` 8))+ if d == 0x63+ then finalize (n + 2)+ else do+ poke @Word8 (dst `plusPtr` 2) (fromIntegral w)+ go (dst `plusPtr` 3) (src `plusPtr` 4) (n + 3)+{-# INLINE decodeB64Internal #-}
+ src/Data/ByteString/Base64/Lens.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Data.Text.Encoding.Base64.Lens+-- Copyright : (c) 2019 Emily Pillmore+-- License : BSD-style+--+-- Maintainer : Emily Pillmore <emilypi@cohomolo.gy>+-- Stability : Experimental+-- Portability : TypeFamilies+--+-- This module contains the 'AsBase64' instance for @Text@, which is+-- defined to be the collection of 'Control.Lens.Type.Prism's defining the+-- RFC 4648 specification for the Base64 encoding format.+--+-- In order to expose this file, you must build the package with+-- '-foptics' enabled.+--+module Data.ByteString.Base64.Lens+( -- * Classy Prisms+ AsBase64(..)+, AsBase64Unpadded(..)+) where+++import Control.Lens++import Data.ByteString (ByteString)+import qualified Data.ByteString.Base64 as B64+import qualified Data.ByteString.Base64.URL as B64U+++-- | If a particular type @s@ has a base64 representation+-- for any of its focii, this class provides the optical interface+-- for satisfying the padded base64 spec in RFC 4648+--+class AsBase64 s where+ type Base64 s+ -- | A prism into a base64-encoded focus of+ -- some type+ --+ -- Examples:+ --+ -- >>> _Base64 @Text # "Sun"+ -- "UV3u"+ -- --+ -- >>> "PDw/Pz8+Pg==" ^? _Base64+ -- Just "<<???>>"+ --+ _Base64 :: Prism' s (Base64 s)++ -- | A prism into the base64url-encoded focus of+ -- some type+ --+ -- Examples:+ --+ -- >>> _Base64Url @Text # "Sun"+ -- "UV3u"+ --+ -- >>> "PDw_Pz8-Pg==" ^? _Base64Url+ -- Just "<<???>>"+ --+ _Base64Url :: Prism' s (Base64 s)++-- | If a particular type @a@ has an unpadded base64 representation+-- for any of its focii, this class provides the optical interface+-- for satisfying the unpadded base64 spec in RFC 4648+--+class AsBase64Unpadded s where+ type Base64Unpadded s+ -- | A prism into the unpadded base64-encoded focus of+ -- some type+ --+ _Base64Unpadded :: Prism' s (Base64Unpadded s)++ -- | A prism into the unpadded base64url-encoded focus of+ -- some type+ --+ _Base64UrlUnpadded :: Prism' s (Base64Unpadded s)+++instance AsBase64 ByteString where+ type Base64 ByteString = ByteString++ _Base64 = prism' B64.encodeBase64 $ \s -> case B64.decodeBase64 s of+ Left _ -> Nothing+ Right a -> Just a+ {-# INLINE _Base64 #-}++ _Base64Url = prism' B64U.encodeBase64 $ \s -> case B64U.decodeBase64 s of+ Left _ -> Nothing+ Right a -> Just a+ {-# INLINE _Base64Url #-}++instance AsBase64Unpadded ByteString where+ type Base64Unpadded ByteString = ByteString++ _Base64Unpadded = prism' B64.encodeBase64 $ \s -> case B64U.decodeBase64 s of+ Left _ -> Nothing+ Right a -> Just a+ {-# INLINE _Base64Unpadded #-}++ _Base64UrlUnpadded = prism' B64.encodeBase64 $ \s -> case B64U.decodeBase64Unpadded s of+ Left _ -> Nothing+ Right a -> Just a+ {-# INLINE _Base64UrlUnpadded #-}
+ src/Data/ByteString/Base64/URL.hs view
@@ -0,0 +1,61 @@+-- |+-- Module : Data.ByteString.Base64.URL+-- Copyright : (c) 2019 Emily Pillmore+-- License : BSD-style+--+-- Maintainer : Emily Pillmore <emilypi@cohomolo.gy>+-- 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.ByteString.Base64.URL+( encodeBase64+, decodeBase64+, encodeBase64Unpadded+, decodeBase64Unpadded+) where++import Data.ByteString (ByteString)+import Data.ByteString.Base64.Internal+import Data.Text (Text)+++-- | Encode a 'ByteString' in base64-url with padding.+--+-- See: RFC-4648 section 5+--+encodeBase64 :: ByteString -> ByteString+encodeBase64 = encodeB64Padded base64UrlTable++-- | Decode a padded base64-url encoded 'ByteString'+--+-- See: RFC-4648 section 4+--+decodeBase64 :: ByteString -> Either Text ByteString+decodeBase64 = decodeB64 decodeB64UrlTable++-- | Encode a 'ByteString' in base64-url without padding.+--+-- Note: in some circumstances, the use of padding ("=") in base-encoded data+-- is not required or used. If you are absolutely sure the length of your+-- input data is divisible by 3, this function will be the same as 'encodeBase64'+-- with padding. However, if not, you may see garbage appended to output in the+-- form of "\NUL".+--+-- Only call unpadded variants when you can make assumptions about the length of+-- your input data.+--+-- See: RFC-4648 section 3.2+--+encodeBase64Unpadded :: ByteString -> ByteString+encodeBase64Unpadded = encodeB64Unpadded base64UrlTable++-- | Decode an unpadded base64-url encoded 'ByteString'+--+-- See: RFC-4648 section 4+--+decodeBase64Unpadded :: ByteString -> Either Text ByteString+decodeBase64Unpadded = decodeB64 decodeB64UrlTable
+ src/Data/Text/Encoding/Base64.hs view
@@ -0,0 +1,66 @@+-- |+-- Module : Data.Text.Encoding.Base64+-- Copyright : (c) 2019 Emily Pillmore+-- License : BSD-style+--+-- Maintainer : Emily Pillmore <emilypi@cohomolo.gy>+-- 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.Encoding.Base64+( encodeBase64+, decodeBase64+, encodeBase64Unpadded+, decodeBase64Unpadded+) where+++import qualified Data.ByteString.Base64 as B64++import Data.Text (Text)+import qualified Data.Text.Encoding as T++-- | Encode 'Text' in base64 with padding.+--+-- See: RFC-4648 section 5+--+encodeBase64 :: Text -> Text+encodeBase64 = T.decodeUtf8 . B64.encodeBase64 . T.encodeUtf8++-- | Decode a padded base64 encoded 'Text' value+--+-- See: RFC-4648 section 4+--+decodeBase64 :: Text -> Either Text Text+decodeBase64 = fmap T.decodeUtf8 . B64.decodeBase64 . T.encodeUtf8++-- | Encode a 'Text' in base64 without padding.+--+-- Note: in some circumstances, the use of padding ("=") in base-encoded data+-- is not required or used. If you are absolutely sure the length of your+-- input data is divisible by 3, this function will be the same as 'encodeBase64'+-- with padding. However, if not, you may see garbage appended to output in the+-- form of "\NUL".+--+-- Only call unpadded variants when you can make assumptions about the length of+-- your input data.+--+-- See: RFC-4648 section 3.2+--+encodeBase64Unpadded :: Text -> Text+encodeBase64Unpadded = T.decodeUtf8+ . B64.encodeBase64Unpadded+ . T.encodeUtf8++-- | Decode an unpadded base64 encoded 'Text'+--+-- See: RFC-4648 section 4+--+decodeBase64Unpadded :: Text -> Either Text Text+decodeBase64Unpadded = fmap T.decodeUtf8+ . B64.decodeBase64Unpadded+ . T.encodeUtf8
+ src/Data/Text/Encoding/Base64/Lens.hs view
@@ -0,0 +1,56 @@+{-# OPTIONS_GHC -fno-warn-orphans #-}+{-# LANGUAGE TypeFamilies #-}+-- |+-- Module : Data.Text.Encoding.Base64.Lens+-- Copyright : (c) 2019 Emily Pillmore+-- License : BSD-style+--+-- Maintainer : Emily Pillmore <emilypi@cohomolo.gy>+-- Stability : Experimental+-- Portability : TypeFamilies+--+-- This module contains the 'AsBase64' and 'AsBase64Unpadded' instances+-- for 'Text', which defined to be the collection of 'Control.Lens.Type.Prism's defining the+-- RFC 4648 specification for the padded and unpadded Base64 encoding format.+--+-- These typeclasses are re-exported for convenience+--+module Data.Text.Encoding.Base64.Lens+( AsBase64(..)+, AsBase64Unpadded(..)+) where+++import Control.Lens++import Data.Text (Text)+import Data.ByteString.Base64.Lens+import qualified Data.Text.Encoding.Base64 as B64T+import qualified Data.Text.Encoding.Base64.URL as B64TU+++instance AsBase64 Text where+ type Base64 Text = Text++ _Base64 = prism' B64T.encodeBase64 $ \s -> case B64T.decodeBase64 s of+ Left _ -> Nothing+ Right a -> Just a+ {-# INLINE _Base64 #-}++ _Base64Url = prism' B64TU.encodeBase64 $ \s -> case B64TU.decodeBase64 s of+ Left _ -> Nothing+ Right a -> Just a+ {-# INLINE _Base64Url #-}++instance AsBase64Unpadded Text where+ type Base64Unpadded Text = Text++ _Base64Unpadded = prism' B64T.encodeBase64 $ \s -> case B64T.decodeBase64 s of+ Left _ -> Nothing+ Right a -> Just a+ {-# INLINE _Base64Unpadded #-}++ _Base64UrlUnpadded = prism' B64TU.encodeBase64 $ \s -> case B64TU.decodeBase64Unpadded s of+ Left _ -> Nothing+ Right a -> Just a+ {-# INLINE _Base64UrlUnpadded #-}
+ src/Data/Text/Encoding/Base64/URL.hs view
@@ -0,0 +1,65 @@+-- |+-- Module : Data.Text.Encoding.Base64.URL+-- Copyright : (c) 2019 Emily Pillmore+-- License : BSD-style+--+-- Maintainer : Emily Pillmore <emilypi@cohomolo.gy>+-- 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.Encoding.Base64.URL+( encodeBase64+, decodeBase64+, encodeBase64Unpadded+, decodeBase64Unpadded+) where+++import qualified Data.ByteString.Base64.URL as B64U++import Data.Text (Text)+import qualified Data.Text.Encoding as T++-- | Encode a 'Text' in base64-url with padding.+--+-- See: RFC-4648 section 5+--+encodeBase64 :: Text -> Text+encodeBase64 = T.decodeUtf8 . B64U.encodeBase64 . T.encodeUtf8++-- | Decode a padded base64-url encoded 'Text'+--+-- See: RFC-4648 section 4+--+decodeBase64 :: Text -> Either Text Text+decodeBase64 = fmap T.decodeUtf8 . B64U.decodeBase64 . T.encodeUtf8++-- | Encode a 'Text' value in base64-url without padding.+--+-- Note: in some circumstances, the use of padding ("=") in base-encoded data+-- is not required or used. If you are absolutely sure the length of your+-- input data is divisible by 3, this function will be the same as 'encodeBase64'+-- with padding. However, if not, you may see garbage appended to output in the+-- form of "\NUL".+--+-- Only call unpadded variants when you can make assumptions about the length of+-- your input data.+--+-- See: RFC-4648 section 3.2+--+encodeBase64Unpadded :: Text -> Text+encodeBase64Unpadded = T.decodeUtf8+ . B64U.encodeBase64Unpadded+ . T.encodeUtf8++-- | Decode an unpadded base64-url encoded 'Text' value+--+-- See: RFC-4648 section 4+--+decodeBase64Unpadded :: Text -> Either Text Text+decodeBase64Unpadded = fmap T.decodeUtf8+ . B64U.decodeBase64Unpadded+ . T.encodeUtf8
+ test/Base64Tests.hs view
@@ -0,0 +1,80 @@+{-# 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 qualified Data.Text as T+import qualified Data.Text.Encoding as T++import Test.Tasty+import Test.Tasty.HUnit+++main :: IO ()+main = defaultMain tests+++tests :: TestTree+tests = testGroup "Base64 Tests"+ [ testVectors+ , sanityTests+ ]++testVectors :: TestTree+testVectors = testGroup "RFC 4648 Test Vectors"+ [ testCaseB64 "" ""+ , testCaseB64 "f" "Zg=="+ , testCaseB64 "fo" "Zm8="+ , testCaseB64 "foo" "Zm9v"+ , testCaseB64 "foob" "Zm9vYg=="+ , testCaseB64 "fooba" "Zm9vYmE="+ , testCaseB64 "foobar" "Zm9vYmFy"+ ]+ where+ testCaseB64 s t =+ testCase (T.unpack $ if s == "" then "empty" else s) $+ t @=? B64.encodeBase64 (T.encodeUtf8 s)++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