base64-bytes (empty) → 0.1.0.0

raw patch · 7 files changed

+466/−0 lines, 7 filesdep +basedep +base64dep +base64-bytessetup-changed

Dependencies added: base, base64, base64-bytes, base64-bytestring, byte-order, bytebuild, byteslice, bytestring, gauge, natural-arithmetic, primitive, random, run-st, small-bytearray-builder

Files

CHANGELOG.md +5/−0
LICENSE +28/−0
Setup.hs +2/−0
base64-bytes.cabal +60/−0
bench/Main.hs +78/−0
src/Data/Bytes/Base64.hs +213/−0
test/Main.hs +80/−0

+ CHANGELOG.md view

@@ -0,0 +1,5 @@+# Revision history for base64-bytes++## 0.1.0.0 -- 2020-06-01++* Initial release.

+ LICENSE view

@@ -0,0 +1,28 @@+Copyright 2020 Andrew Martin++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions+are met:++1. Redistributions of source code must retain the above copyright notice,+this list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+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+HOLDER 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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ base64-bytes.cabal view

@@ -0,0 +1,60 @@+cabal-version: 2.2+name: base64-bytes+version: 0.1.0.0+synopsis: Base64 encoding of byte sequences+homepage: https://github.com/andrewthad/base64-bytes+bug-reports: https://github.com/andrewthad/base64-bytes/issues+license: BSD-3-Clause+license-file: LICENSE+author: Andrew Martin+maintainer: andrew.thaddeus@gmail.com+copyright: 2019 Andrew Martin+category: Data+build-type: Simple+extra-source-files: CHANGELOG.md++library+  exposed-modules:+    Data.Bytes.Base64+  build-depends:+    , base >=4.12 && <5+    , primitive >=0.7 && <0.8+    , byte-order >=0.1.1 && <0.2+    , byteslice >=0.1.4 && <0.3+    , run-st >=0.1 && <0.2+    , bytebuild >=0.3.4 && <0.4+    , natural-arithmetic >=0.1.1 && <0.2+  hs-source-dirs: src+  default-language: Haskell2010+  ghc-options: -Wall -O2++test-suite test+  Default-Language: Haskell2010+  hs-source-dirs: test+  main-is: Main.hs+  type: exitcode-stdio-1.0+  build-depends:+    , base+    , base64-bytes+    , natural-arithmetic >=0.1.1+    , small-bytearray-builder+    , primitive+    , byteslice >=0.1.4.0+  ghc-options: -O2 -Wall++benchmark bench+  type: exitcode-stdio-1.0+  build-depends:+    , base+    , base64-bytes+    , byteslice+    , bytestring+    , gauge+    , primitive+    , base64-bytestring+    , base64 >=0.3+    , random >=1.1+  ghc-options: -Wall -O2+  default-language: Haskell2010+  hs-source-dirs: bench+  main-is: Main.hs

+ bench/Main.hs view

@@ -0,0 +1,78 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE BlockArguments #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeApplications #-}+{-# LANGUAGE PackageImports #-}++import Control.Monad.ST (runST)+import System.Random (mkStdGen,randoms)+import Data.Primitive (ByteArray(ByteArray),unsafeFreezeByteArray)+import Data.Primitive (copyByteArray,newPinnedByteArray)+import Gauge.Main (defaultMain,bgroup,bench,whnf)+import Data.ByteString.Internal (ByteString(PS))++import qualified Data.Bytes as Bytes+import qualified Data.Bytes.Base64 as Base64+import qualified Data.List as List+import qualified GHC.Exts as Exts+import qualified GHC.ForeignPtr as Exts++import qualified "base64-bytestring" Data.ByteString.Base64 as BS+import qualified "base64" Data.ByteString.Base64 as B64++main :: IO ()+main = defaultMain+  [ bgroup "encode"+    [ bgroup "base64-bytes"+      [ bench "100" $+          whnf (\x -> Base64.encode (Bytes.fromByteArray x)) str100+      , bench "1000" $+          whnf (\x -> Base64.encode (Bytes.fromByteArray x)) str1000+      , bench "10000" $+          whnf (\x -> Base64.encode (Bytes.fromByteArray x)) str10000+      ]+    , bgroup "base64-bytestring"+      [ bench "100" $+          whnf (\x -> BS.encode (byteArrayToByteString 100 x)) str100+      , bench "1000" $+          whnf (\x -> BS.encode (byteArrayToByteString 1000 x)) str1000+      , bench "10000" $+          whnf (\x -> BS.encode (byteArrayToByteString 10000 x)) str10000+      ]+    , bgroup "base64"+      [ bench "100" $+          whnf (\x -> B64.encodeBase64' (byteArrayToByteString 100 x)) str100+      , bench "1000" $+          whnf (\x -> B64.encodeBase64' (byteArrayToByteString 1000 x)) str1000+      , bench "10000" $+          whnf (\x -> B64.encodeBase64' (byteArrayToByteString 10000 x)) str10000+      ]+    ]+  ]++byteArrayToByteString :: Int -> ByteArray -> ByteString+{-# inline byteArrayToByteString #-}+byteArrayToByteString len (ByteArray x) = PS+  ( Exts.ForeignPtr+    (Exts.byteArrayContents# x)+    (Exts.PlainPtr (Exts.unsafeCoerce# x))+  ) 0 len++str100 :: ByteArray+{-# NOINLINE str100 #-}+str100 = mkPinned 100++str1000 :: ByteArray+{-# NOINLINE str1000 #-}+str1000 = mkPinned 1000++str10000 :: ByteArray+{-# NOINLINE str10000 #-}+str10000 = mkPinned 10000++mkPinned :: Int -> ByteArray+mkPinned n = runST do+  x <- newPinnedByteArray n+  let src = Exts.fromList (List.take n (randoms (mkStdGen 42)))+  copyByteArray x 0 src 0 n+  unsafeFreezeByteArray x

+ src/Data/Bytes/Base64.hs view

@@ -0,0 +1,213 @@+{-# language BinaryLiterals #-}+{-# language BlockArguments #-}+{-# language DataKinds #-}+{-# language MagicHash #-}+{-# language NoStarIsType #-}+{-# language BangPatterns #-}+{-# language ScopedTypeVariables #-}+{-# language ExplicitNamespaces #-}+{-# language TypeApplications #-}+{-# language TypeOperators #-}+{-# language UnboxedTuples #-}++module Data.Bytes.Base64+  ( encode+  , builder+  , recodeBoundedBuilder+  ) where++import GHC.TypeNats (type (+),type (*),Div)+import Control.Monad.ST.Run (runByteArrayST)+import Data.Char (ord)+import Data.Bits (unsafeShiftR,unsafeShiftL,(.|.),(.&.))+import Data.Bytes.Types (Bytes(Bytes))+import Data.Primitive (ByteArray(..),MutableByteArray(..))+import Data.Primitive (newByteArray,unsafeFreezeByteArray,readByteArray)+import Data.Primitive.Ptr (indexOffPtr)+import Data.Word (Word8)+import GHC.Exts (Ptr(Ptr),Int(I#),State#,(+#),(-#))+import GHC.ST (ST(ST))+import GHC.Word (Word(W#),Word32(W32#))++import qualified Arithmetic.Nat as Nat+import qualified Arithmetic.Types as Arithmetic+import qualified Data.Bytes.Builder.Unsafe as BU+import qualified Data.Bytes.Builder.Bounded.Unsafe as BBU+import qualified Data.Primitive.ByteArray.BigEndian as BE+import qualified Data.Primitive.ByteArray.LittleEndian as LE+import qualified GHC.Exts as Exts++-- | Encode a byte sequence with base64.+encode :: Bytes -> ByteArray+encode (Bytes src soff slen) = runByteArrayST do+  let dlen = calculatePaddedLength slen+  dst <- newByteArray dlen+  performEncodeImmutable dst 0 src soff slen+  unsafeFreezeByteArray dst++-- | Encode a byte sequence with base64 as a builder.+builder :: Bytes -> BU.Builder+builder (Bytes src soff slen) = BU.fromEffect dlen \dst doff -> do+  performEncodeImmutable dst doff src soff slen+  pure (doff + dlen)+  where+  dlen = calculatePaddedLength slen++-- | Encode a byte sequence with base64. This augments a builder+-- by first playing the original builder to paste the byte sequence+-- and then performing the base64 encoding in-place on the buffer+-- that had been pasted into.+recodeBoundedBuilder ::+     Arithmetic.Nat n+  -> BBU.Builder n+  -> BBU.Builder (4 * (Div (n + 2) 3))+recodeBoundedBuilder !n (BBU.Builder f) = BBU.Builder+  (\arr off0 s0 -> let !off1 = (off0 +# maxEncLen) -# maxRawLen in+    case f arr off1 s0 of+      (# s1, off2 #) ->+        let !actualLen = off2 -# off1 in+        case unST (performEncode (MutableByteArray arr) (I# off0) (MutableByteArray arr) (I# off1) (W# (Exts.int2Word# actualLen))) s1 of+          (# s2, (_ :: ()) #) ->+            let !(I# actualEncLen) = calculatePaddedLength (I# actualLen) in+            (# s2, actualEncLen #)+  )+  where+  !(I# maxRawLen) = Nat.demote n+  !(I# maxEncLen) = calculatePaddedLength (I# maxRawLen)++performEncodeImmutable ::+     MutableByteArray s -- dest+  -> Int -- dest off+  -> ByteArray+  -> Int -- src off+  -> Int -- source length+  -> ST s ()+performEncodeImmutable dst doff (ByteArray src) soff slen =+  performEncode dst doff (MutableByteArray (Exts.unsafeCoerce# src)) soff (fromIntegral @Int @Word slen)++-- The function is the meat of this module. Implementation notes:+--+-- We use big-endian and little-endian unaligned loads and stores+-- from the byte-order library. This means we can cut down loads+-- and stores by a factor of 4.+--+-- Once we get down to less than 4 bytes, we have to do some grunt+-- work to finish off the encoding. This happens for two reasons.+-- The first is that base64 requires trailing equals signs to pad+-- encoded byte sequences whose length was not a multiple of three+-- The second is that our 32-bit load is unsafe once we are at the+-- end since its possible (although really unlikely) that the byte+-- sequences is right up against the end of the address space that+-- is available to GHC. Segfaults happen if we wander outside of+-- this pasture.+--+-- Why is the source a mutable byte array? We actually need this+-- to accept both immutable and mutable byte arrays as the source.+-- To avoid code duplication, we use unsafeCoerce# in performEncodeImmutable.+-- Using the mutable variant here actually gives us slightly better+-- guarantees from the compiler since read (unlike index) is sequenced.+-- These guarantees are important in recodeBoundedBuilder, where the+-- encoding is performed in-place.+--+-- Also, what's the deal with the source length being a Word instead+-- of an Int. GHC can actually generate code when we do this.+-- In the cmm stage of compilation, case-on-number constructs+-- are compiled to lower-level constructs. They become either jump+-- table or a series of conditionals statements. In our case,+-- an unsigned number helps GHC realize that it does not need+-- to test for n<0, although it still must test for n>3.+performEncode ::+     MutableByteArray s -- dest+  -> Int -- dest off+  -> MutableByteArray s -- src+  -> Int -- src off+  -> Word -- source length+  -> ST s ()+performEncode !dst !doff !src !soff !slen = case slen of+  3 -> do+    x1 <- readByteArray src soff+    x2 <- readByteArray src (soff + 1)+    x3 <- readByteArray src (soff + 2)+    let (w1,w2,w3,w4) = disassembleBE (assembleBE x1 x2 x3 0)+        c1 = indexOffPtr table (fromIntegral @Word @Int w1)+        c2 = indexOffPtr table (fromIntegral @Word @Int w2)+        c3 = indexOffPtr table (fromIntegral @Word @Int w3)+        c4 = indexOffPtr table (fromIntegral @Word @Int w4)+    LE.writeUnalignedByteArray dst doff (assembleLE c1 c2 c3 c4)+  2 -> do+    x1 <- readByteArray src soff+    x2 <- readByteArray src (soff + 1)+    let (w1,w2,w3,_) = disassembleBE (assembleBE x1 x2 0 0)+        c1 = indexOffPtr table (fromIntegral @Word @Int w1)+        c2 = indexOffPtr table (fromIntegral @Word @Int w2)+        c3 = indexOffPtr table (fromIntegral @Word @Int w3)+        c4 = c2w '='+    LE.writeUnalignedByteArray dst doff (assembleLE c1 c2 c3 c4)+  1 -> do+    x1 <- readByteArray src soff+    let (w1,w2,_,_) = disassembleBE (assembleBE x1 0 0 0)+        c1 = indexOffPtr table (fromIntegral @Word @Int w1)+        c2 = indexOffPtr table (fromIntegral @Word @Int w2)+        c3 = c2w '='+        c4 = c2w '='+    LE.writeUnalignedByteArray dst doff (assembleLE c1 c2 c3 c4)+  0 -> pure ()+  _ -> do -- This last case is always slen > 3+    w :: Word32 <- BE.readUnalignedByteArray src soff+    let (w1,w2,w3,w4) = disassembleBE w+        c1 = indexOffPtr table (fromIntegral @Word @Int w1)+        c2 = indexOffPtr table (fromIntegral @Word @Int w2)+        c3 = indexOffPtr table (fromIntegral @Word @Int w3)+        c4 = indexOffPtr table (fromIntegral @Word @Int w4)+    LE.writeUnalignedByteArray dst doff (assembleLE c1 c2 c3 c4)+    performEncode dst (doff + 4) src (soff + 3) (slen - 3)++-- Argument bytes are hi to lo. The first argument becomes+-- the least significant component of the result.+assembleLE :: Word8 -> Word8 -> Word8 -> Word8 -> Word32+assembleLE a b c d = unsafeW32+  (unsafeShiftL (fromIntegral @Word8 @Word d) 24 .|.+   unsafeShiftL (fromIntegral @Word8 @Word c) 16 .|.+   unsafeShiftL (fromIntegral @Word8 @Word b) 8 .|.+   (fromIntegral @Word8 @Word a)+  )++-- Argument bytes are hi to lo. The first argument becomes+-- the most significant component of the result.+assembleBE :: Word8 -> Word8 -> Word8 -> Word8 -> Word32+assembleBE a b c d = unsafeW32+  (unsafeShiftL (fromIntegral @Word8 @Word a) 24 .|.+   unsafeShiftL (fromIntegral @Word8 @Word b) 16 .|.+   unsafeShiftL (fromIntegral @Word8 @Word c) 8 .|.+   (fromIntegral @Word8 @Word d)+  )++-- Create a 32-bit word from a machine word that we know+-- is not too large.+unsafeW32 :: Word -> Word32+unsafeW32 (W# w) = W32# w++-- We only care about the upper 24 bits of the argument.+-- This gets broken into four 6-bit words.+disassembleBE :: Word32 -> (Word,Word,Word,Word)+disassembleBE !w =+  ( unsafeShiftR (fromIntegral @Word32 @Word w) 26+  , unsafeShiftR (fromIntegral @Word32 @Word w) 20 .&. 0b00111111+  , unsafeShiftR (fromIntegral @Word32 @Word w) 14 .&. 0b00111111+  , unsafeShiftR (fromIntegral @Word32 @Word w) 8 .&. 0b00111111+  )++table :: Ptr Word8+table = Ptr "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/"#++calculatePaddedLength :: Int -> Int+calculatePaddedLength n = 4 * (divRoundUp n 3)++divRoundUp :: Int -> Int -> Int+divRoundUp x y = div (x + y - 1) y++c2w :: Char -> Word8+c2w = fromIntegral . ord++unST :: ST s a -> State# s -> (# State# s, a #)+unST (ST f) s = f s

+ test/Main.hs view

@@ -0,0 +1,80 @@+{-# language BangPatterns #-}++import Control.Monad (when)+import Data.Primitive (ByteArray)+import Data.Word (Word8)+import Numeric (showHex)++import qualified Arithmetic.Nat as Nat+import qualified Data.ByteArray.Builder.Bounded as BB+import qualified Data.Bytes as Bytes+import qualified Data.Primitive as PM+import qualified GHC.Exts as Exts+import qualified Data.Bytes.Base64 as Base64++main :: IO ()+main = do+  putStr "Encoding: foobar\n"+  putStr "Expected: 5a6d3976596d4679 (Zm9vYmFy)\n"+  putStr "Got:      "+  printHex actualFoobar+  when (actualFoobar /= expectedFoobar) (fail "Did not match")+  putStr "Encoding: helloworld\n"+  putStr "Expected: 614756736247393362334a735a413d3d (aGVsbG93b3JsZA==)\n"+  putStr "Got:      "+  printHex actualHelloworld+  when (actualHelloworld /= expectedHelloworld) (fail "Did not match")+  putStr "Encoding: camel\n"+  putStr "Expected: 593246745a57773d (Y2FtZWw=)\n"+  putStr "Got:      "+  printHex actualCamel+  when (actualCamel /= expectedCamel) (fail "Did not match")+  putStr "Encoding: 123.6789\n"+  putStr "Expected: 4d54497a4c6a59334f446b3d (MTIzLjY3ODk=)\n"+  putStr "Got:      "+  printHex actualNumbers+  when (actualNumbers /= expectedNumbers) (fail "Did not match")+  putStr "\nAll tests succeeded!\n"++printHex :: ByteArray -> IO ()+printHex !b = putStr (go 0) where+  go !ix = if ix < PM.sizeofByteArray b+    then let val = PM.indexByteArray b ix :: Word8 in+      if val < 16+        then '0' : showHex val (go (ix + 1))+        else showHex val (go (ix + 1))+    else "\n"++actualFoobar :: ByteArray+actualFoobar = Base64.encode (Bytes.fromAsciiString "foobar")++actualHelloworld :: ByteArray+actualHelloworld = Base64.encode (Bytes.fromAsciiString "helloworld")++actualCamel :: ByteArray+actualCamel = Base64.encode (Bytes.fromAsciiString "camel")++actualNumbers :: ByteArray+actualNumbers = BB.run Nat.constant+  ( Base64.recodeBoundedBuilder+    Nat.constant+    (BB.wordDec 123 `BB.append` BB.ascii '.' `BB.append` BB.wordDec 6789)+  )++expectedFoobar :: ByteArray+expectedFoobar = Exts.fromList [0x5a,0x6d,0x39,0x76,0x59,0x6d,0x46,0x79]++expectedHelloworld :: ByteArray+expectedHelloworld = Exts.fromList+  [0x61,0x47,0x56,0x73,0x62,0x47,0x39,0x33+  ,0x62,0x33,0x4a,0x73,0x5a,0x41,0x3d,0x3d+  ]++expectedCamel :: ByteArray+expectedCamel = Exts.fromList [0x59,0x32,0x46,0x74,0x5a,0x57,0x77,0x3d]++expectedNumbers :: ByteArray+expectedNumbers = Exts.fromList+  [0x4d,0x54,0x49,0x7a,0x4c,0x6a+  ,0x59,0x33,0x4f,0x44,0x6b,0x3d+  ]