base16 (empty) → 0.1.0.0
raw patch · 16 files changed
+1156/−0 lines, 16 filesdep +basedep +base16dep +base16-bytestringsetup-changed
Dependencies added: base, base16, base16-bytestring, bytestring, criterion, deepseq, memory, random-bytestring, tasty, tasty-hunit, text
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +21/−0
- Setup.hs +2/−0
- base16.cabal +82/−0
- benchmarks/Base16Bench.hs +101/−0
- src/Data/ByteString/Base16.hs +72/−0
- src/Data/ByteString/Base16/Internal.hs +46/−0
- src/Data/ByteString/Base16/Internal/Head.hs +65/−0
- src/Data/ByteString/Base16/Internal/Tables.hs +55/−0
- src/Data/ByteString/Base16/Internal/Utils.hs +49/−0
- src/Data/ByteString/Base16/Internal/W16/Loop.hs +92/−0
- src/Data/ByteString/Base16/Internal/W32/Loop.hs +145/−0
- src/Data/ByteString/Base16/Internal/W64/Loop.hs +229/−0
- src/Data/Text/Encoding/Base16.hs +57/−0
- test/Base16Tests.hs +105/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for base16++## 0.1.0.0 -- 2020-02-16++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2020, 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,21 @@+# Base16++[](https://travis-ci.com/emilypi/base16)+[](https://hackage.haskell.org/package/base16)++Padded and unpadded base16 and base16hex encoding and decoding for `Text` and `ByteString` values.++For the companion optics and pattern synonyms, see [base16-lens](https://hackage.haskell.org/package/base16-lens).+++### Summary++What does this library provide? Here is the summary:++- *Great* encoding performance compared to existing libraries (e.g. `memory`, `base16-bytestring`)+- Better decoding performance compared to existing libraries.+- Support for `Text` encodings and decodings+- Optics for handling more complex structures with Base16 representations via the `base16-lens` package+- Checks for both valid Base16 and correct Base16 and Base16hex encodings++There are no dependencies aside from those bundled with GHC.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ base16.cabal view
@@ -0,0 +1,82 @@+cabal-version: 2.0+name: base16+version: 0.1.0.0+synopsis: RFC 4648-compliant Base16 encodings/decodings+description:+ RFC 4648-compliant Base16 encodings and decodings.+ This library provides performant encoding and decoding primitives, as well as support for textual values.++homepage: https://github.com/emilypi/base16+bug-reports: https://github.com/emilypi/base16/issues+license: BSD3+license-file: LICENSE+author: Emily Pillmore+maintainer: emilypi@cohomolo.gy+copyright: (c) 2020 Emily Pillmore+category: Data+build-type: Simple+extra-source-files:+ CHANGELOG.md+ README.md++tested-with:+ GHC ==8.2.2 || ==8.4.3 || ==8.4.4 || ==8.6.3 || ==8.6.5 || ==8.8.1++source-repository head+ type: git+ location: https://github.com/emilypi/base16.git++library+ exposed-modules:+ Data.ByteString.Base16+ Data.Text.Encoding.Base16++ other-modules:+ Data.ByteString.Base16.Internal+ Data.ByteString.Base16.Internal.Head+ Data.ByteString.Base16.Internal.Tables+ Data.ByteString.Base16.Internal.Utils+ Data.ByteString.Base16.Internal.W16.Loop+ Data.ByteString.Base16.Internal.W32.Loop+ Data.ByteString.Base16.Internal.W64.Loop++ build-depends:+ base >=4.10 && <5+ , bytestring ^>=0.10+ , text ^>=1.2++ 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: Base16Tests.hs+ build-depends:+ base >=4.10 && <5+ , base16+ , base16-bytestring+ , bytestring+ , memory+ , random-bytestring+ , tasty+ , tasty-hunit+ , text++benchmark bench+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmarks+ main-is: Base16Bench.hs+ build-depends:+ base >=4.10 && <5+ , base16+ , base16-bytestring+ , bytestring+ , criterion+ , deepseq+ , memory+ , random-bytestring+ , text
+ benchmarks/Base16Bench.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE PackageImports #-}+module Main+( main+)where+++import Criterion+import Criterion.Main++import "memory" Data.ByteArray.Encoding as Mem+import Data.ByteString+import "base16" Data.ByteString.Base16 as B16+import "base16-bytestring" Data.ByteString.Base16 as Bos+import Data.ByteString.Random (random)+++main :: IO ()+main =+ defaultMain+ [ env bs $ \ ~(bs25,bs100,bs1k,bs10k,bs100k,bs1mm) ->+ bgroup "encode"+ [ bgroup "25"+ [ bench "memory" $ whnf ctob bs25+ , bench "base16-bytestring" $ whnf Bos.encode bs25+ , bench "base16" $ whnf B16.encodeBase16' bs25+ ]+ , bgroup "100"+ [ bench "memory" $ whnf ctob bs100+ , bench "base16-bytestring" $ whnf Bos.encode bs100+ , bench "base16" $ whnf B16.encodeBase16' bs100+ ]+ , bgroup "1k"+ [ bench "memory" $ whnf ctob bs1k+ , bench "base16-bytestring" $ whnf Bos.encode bs1k+ , bench "base16" $ whnf B16.encodeBase16' bs1k+ ]+ , bgroup "10k"+ [ bench "memory" $ whnf ctob bs10k+ , bench "base16-bytestring" $ whnf Bos.encode bs10k+ , bench "base16" $ whnf B16.encodeBase16' bs10k+ ]+ , bgroup "100k"+ [ bench "memory" $ whnf ctob bs100k+ , bench "base16-bytestring" $ whnf Bos.encode bs100k+ , bench "base16" $ whnf B16.encodeBase16' bs100k+ ]+ , bgroup "1mm"+ [ bench "memory" $ whnf ctob bs1mm+ , bench "base16-bytestring" $ whnf Bos.encode bs1mm+ , bench "base16" $ whnf B16.encodeBase16' bs1mm+ ]+ ]+ , env bs $ \ ~(bs25,bs100,bs1k,bs10k,bs100k,bs1mm) ->+ bgroup "decode"+ [ bgroup "25"+ [ bench "memory" $ whnf cfob bs25+ , bench "base16-bytestring" $ whnf Bos.decode bs25+ , bench "base16" $ whnf B16.decodeBase16 bs25+ ]+ , bgroup "100"+ [ bench "memory" $ whnf cfob bs100+ , bench "base16-bytestring" $ whnf Bos.decode bs100+ , bench "base16" $ whnf B16.decodeBase16 bs100+ ]+ , bgroup "1k"+ [ bench "memory" $ whnf cfob bs1k+ , bench "base16-bytestring" $ whnf Bos.decode bs1k+ , bench "base16" $ whnf B16.decodeBase16 bs1k+ ]+ , bgroup "10k"+ [ bench "memory" $ whnf cfob bs10k+ , bench "base16-bytestring" $ whnf Bos.decode bs10k+ , bench "base16" $ whnf B16.decodeBase16 bs10k+ ]+ , bgroup "100k"+ [ bench "memory" $ whnf cfob bs100k+ , bench "base16-bytestring" $ whnf Bos.decode bs100k+ , bench "base16" $ whnf B16.decodeBase16 bs100k+ ]+ , bgroup "1mm"+ [ bench "memory" $ whnf cfob bs1mm+ , bench "base16-bytestring" $ whnf Bos.decode bs1mm+ , bench "base16" $ whnf B16.decodeBase16 bs1mm+ ]+ ]+ ]+ where+ ctob :: ByteString -> ByteString+ ctob = Mem.convertToBase Mem.Base16++ cfob :: ByteString -> Either String ByteString+ cfob = Mem.convertFromBase Mem.Base16++ bs = do+ a <- random 25+ b <- random 100+ c <- random 1000+ d <- random 10000+ e <- random 100000+ f <- random 1000000+ return (a,b,c,d,e,f)
+ src/Data/ByteString/Base16.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module : Data.ByteString.Base16+-- Copyright : (c) 2020 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 Base16 encoding including+-- unpadded and lenient variants+--+module Data.ByteString.Base16+( encodeBase16+, encodeBase16'+, decodeBase16+, isBase16+, isValidBase16+) where+++import Data.ByteString (ByteString)+import Data.ByteString.Base16.Internal+import Data.ByteString.Base16.Internal.Head+import Data.Either+import Data.Text (Text)+import qualified Data.Text.Encoding as T+++-- | Encode a 'ByteString' value as Base16 'Text' with padding.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+encodeBase16 :: ByteString -> Text+encodeBase16 = T.decodeUtf8 . encodeBase16'+{-# INLINE encodeBase16 #-}++-- | Encode a 'ByteString' value as a Base16 'ByteString' value with padding.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+encodeBase16' :: ByteString -> ByteString+encodeBase16' = encodeBase16_+{-# INLINE encodeBase16' #-}++-- | Decode a padded Base16-encoded 'ByteString' value.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+decodeBase16 :: ByteString -> Either Text ByteString+decodeBase16 = decodeBase16_+{-# INLINE decodeBase16 #-}++-- | Tell whether a 'ByteString' value is base16 encoded.+--+isBase16 :: ByteString -> Bool+isBase16 bs = isValidBase16 bs && isRight (decodeBase16 bs)+{-# INLINE isBase16 #-}++-- | Tell whether a 'ByteString' value is a valid Base16 format.+--+-- This will not tell you whether or not this is a correct Base16 representation,+-- only that it conforms to the correct shape. To check whether it is a true+-- Base16 encoded 'ByteString' value, use 'isBase16'.+--+isValidBase16 :: ByteString -> Bool+isValidBase16 = validateBase16 "0123456789abcdef"+{-# INLINE isValidBase16 #-}
+ src/Data/ByteString/Base16/Internal.hs view
@@ -0,0 +1,46 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module : Data.ByteString.Base16.Internal+-- Copyright : (c) 2020 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.Base16.Internal+( validateBase16+) where+++import qualified Data.ByteString as BS+import Data.ByteString.Internal++import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable++-- -------------------------------------------------------------------------- --+-- Validating Base16++validateBase16 :: ByteString -> ByteString -> Bool+validateBase16 !alphabet (PS fp off l) =+ accursedUnutterablePerformIO $ withForeignPtr fp $ \p ->+ go (plusPtr p off) (plusPtr p (l + off))+ where+ go !p !end+ | p == end = return True+ | otherwise = do+ w <- peek p+ if BS.elem w alphabet+ then go (plusPtr p 1) end+ else return False+{-# INLINE validateBase16 #-}
+ src/Data/ByteString/Base16/Internal/Head.hs view
@@ -0,0 +1,65 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+module Data.ByteString.Base16.Internal.Head+( encodeBase16_+, decodeBase16_+) where+++#include "MachDeps.h"++import Data.ByteString (ByteString)+import Data.ByteString.Internal+import Data.ByteString.Base16.Internal.Tables+#if WORD_SIZE_IN_BITS >= 32+import Data.ByteString.Base16.Internal.W32.Loop+#elif WORD_SIZE_IN_BITS >= 64+import Data.ByteString.Base16.Internal.W64.Loop+#else+import Data.ByteString.Base16.Internal.W16.Loop+#endif+import Data.Text (Text)++import Foreign.Ptr+import Foreign.ForeignPtr++import GHC.ForeignPtr++import System.IO.Unsafe+++-- | Head of the base16 encoding loop - marshal data, assemble loops+--+encodeBase16_ :: ByteString -> ByteString+encodeBase16_ (PS !sfp !soff !slen) =+ unsafeCreate dlen $ \dptr ->+ withForeignPtr sfp $ \sptr ->+ innerLoop+ (castPtr dptr)+ (castPtr (plusPtr sptr soff))+ (plusPtr sptr (soff + slen))+ where+ !dlen = 2 * slen++decodeBase16_ :: ByteString -> Either Text ByteString+decodeBase16_ (PS !sfp !soff !slen)+ | slen == 0 = Right ""+ | r /= 0 = Left "invalid bytestring size"+ | otherwise = unsafeDupablePerformIO $ do+ dfp <- mallocPlainForeignPtrBytes q+ withForeignPtr dfp $ \dptr ->+ withForeignPtr dtableHi $ \hi ->+ withForeignPtr dtableLo $ \lo ->+ withForeignPtr sfp $ \sptr ->+ decodeLoop+ dfp+ hi+ lo+ (castPtr dptr)+ (castPtr (plusPtr sptr soff))+ (plusPtr sptr (soff + slen))+ where+ (!q, !r) = slen `divMod` 2
+ src/Data/ByteString/Base16/Internal/Tables.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeApplications #-}+module Data.ByteString.Base16.Internal.Tables+( dtableHi+, dtableLo+) where+++import Data.ByteString.Base16.Internal.Utils++import GHC.ForeignPtr+import GHC.Word++dtableHi :: ForeignPtr Word8+dtableHi = 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,0xff,0xff,0xff+ , 0x00,0x10,0x20,0x30,0x40,0x50,0x60,0x70,0x80,0x90,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xa0,0xb0,0xc0,0xd0,0xe0,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xa0,0xb0,0xc0,0xd0,0xe0,0xf0,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,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 dtableHi #-}++dtableLo :: ForeignPtr Word8+dtableLo = 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,0xff,0xff,0xff+ , 0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0x0a,0x0b,0x0c,0x0d,0x0e,0x0f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0x0a,0x0b,0x0c,0x0d,0x0e,0x0f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,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 dtableLo #-}
+ src/Data/ByteString/Base16/Internal/Utils.hs view
@@ -0,0 +1,49 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+module Data.ByteString.Base16.Internal.Utils+( aix+, w32+, w64+, writeNPlainForeignPtrBytes+) where++import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable++import GHC.Exts+import GHC.ForeignPtr+import GHC.Word++import System.IO.Unsafe++-- | Read 'Word8' index off alphabet addr+--+aix :: Word8 -> Addr# -> Word8+aix (W8# i) alpha = W8# (indexWord8OffAddr# alpha (word2Int# i))+{-# INLINE aix #-}++w32 :: Word8 -> Word32+w32 = fromIntegral+{-# INLINE w32 #-}++w64 :: Word8 -> Word64+w64 = fromIntegral+{-# INLINE w64 #-}++-- | 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
+ src/Data/ByteString/Base16/Internal/W16/Loop.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module : Data.ByteString.Base16.Internal.W16.Loop+-- Copyright : (c) 2020 Emily Pillmore+-- License : BSD-style+--+-- Maintainer : Emily Pillmore <emilypi@cohomolo.gy>+-- Stability : Experimental+-- Portability : portable+--+-- Encoding loop optimized for 'Word16' architectures+--+module Data.ByteString.Base16.Internal.W16.Loop+( innerLoop+, decodeLoop+) where+++import Data.Bits+import Data.ByteString.Internal+import Data.ByteString.Base16.Internal.Utils+import Data.Text (Text)+import qualified Data.Text as T++import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable++import GHC.Word+++-- | Hex encoding inner loop optimized for 16-bit architectures+--+innerLoop+ :: Ptr Word16+ -> Ptr Word8+ -> Ptr Word8+ -> IO ()+innerLoop !dptr !sptr !end = go dptr sptr+ where+ lix !a = aix (fromIntegral a .&. 0x0f) alphabet+ {-# INLINE lix #-}++ !alphabet = "0123456789abcdef"#++ go !dst !src+ | src == end = return ()+ | otherwise = do+ !t <- peek src++ let !a = fromIntegral (lix (unsafeShiftR t 4))+ !b = fromIntegral (lix t)++ let !w = a .|. (unsafeShiftL b 8)++ poke dst w++ go (plusPtr dst 2) (plusPtr src 1)+{-# INLINE innerLoop #-}++-- | Hex decoding loop optimized for 16-bit architectures+--+decodeLoop+ :: ForeignPtr Word8+ -> Ptr Word8+ -> Ptr Word8+ -> Ptr Word8+ -> Ptr Word8+ -> Ptr Word8+ -> IO (Either Text ByteString)+decodeLoop !dfp !hi !lo !dptr !sptr !end = go dptr sptr 0+ where+ go !dst !src !n+ | src == end = return (Right (PS dfp 0 n))+ | otherwise = do+ !x <- peek @Word8 src+ !y <- peek @Word8 (plusPtr src 1)++ !a <- peekByteOff hi (fromIntegral x)+ !b <- peekByteOff lo (fromIntegral y)++ if a == 0xff || b == 0xff+ then return . Left . T.pack+ $ "invalid character at offset: "+ ++ show (src `minusPtr` sptr)+ else do+ poke dst (a .|. b)+ go (plusPtr dst 1) (plusPtr src 2) (n + 1)
+ src/Data/ByteString/Base16/Internal/W32/Loop.hs view
@@ -0,0 +1,145 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module : Data.ByteString.Base16.Internal.W32.Loop+-- Copyright : (c) 2020 Emily Pillmore+-- License : BSD-style+--+-- Maintainer : Emily Pillmore <emilypi@cohomolo.gy>+-- Stability : Experimental+-- Portability : portable+--+-- Encoding loop optimized for 'Word32' architectures+--+module Data.ByteString.Base16.Internal.W32.Loop+( innerLoop+, decodeLoop+) where+++import Data.Bits+import Data.ByteString.Internal+import Data.ByteString.Base16.Internal.Utils+import Data.Text (Text)+import qualified Data.Text as T++import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable++import GHC.Word+++-- | Hex encoding inner loop optimized for 32-bit architectures+--+innerLoop+ :: Ptr Word32+ -> Ptr Word16+ -> Ptr Word8+ -> IO ()+innerLoop !dptr !sptr !end = go dptr sptr+ where+ lix !a = aix (fromIntegral a .&. 0x0f) alphabet+ {-# INLINE lix #-}++ !alphabet = "0123456789abcdef"#++ tailRound16 !dst !src+ | src == end = return ()+ | otherwise = do+ !t <- peek @Word8 src++ let !a = fromIntegral (lix (unsafeShiftR t 4))+ !b = fromIntegral (lix t)++ let !w = a .|. (unsafeShiftL b 8)++ poke @Word16 dst w++ tailRound16 (plusPtr dst 2) (plusPtr src 1)++ go !dst !src+ | plusPtr src 3 >= end = tailRound16 (castPtr dst) (castPtr src)+ | otherwise = do+#ifdef WORDS_BIGENDIAN+ !t <- peek src+#else+ !t <- byteSwap16 <$> peek @Word16 src+#endif+ let !a = unsafeShiftR t 12+ !b = unsafeShiftR t 8+ !c = unsafeShiftR t 4++ let !w = w32 (lix a)+ !x = w32 (lix b)+ !y = w32 (lix c)+ !z = w32 (lix t)++ let !xx = w+ .|. (unsafeShiftL x 8)+ .|. (unsafeShiftL y 16)+ .|. (unsafeShiftL z 24)++ poke @Word32 dst xx++ go (plusPtr dst 4) (plusPtr src 2)++-- | Hex decoding loop optimized for 32-bit architectures+--+decodeLoop+ :: ForeignPtr Word8+ -> Ptr Word8+ -> Ptr Word8+ -> Ptr Word16+ -> Ptr Word32+ -> Ptr Word8+ -> IO (Either Text ByteString)+decodeLoop !dfp !hi !lo !dptr !sptr !end = go dptr sptr 0+ where+ tailRound16 !dst !src !n+ | src == end = return (Right (PS dfp 0 n))+ | otherwise = do+ !x <- peek @Word8 src+ !y <- peek @Word8 (plusPtr src 1)++ !a <- peekByteOff hi (fromIntegral x)+ !b <- peekByteOff lo (fromIntegral y)++ if a == 0xff || b == 0xff+ then return . Left . T.pack+ $ "invalid character at offset: "+ ++ show (src `minusPtr` sptr)+ else do+ poke @Word8 dst (a .|. b)+ go (plusPtr dst 1) (plusPtr src 2) (n + 1)++ go !dst !src !n+ | plusPtr src 3 >= end = tailRound16 (castPtr dst) (castPtr src) n+ | otherwise = do+#ifdef WORDS_BIGENDIAN+ !t <- peek @Word32 src+#else+ !t <- byteSwap32 <$> peek @Word32 src+#endif+ let !w = fromIntegral ((unsafeShiftR t 24) .&. 0xff)+ !x = fromIntegral ((unsafeShiftR t 16) .&. 0xff)+ !y = fromIntegral ((unsafeShiftR t 8) .&. 0xff)+ !z = (fromIntegral (t .&. 0xff))++ !a <- peekByteOff @Word8 hi w+ !b <- peekByteOff @Word8 lo x+ !c <- peekByteOff @Word8 hi y+ !d <- peekByteOff @Word8 lo z++ let !zz = fromIntegral (a .|. b)+ .|. (unsafeShiftL (fromIntegral (c .|. d)) 8)++ if a .|. b .|. c .|. d == 0xff+ then return . Left . T.pack+ $ "invalid character at offset: "+ ++ show (src `minusPtr` sptr)+ else do+ poke @Word16 dst zz+ go (plusPtr dst 2) (plusPtr src 4) (n + 2)
+ src/Data/ByteString/Base16/Internal/W64/Loop.hs view
@@ -0,0 +1,229 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module : Data.ByteString.Base16.Internal.W64.Loop+-- Copyright : (c) 2020 Emily Pillmore+-- License : BSD-style+--+-- Maintainer : Emily Pillmore <emilypi@cohomolo.gy>+-- Stability : Experimental+-- Portability : portable+--+-- Encoding loop optimized for 'Word64' architectures+--+module Data.ByteString.Base16.Internal.W64.Loop+( innerLoop+, decodeLoop+) where+++import Data.Bits+import Data.ByteString.Internal+import Data.ByteString.Base16.Internal.Utils+import Data.Text (Text)+import qualified Data.Text as T++import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable++import GHC.Word+++-- | Hex encoding inner loop optimized for 64-bit architectures+--+innerLoop+ :: Ptr Word64+ -> Ptr Word32+ -> Ptr Word8+ -> IO ()+innerLoop !dptr !sptr !end = go dptr sptr+ where+ lix !a = aix (fromIntegral a .&. 0x0f) alphabet+ {-# INLINE lix #-}++ !alphabet = "0123456789abcdef"#++ tailRound16 !dst !src+ | src == end = return ()+ | otherwise = do+ !t <- peek @Word8 src++ let !a = fromIntegral (lix (unsafeShiftR t 4))+ !b = fromIntegral (lix t)++ let !w = a .|. (unsafeShiftL b 8)++ poke @Word16 dst w++ tailRound16 (plusPtr dst 2) (plusPtr src 1)++ tailRound32 !dst !src+ | plusPtr src 3 >= end = tailRound16 (castPtr dst) (castPtr src)+ | otherwise = do+#ifdef WORDS_BIGENDIAN+ !t <- peek src+#else+ !t <- byteSwap16 <$> peek @Word16 src+#endif+ let !a = unsafeShiftR t 12+ !b = unsafeShiftR t 8+ !c = unsafeShiftR t 4++ let !w = w32 (lix a)+ !x = w32 (lix b)+ !y = w32 (lix c)+ !z = w32 (lix t)++ let !xx = w+ .|. (unsafeShiftL x 8)+ .|. (unsafeShiftL y 16)+ .|. (unsafeShiftL z 24)++ poke @Word32 dst xx++ tailRound32 (plusPtr dst 4) (plusPtr src 2)++ go !dst !src+ | plusPtr src 7 >= end = tailRound32 (castPtr dst) (castPtr src)+ | otherwise = do+#ifdef WORDS_BIGENDIAN+ !t <- peek src+#else+ !t <- byteSwap32 <$> peek @Word32 src+#endif+ let !a = unsafeShiftR t 28+ !b = unsafeShiftR t 24+ !c = unsafeShiftR t 20+ !d = unsafeShiftR t 16+ !e = unsafeShiftR t 12+ !f = unsafeShiftR t 8+ !g = unsafeShiftR t 4++ let !p = w64 (lix a)+ !q = w64 (lix b)+ !r = w64 (lix c)+ !s = w64 (lix d)+ !w = w64 (lix e)+ !x = w64 (lix f)+ !y = w64 (lix g)+ !z = w64 (lix t)++ let !xx = p+ .|. (unsafeShiftL q 8)+ .|. (unsafeShiftL r 16)+ .|. (unsafeShiftL s 24)++ !yy = w+ .|. (unsafeShiftL x 8)+ .|. (unsafeShiftL y 16)+ .|. (unsafeShiftL z 24)++ let !zz = xx .|. unsafeShiftL yy 32++ poke dst zz++ go (plusPtr dst 8) (plusPtr src 4)+{-# INLINE innerLoop #-}+++-- | Hex decoding loop optimized for 64-bit architectures+--+decodeLoop+ :: ForeignPtr Word8+ -> Ptr Word8+ -> Ptr Word8+ -> Ptr Word32+ -> Ptr Word64+ -> Ptr Word8+ -> IO (Either Text ByteString)+decodeLoop !dfp !hi !lo !dptr !sptr !end = go dptr sptr 0+ where+ tailRound16 !dst !src !n+ | src == end = return (Right (PS dfp 0 n))+ | otherwise = do+ !x <- peek @Word8 src+ !y <- peek @Word8 (plusPtr src 1)++ !a <- peekByteOff @Word8 hi (fromIntegral x)+ !b <- peekByteOff @Word8 lo (fromIntegral y)++ if a == 0xff || b == 0xff+ then return . Left . T.pack+ $ "invalid character at offset: "+ ++ show (src `minusPtr` sptr)+ else do+ poke dst (a .|. b)+ go (plusPtr dst 1) (plusPtr src 2) (n + 1)++ tailRound32 !dst !src !n+ | plusPtr src 4 >= end = tailRound16 (castPtr dst) (castPtr src) n+ | otherwise = do+#ifdef WORDS_BIGENDIAN+ !t <- peek @Word32 src+#else+ !t <- byteSwap32 <$> peek @Word32 src+#endif+ let !w = fromIntegral ((unsafeShiftR t 24) .&. 0xff)+ !x = fromIntegral ((unsafeShiftR t 16) .&. 0xff)+ !y = fromIntegral ((unsafeShiftR t 8) .&. 0xff)+ !z = (fromIntegral (t .&. 0xff))++ !a <- peekByteOff @Word8 hi w+ !b <- peekByteOff @Word8 lo x+ !c <- peekByteOff @Word8 hi y+ !d <- peekByteOff @Word8 lo z++ let !xx = fromIntegral (a .|. b)+ !yy = fromIntegral (c .|. d)++ let !zz = xx .|. (unsafeShiftL yy 8)++ if a .|. b .|. c .|. d == 0xff+ then return . Left . T.pack+ $ "invalid character at offset: "+ ++ show (src `minusPtr` sptr)+ else do+ poke @Word16 dst zz+ go (plusPtr dst 2) (plusPtr src 4) (n + 2)++ go !dst !src !n+ | plusPtr src 8 >= end = tailRound32 (castPtr dst) (castPtr src) n+ | otherwise = do+#ifdef WORDS_BIGENDIAN+ !tt <- peek @Word64 src+#else+ !tt <- byteSwap64 <$> peek @Word64 src+#endif+ let !s = fromIntegral ((unsafeShiftR tt 56) .&. 0xff)+ !t = fromIntegral ((unsafeShiftR tt 48) .&. 0xff)+ !u = fromIntegral ((unsafeShiftR tt 40) .&. 0xff)+ !v = fromIntegral ((unsafeShiftR tt 32) .&. 0xff)+ !w = fromIntegral ((unsafeShiftR tt 24) .&. 0xff)+ !x = fromIntegral ((unsafeShiftR tt 16) .&. 0xff)+ !y = fromIntegral ((unsafeShiftR tt 8) .&. 0xff)+ !z = fromIntegral (tt .&. 0xff)++ !a <- peekByteOff @Word8 hi s+ !b <- peekByteOff @Word8 lo t+ !c <- peekByteOff @Word8 hi u+ !d <- peekByteOff @Word8 lo v+ !e <- peekByteOff @Word8 hi w+ !f <- peekByteOff @Word8 lo x+ !g <- peekByteOff @Word8 hi y+ !h <- peekByteOff @Word8 lo z++ let !zz = fromIntegral (a .|. b)+ .|. (unsafeShiftL (fromIntegral (c .|. d)) 8)+ .|. (unsafeShiftL (fromIntegral (e .|. f)) 16)+ .|. (unsafeShiftL (fromIntegral (g .|. h)) 24)++ if a .|. b .|. c .|. d .|. e .|. f .|. g .|. h == 0xff+ then return . Left . T.pack+ $ "invalid character at offset: "+ ++ show (src `minusPtr` sptr)+ else do+ poke @Word32 dst zz+ go (plusPtr dst 4) (plusPtr src 8) (n + 4)
+ src/Data/Text/Encoding/Base16.hs view
@@ -0,0 +1,57 @@+-- |+-- Module : Data.Text.Encoding.Base16+-- 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 Base16 encoding including+-- unpadded and lenient variants+--+module Data.Text.Encoding.Base16+( encodeBase16+, decodeBase16+, isBase16+, isValidBase16+) where+++import qualified Data.ByteString.Base16 as B16++import Data.Text (Text)+import qualified Data.Text.Encoding as T++-- | Encode a 'Text' value in Base16 with padding.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+encodeBase16 :: Text -> Text+encodeBase16 = B16.encodeBase16 . T.encodeUtf8+{-# INLINE encodeBase16 #-}++-- | Decode a padded Base16-encoded 'Text' value+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+decodeBase16 :: Text -> Either Text Text+decodeBase16 = fmap T.decodeUtf8 . B16.decodeBase16 . T.encodeUtf8+{-# INLINE decodeBase16 #-}++-- | Tell whether a 'Text' value is Base16-encoded.+--+isBase16 :: Text -> Bool+isBase16 = B16.isBase16 . T.encodeUtf8+{-# INLINE isBase16 #-}++-- | Tell whether a 'Text' value is a valid Base16 format.+--+-- This will not tell you whether or not this is a correct Base16 representation,+-- only that it conforms to the correct shape. To check whether it is a true+-- Base16 encoded 'Text' value, use 'isBase16'.+--+isValidBase16 :: Text -> Bool+isValidBase16 = B16.isValidBase16 . T.encodeUtf8+{-# INLINE isValidBase16 #-}
+ test/Base16Tests.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TypeApplications #-}+module Main+( main+, tests+) where+++import Data.Bifunctor+import Data.ByteString (ByteString)+import "base16" Data.ByteString.Base16 as B16+import "memory" Data.ByteArray.Encoding as Mem+import Data.ByteString.Random (random)+import Data.Functor (void)+import Data.Text (pack)++import Test.Tasty+import Test.Tasty.HUnit+++main :: IO ()+main = defaultMain tests+++tests :: TestTree+tests = testGroup "Base16 Tests"+ [ testVectors+ , sanityTests+ , alphabetTests+ ]++testVectors :: TestTree+testVectors = testGroup "RFC 4648 Test Vectors"+ [ testGroup "encode/decode"+ [ testCaseB16 "" ""+ , testCaseB16 "f" "66"+ , testCaseB16 "fo" "666f"+ , testCaseB16 "foo" "666f6f"+ , testCaseB16 "foob" "666f6f62"+ , testCaseB16 "fooba" "666f6f6261"+ , testCaseB16 "foobar" "666f6f626172"+ ]+ ]+ where+ testCaseB16 s t =+ testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do+ let t' = B16.encodeBase16' s+ s' = B16.decodeBase16 t'++ step "compare encoding"+ t @=? t'++ step "compare decoding"+ Right s @=? s'++sanityTests :: TestTree+sanityTests = testGroup "Sanity tests"+ [ testGroup "very large bytestrings don't segfault"+ [ chonk+ ]+ , testGroup "`memory` sanity checks"+ [ compare32 3+ , compare32 4+ , compare32 5+ , compare32 6+ , compare32 1000+ , compare32 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 $ B16.encodeBase16' bs++ compare32 n = testCase ("Testing " ++ show n ++ "-sized bytestrings") $ do+ bs <- random n+ B16.encodeBase16' bs @=? Mem.convertToBase Mem.Base16 bs+ B16.decodeBase16 (B16.encodeBase16' bs) @=?+ first pack (Mem.convertFromBase @ByteString Mem.Base16 (Mem.convertToBase Mem.Base16 bs))++ roundtrip n = testCase ("Roundtrip encode/decode for " ++ show n ++ "-sized bytestrings") $ do+ bs <- random n+ B16.decodeBase16 (B16.encodeBase16' bs) @=? Right bs++alphabetTests :: TestTree+alphabetTests = testGroup "Alphabet tests"+ [ base16Tests 0+ , base16Tests 4+ , base16Tests 5+ , base16Tests 6+ ]+ where+ base16Tests n = testCase ("Conforms to Base16 alphabet: " ++ show n) $ do+ bs <- random n+ let b = B16.encodeBase16' bs+ assertBool ("failed validity: " ++ show b) $ B16.isValidBase16 b+ assertBool ("failed correctness: " ++ show b) $ B16.isBase16 b