base32 (empty) → 0.1.0.0
raw patch · 17 files changed
+1448/−0 lines, 17 filesdep +basedep +base32dep +bytestringsetup-changed
Dependencies added: base, base32, bytestring, criterion, deepseq, memory, random-bytestring, tasty, tasty-hunit, text
Files
- CHANGELOG.md +5/−0
- LICENSE +30/−0
- README.md +22/−0
- Setup.hs +2/−0
- base32.cabal +81/−0
- benchmarks/Base32Bench.hs +58/−0
- src/Data/ByteString/Base32.hs +111/−0
- src/Data/ByteString/Base32/Hex.hs +110/−0
- src/Data/ByteString/Base32/Internal.hs +55/−0
- src/Data/ByteString/Base32/Internal/Head.hs +92/−0
- src/Data/ByteString/Base32/Internal/Loop.hs +160/−0
- src/Data/ByteString/Base32/Internal/Tables.hs +56/−0
- src/Data/ByteString/Base32/Internal/Tail.hs +281/−0
- src/Data/ByteString/Base32/Internal/Utils.hs +56/−0
- src/Data/Text/Encoding/Base32.hs +91/−0
- src/Data/Text/Encoding/Base32/Hex.hs +90/−0
- test/Base32Tests.hs +148/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for base32++## 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,22 @@+# Base32++[](https://travis-ci.com/emilypi/base32)+[](https://hackage.haskell.org/package/base32)++Padded and unpadded base32 and base32hex encoding and decoding for `Text` and `ByteString` values.++For the companion optics and pattern synonyms, see [base32-lens](https://hackage.haskell.org/package/base32-lens).+++### Summary++What does this library provide? Here is the summary:++- Support for padded and unpadded Base32 and Base32hex+- Support for `Text` encodings and decodings+- Optics for handling more complex structures with Base32 representations via the `base32-lens` package+- Checks for both valid Base32 and correct Base32 and Base32hex encodings++There are no dependencies aside from those bundled with GHC:++
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ base32.cabal view
@@ -0,0 +1,81 @@+cabal-version: 2.0+name: base32+version: 0.1.0.0+synopsis: RFC 4648-compliant Base32 encodings/decodings+description:+ RFC 4648-compliant Base32 encodings and decodings.+ This library provides performant encoding and decoding primitives, as well as support for textual values.++homepage: https://github.com/emilypi/base32+bug-reports: https://github.com/emilypi/base32/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/base32.git++library+ exposed-modules:+ Data.ByteString.Base32+ Data.ByteString.Base32.Hex+ Data.Text.Encoding.Base32+ Data.Text.Encoding.Base32.Hex++ other-modules:+ Data.ByteString.Base32.Internal+ Data.ByteString.Base32.Internal.Head+ Data.ByteString.Base32.Internal.Loop+ Data.ByteString.Base32.Internal.Tables+ Data.ByteString.Base32.Internal.Tail+ Data.ByteString.Base32.Internal.Utils++ 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: Base32Tests.hs+ build-depends:+ base >=4.10 && <5+ , base32+ , bytestring+ , memory+ , random-bytestring+ , tasty+ , tasty-hunit+ , text++benchmark bench+ default-language: Haskell2010+ type: exitcode-stdio-1.0+ hs-source-dirs: benchmarks+ main-is: Base32Bench.hs+ build-depends:+ base >=4.10 && <5+ , base32+ , bytestring+ , criterion+ , deepseq+ , memory+ , random-bytestring+ , text
+ benchmarks/Base32Bench.hs view
@@ -0,0 +1,58 @@+{-# LANGUAGE PackageImports #-}+module Main+( main+)where+++import Criterion+import Criterion.Main++import "memory" Data.ByteArray.Encoding as Mem+import Data.ByteString+import "base32" Data.ByteString.Base32 as B32+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 "base64" $ whnf B32.encodeBase32' bs25+ ]+ , bgroup "100"+ [ bench "memory" $ whnf ctob bs100+ , bench "base64" $ whnf B32.encodeBase32' bs100+ ]+ , bgroup "1k"+ [ bench "memory" $ whnf ctob bs1k+ , bench "base64" $ whnf B32.encodeBase32' bs1k+ ]+ , bgroup "10k"+ [ bench "memory" $ whnf ctob bs10k+ , bench "base64" $ whnf B32.encodeBase32' bs10k+ ]+ , bgroup "100k"+ [ bench "memory" $ whnf ctob bs100k+ , bench "base64" $ whnf B32.encodeBase32' bs100k+ ]+ , bgroup "1mm"+ [ bench "memory" $ whnf ctob bs1mm+ , bench "base64" $ whnf B32.encodeBase32' bs1mm+ ]+ ]+ ]+ where+ ctob :: ByteString -> ByteString+ ctob = Mem.convertToBase Mem.Base32++ 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/Base32.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module : Data.ByteString.Base32+-- 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 Base32 encoding including+-- unpadded and lenient variants+--+module Data.ByteString.Base32+( encodeBase32+, encodeBase32'+, decodeBase32+, encodeBase32Unpadded+, encodeBase32Unpadded'+, decodeBase32Unpadded+-- , decodeBase32Lenient+, isBase32+, isValidBase32+) where+++import Data.ByteString (ByteString)+import Data.ByteString.Base32.Internal+import Data.ByteString.Base32.Internal.Head+import Data.ByteString.Base32.Internal.Tables+import Data.Either (isRight)+import Data.Text (Text)+import qualified Data.Text.Encoding as T+++-- | Encode a 'ByteString' value as Base32 'Text' with padding.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+encodeBase32 :: ByteString -> Text+encodeBase32 = T.decodeUtf8 . encodeBase32'+{-# INLINE encodeBase32 #-}++-- | Encode a 'ByteString' value as a Base32 'ByteString' value with padding.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+encodeBase32' :: ByteString -> ByteString+encodeBase32' = encodeBase32_ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"#+{-# INLINE encodeBase32' #-}++-- | Decode a padded Base32-encoded 'ByteString' value.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+decodeBase32 :: ByteString -> Either Text ByteString+decodeBase32 = decodeBase32_ False stdDecodeTable+{-# INLINE decodeBase32 #-}++-- | Encode a 'ByteString' value as a Base32 'Text' value without padding.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+encodeBase32Unpadded :: ByteString -> Text+encodeBase32Unpadded = T.decodeUtf8 . encodeBase32Unpadded'+{-# INLINE encodeBase32Unpadded #-}++-- | Encode a 'ByteString' value as a Base32 'ByteString' value with padding.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+encodeBase32Unpadded' :: ByteString -> ByteString+encodeBase32Unpadded' = encodeBase32NoPad_ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"#+{-# INLINE encodeBase32Unpadded' #-}++-- | Decode an arbitarily padded Base32-encoded 'ByteString' value.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+decodeBase32Unpadded :: ByteString -> Either Text ByteString+decodeBase32Unpadded = decodeBase32_ True stdDecodeTable+{-# INLINE decodeBase32Unpadded #-}++-- -- | Leniently decode an unpadded Base32-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.+-- --+-- decodeBase32Lenient :: ByteString -> ByteString+-- decodeBase32Lenient = decodeBase32Lenient_ decodeB32Table+-- {-# INLINE decodeBase32Lenient #-}++-- | Tell whether a 'ByteString' value is base32 encoded.+--+isBase32 :: ByteString -> Bool+isBase32 bs = isValidBase32 bs && isRight (decodeBase32 bs)+{-# INLINE isBase32 #-}++-- | Tell whether a 'ByteString' value is a valid Base32 format.+--+-- This will not tell you whether or not this is a correct Base32 representation,+-- only that it conforms to the correct shape. To check whether it is a true+-- Base32 encoded 'ByteString' value, use 'isBase32'.+--+isValidBase32 :: ByteString -> Bool+isValidBase32 = validateBase32 "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"+{-# INLINE isValidBase32 #-}
+ src/Data/ByteString/Base32/Hex.hs view
@@ -0,0 +1,110 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module : Data.ByteString.Base32.Hex+-- 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 Base32-Hex encoding including+-- unpadded and lenient variants+--+module Data.ByteString.Base32.Hex+( encodeBase32+, encodeBase32'+, decodeBase32+, encodeBase32Unpadded+, encodeBase32Unpadded'+, decodeBase32Unpadded+-- , decodeBase32Lenient+, isBase32Hex+, isValidBase32Hex+) where++import Data.ByteString (ByteString)+import Data.ByteString.Base32.Internal+import Data.ByteString.Base32.Internal.Head+import Data.ByteString.Base32.Internal.Tables+import Data.Either (isRight)+import Data.Text (Text)+import qualified Data.Text.Encoding as T+++-- | Encode a 'ByteString' value as a Base32hex 'Text' value with padding.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-5 RFC-4648 section 5>+--+encodeBase32 :: ByteString -> Text+encodeBase32 = T.decodeUtf8 . encodeBase32'+{-# INLINE encodeBase32 #-}++-- | Encode a 'ByteString' as a Base32hex 'ByteString' value with padding.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-5 RFC-4648 section 5>+--+encodeBase32' :: ByteString -> ByteString+encodeBase32' = encodeBase32_ "0123456789ABCDEFGHIJKLMNOPQRSTUV"#+{-# INLINE encodeBase32' #-}++-- | Decode a padded Base32hex encoded 'ByteString' value.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+decodeBase32 :: ByteString -> Either Text ByteString+decodeBase32 = decodeBase32_ False hexDecodeTable+{-# INLINE decodeBase32 #-}++-- | Encode a 'ByteString' as a Base32hex 'Text' value without padding.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-5 RFC-4648 section 5>+--+encodeBase32Unpadded :: ByteString -> Text+encodeBase32Unpadded = T.decodeUtf8 . encodeBase32Unpadded'+{-# INLINE encodeBase32Unpadded #-}++-- | Encode a 'ByteString' as a Base32hex 'ByteString' value without padding.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-5 RFC-4648 section 5>+--+encodeBase32Unpadded' :: ByteString -> ByteString+encodeBase32Unpadded' = encodeBase32NoPad_ "0123456789ABCDEFGHIJKLMNOPQRSTUV"#+{-# INLINE encodeBase32Unpadded' #-}++-- | Decode an arbitrarily padded Base32hex encoded 'ByteString' value.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+decodeBase32Unpadded :: ByteString -> Either Text ByteString+decodeBase32Unpadded = decodeBase32_ True hexDecodeTable+{-# INLINE decodeBase32Unpadded #-}++-- -- | Leniently decode an unpadded Base32hex-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.+-- --+-- decodeBase32Lenient :: ByteString -> ByteString+-- decodeBase32Lenient = decodeBase32Lenient_ decodeB32HexTable+-- {-# INLINE decodeBase32Lenient #-}++-- | Tell whether a 'ByteString' is Base32hex-encoded.+--+isBase32Hex :: ByteString -> Bool+isBase32Hex bs = isValidBase32Hex bs && isRight (decodeBase32 bs)+{-# INLINE isBase32Hex #-}++-- | Tell whether a 'ByteString' is a valid Base32hex format.+--+-- This will not tell you whether or not this is a correct Base32hex representation,+-- only that it conforms to the correct shape. To check whether it is a true+-- Base32 encoded 'ByteString' value, use 'isBase32Hex'.+--+isValidBase32Hex :: ByteString -> Bool+isValidBase32Hex = validateBase32 "0123456789ABCDEFGHIJKLMNOPQRSTUV"+{-# INLINE isValidBase32Hex #-}
+ src/Data/ByteString/Base32/Internal.hs view
@@ -0,0 +1,55 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+-- |+-- Module : Data.ByteString.Base32.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.Base32.Internal+( validateBase32+) where+++import qualified Data.ByteString as BS+import Data.ByteString.Internal++import Foreign.ForeignPtr+import Foreign.Ptr+import Foreign.Storable++-- -------------------------------------------------------------------------- --+-- Validating Base64++validateBase32 :: ByteString -> ByteString -> Bool+validateBase32 !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++ let f a+ | a == 0x3d, plusPtr p 1 == end = True+ | a == 0x3d, plusPtr p 2 == end = True+ | a == 0x3d, plusPtr p 3 == end = True+ | a == 0x3d, plusPtr p 4 == end = True+ | a == 0x3d, plusPtr p 5 == end = True+ | a == 0x3d, plusPtr p 6 == end = True+ | a == 0x3d = False+ | otherwise = BS.elem a alphabet++ if f w then go (plusPtr p 1) end else return False+{-# INLINE validateBase32 #-}
+ src/Data/ByteString/Base32/Internal/Head.hs view
@@ -0,0 +1,92 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+module Data.ByteString.Base32.Internal.Head+( encodeBase32_+, encodeBase32NoPad_+, decodeBase32_+) where+++import Data.ByteString (ByteString)+import qualified Data.ByteString as BS+import Data.ByteString.Internal+import Data.ByteString.Base32.Internal.Loop+import Data.ByteString.Base32.Internal.Tail+import Data.Text (Text)++import Foreign.Ptr+import Foreign.ForeignPtr++import GHC.Exts+import GHC.ForeignPtr+import GHC.Word++import System.IO.Unsafe+++-- | Head of the base32 encoding loop - marshal data, assemble loops+--+encodeBase32_ :: Addr# -> ByteString -> ByteString+encodeBase32_ !lut (PS !sfp !soff !slen) =+ unsafeCreate dlen $ \dptr ->+ withForeignPtr sfp $ \sptr -> do+ let !end = plusPtr sptr (soff + slen)+ innerLoop+ lut+ (castPtr dptr)+ (plusPtr sptr soff)+ end+ (loopTail lut end)+ where+ !dlen = 8 * ((slen + 4) `div` 5)++-- | Head of the unpadded base32 encoding loop - marshal data, assemble loops+--+encodeBase32NoPad_ :: Addr# -> ByteString -> ByteString+encodeBase32NoPad_ !lut (PS !sfp !soff !slen)+ = unsafeDupablePerformIO $ do+ !dfp <- mallocPlainForeignPtrBytes dlen+ withForeignPtr dfp $ \dptr ->+ withForeignPtr sfp $ \sptr -> do+ let !end = plusPtr sptr (soff + slen)+ innerLoopNoPad+ lut+ (castPtr dptr)+ (plusPtr sptr soff)+ end+ (loopTailNoPad lut dfp end)+ where+ !dlen = 8 * ((slen + 4) `div` 5)++-- | Head of the base32 decoding loop - marshal data, assemble loops+--+decodeBase32_ :: Bool -> ForeignPtr Word8 -> ByteString -> Either Text ByteString+decodeBase32_ !pad !alphabet bs@(PS _ _ !l)+ | l == 0 = Right ""+ | r /= 0, pad =+ if+ | r == 2 -> go (BS.append bs (BS.replicate 6 0x3d))+ | r == 4 -> go (BS.append bs (BS.replicate 4 0x3d))+ | r == 5 -> go (BS.append bs (BS.replicate 3 0x3d))+ | r == 7 -> go (BS.append bs (BS.replicate 1 0x3d))+ | otherwise -> Left "invalid bytestring size"+ | r /= 0, not pad = Left "invalid padding"+ | otherwise = go bs+ where+ (!q, !r) = l `divMod` 8+ !dlen = q * 8++ go (PS !sfp !soff !slen) = unsafeDupablePerformIO $ do+ !dfp <- mallocPlainForeignPtrBytes dlen+ withForeignPtr dfp $ \dptr ->+ withForeignPtr alphabet $ \(Ptr lut) ->+ withForeignPtr sfp $ \sptr -> do+ let !end = plusPtr sptr (soff + slen)+ decodeLoop+ lut+ (castPtr dptr)+ (plusPtr sptr soff)+ end+ (decodeTail lut dfp end)
+ src/Data/ByteString/Base32/Internal/Loop.hs view
@@ -0,0 +1,160 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE CPP #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeApplications #-}+module Data.ByteString.Base32.Internal.Loop+( innerLoop+, innerLoopNoPad+, decodeLoop+) where++import Data.Bits+import Data.ByteString (ByteString)+import Data.ByteString.Base32.Internal.Utils+import Data.Text (Text)+import qualified Data.Text as T++import Foreign.Ptr+import Foreign.Storable++import GHC.Exts+import GHC.Word+++-- ------------------------------------------------------------------------ --+-- Encoding loops++innerLoop+ :: Addr#+ -> Ptr Word64+ -> Ptr Word8+ -> Ptr Word8+ -> (Ptr Word8 -> Ptr Word8 -> IO ())+ -> IO ()+innerLoop !lut !dptr !sptr !end finish = go dptr sptr+ where+ lix a = return $ w64 (aix (fromIntegral a .&. 0x1f) lut)+ {-# INLINE lix #-}++ go !dst !src+ | plusPtr src 4 >= end = finish (castPtr dst) src+ | otherwise = do+#ifdef WORDS_BIGENDIAN+ !t <- peek @Word32 (castPtr src)+#else+ !t <- byteSwap32 <$> peek @Word32 (castPtr src)+#endif+ !u <- w32 <$> peek (plusPtr src 4)++ !a <- lix (unsafeShiftR t 27)+ !b <- lix (unsafeShiftR t 22)+ !c <- lix (unsafeShiftR t 17)+ !d <- lix (unsafeShiftR t 12)+ !e <- lix (unsafeShiftR t 7)+ !f <- lix (unsafeShiftR t 2)+ !g <- lix ((unsafeShiftL t 3) .|. (unsafeShiftR u 5))+ !h <- lix u++ w <- return $ a+ .|. (unsafeShiftL b 8)+ .|. (unsafeShiftL c 16)+ .|. (unsafeShiftL d 24)+ .|. (unsafeShiftL e 32)+ .|. (unsafeShiftL f 40)+ .|. (unsafeShiftL g 48)+ .|. (unsafeShiftL h 56)++ poke dst w++ go (plusPtr dst 8) (plusPtr src 5)+{-# INLINE innerLoop #-}++innerLoopNoPad+ :: Addr#+ -> Ptr Word64+ -> Ptr Word8+ -> Ptr Word8+ -> (Ptr Word8 -> Ptr Word8 -> Int -> IO ByteString)+ -> IO ByteString+innerLoopNoPad !lut !dptr !sptr !end finish = go dptr sptr 0+ where+ lix a = return $ w64 (aix (fromIntegral a .&. 0x1f) lut)++ go !dst !src !n+ | plusPtr src 4 >= end = finish (castPtr dptr) src n+ | otherwise = do+#ifdef WORDS_BIGENDIAN+ !t <- peek @Word32 (castPtr src)+#else+ !t <- byteSwap32 <$> peek @Word32 (castPtr src)+#endif+ !u <- w32 <$> peek (plusPtr src 4)++ !a <- lix (unsafeShiftR t 27)+ !b <- lix (unsafeShiftR t 22)+ !c <- lix (unsafeShiftR t 17)+ !d <- lix (unsafeShiftR t 12)+ !e <- lix (unsafeShiftR t 7)+ !f <- lix (unsafeShiftR t 2)+ !g <- lix ((unsafeShiftL t 3) .|. (unsafeShiftR u 5))+ !h <- lix u++ !w <- return $ a+ .|. (unsafeShiftL b 8)+ .|. (unsafeShiftL c 16)+ .|. (unsafeShiftL d 24)+ .|. (unsafeShiftL e 32)+ .|. (unsafeShiftL f 40)+ .|. (unsafeShiftL g 48)+ .|. (unsafeShiftL h 56)++ poke dst w++ go (plusPtr dst 8) (plusPtr src 5) (n + 8)+{-# INLINE innerLoopNoPad #-}++-- ------------------------------------------------------------------------ --+-- Decoding loops++decodeLoop+ :: Addr#+ -> Ptr Word8+ -> Ptr Word64+ -> Ptr Word8+ -> (Ptr Word8 -> Ptr Word8 -> Int -> IO (Either Text ByteString))+ -> IO (Either Text ByteString)+decodeLoop !lut !dptr !sptr !end finish = go dptr sptr 0+ where+ lix a = w64 (aix (fromIntegral a) lut)++ roll !w !acc = (acc `unsafeShiftL` 5) .|. lix w++ err = return . Left . T.pack++ go !dst !src !n+ | plusPtr src 8 == end = finish dst (castPtr src) n+ | otherwise = do+#ifdef WORDS_BIGENDIAN+ !t <- peek src+#else+ !t <- byteSwap64 <$> peek src+#endif+ !w <- return+ $ roll (unsafeShiftR t 0)+ $ roll (unsafeShiftR t 8)+ $ roll (unsafeShiftR t 16)+ $ roll (unsafeShiftR t 24)+ $ roll (unsafeShiftR t 32)+ $ roll (unsafeShiftR t 40)+ $ roll (unsafeShiftR t 48)+ $ roll (unsafeShiftR t 56)+ 0++ if w /= 0xff+ then do+ poke @Word8 dst (fromIntegral (w `unsafeShiftR` 32))+ poke @Word32 (castPtr (plusPtr dst 1)) (byteSwap32 (fromIntegral w))+ go (plusPtr dst 5) (plusPtr src 8) (n + 5)+ else err+ $ "invalid character at offset: "+ ++ show (src `minusPtr` sptr)
+ src/Data/ByteString/Base32/Internal/Tables.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE TypeApplications #-}+module Data.ByteString.Base32.Internal.Tables+( stdDecodeTable+, hexDecodeTable+) where+++import Data.ByteString.Base32.Internal.Utils++import Foreign.ForeignPtr++import GHC.Word+++stdDecodeTable :: ForeignPtr Word8+stdDecodeTable = 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+ , 0xff,0xff,0x1a,0x1b,0x1c,0x1d,0x1e,0x1f,0xff,0xff,0xff,0xff,0xff,0xff,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,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,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,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 stdDecodeTable #-}++hexDecodeTable :: ForeignPtr Word8+hexDecodeTable = 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,0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18+ , 0x19,0x1a,0x1b,0x1c,0x1d,0x1e,0x1f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0x0a,0x0b,0x0c,0x0d,0x0e,0x0f,0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18+ , 0x19,0x1a,0x1b,0x1c,0x1d,0x1e,0x1f,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff+ , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,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 hexDecodeTable #-}
+ src/Data/ByteString/Base32/Internal/Tail.hs view
@@ -0,0 +1,281 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE LambdaCase #-}+{-# LANGUAGE MagicHash #-}+{-# LANGUAGE MultiWayIf #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}+module Data.ByteString.Base32.Internal.Tail+( loopTail+, loopTailNoPad+, decodeTail+) where+++import Data.Bits+import Data.ByteString.Internal+import Data.ByteString.Base32.Internal.Utils+import Data.Text (Text)+import qualified Data.Text as T++import Foreign.Ptr+import Foreign.ForeignPtr+import Foreign.Storable++import GHC.Exts+import GHC.Word+++-- | Unroll final quantum encoding for base32+--+loopTail+ :: Addr#+ -> Ptr Word8+ -> Ptr Word8+ -> Ptr Word8+ -> IO ()+loopTail !lut !end !dst !src+ | plusPtr src 1 == end = do -- 2 6+ !a <- peek src++ let !t = look (unsafeShiftR (a .&. 0xf8) 3)+ !u = look (unsafeShiftL (a .&. 0x07) 2)++ poke dst t+ poke (plusPtr dst 1) u+ padN (plusPtr dst 2) 6++ | plusPtr src 2 == end = do -- 4 4+ !a <- peek src+ !b <- peek (plusPtr src 1)++ let !t = look (unsafeShiftR (a .&. 0xf8) 3)+ !u = look ((unsafeShiftL (a .&. 0x07) 2) .|. (unsafeShiftR (b .&. 0xc0) 6))+ !v = look (unsafeShiftR (b .&. 0x3e) 1)+ !w = look (unsafeShiftL (b .&. 0x01) 4)++ poke dst t+ poke (plusPtr dst 1) u+ poke (plusPtr dst 2) v+ poke (plusPtr dst 3) w+ padN (plusPtr dst 4) 4++ | plusPtr src 3 == end = do -- 5 3+ !a <- peek src+ !b <- peek (plusPtr src 1)+ !c <- peek (plusPtr src 2)++ let !t = look (unsafeShiftR (a .&. 0xf8) 3)+ !u = look ((unsafeShiftL (a .&. 0x07) 2) .|. (unsafeShiftR (b .&. 0xc0) 6))+ !v = look (unsafeShiftR (b .&. 0x3e) 1)+ !w = look ((unsafeShiftL (b .&. 0x01) 4) .|. (unsafeShiftR (c .&. 0xf0) 4))+ !x = look (unsafeShiftL (c .&. 0x0f) 1)++ poke dst t+ poke (plusPtr dst 1) u+ poke (plusPtr dst 2) v+ poke (plusPtr dst 3) w+ poke (plusPtr dst 4) x+ padN (plusPtr dst 5) 3++ | plusPtr src 4 == end = do -- 7 1+ !a <- peek src+ !b <- peek (plusPtr src 1)+ !c <- peek (plusPtr src 2)+ !d <- peek (plusPtr src 3)++ let !t = look (unsafeShiftR (a .&. 0xf8) 3)+ !u = look ((unsafeShiftL (a .&. 0x07) 2) .|. (unsafeShiftR (b .&. 0xc0) 6))+ !v = look (unsafeShiftR (b .&. 0x3e) 1)+ !w = look ((unsafeShiftL (b .&. 0x01) 4) .|. (unsafeShiftR (c .&. 0xf0) 4))+ !x = look ((unsafeShiftL (c .&. 0x0f) 1) .|. (unsafeShiftR (d .&. 0x80) 7))+ !y = look (unsafeShiftR (d .&. 0x7c) 2)+ !z = look (unsafeShiftL (d .&. 0x03) 3)++ poke dst t+ poke (plusPtr dst 1) u+ poke (plusPtr dst 2) v+ poke (plusPtr dst 3) w+ poke (plusPtr dst 4) x+ poke (plusPtr dst 5) y+ poke (plusPtr dst 6) z+ padN (plusPtr dst 7) 1++ | otherwise = return ()+ where+ look !n = aix n lut++ padN :: Ptr Word8 -> Int -> IO ()+ padN !_ 0 = return ()+ padN !p n = poke p 0x3d >> padN (plusPtr p 1) (n - 1)+{-# INLINE loopTail #-}++-- | Unroll final quantum encoding for base32+--+loopTailNoPad+ :: Addr#+ -> ForeignPtr Word8+ -> Ptr Word8+ -> Ptr Word8+ -> Ptr Word8+ -> Int+ -> IO ByteString+loopTailNoPad !lut !dfp !end !dst !src !n+ | plusPtr src 1 == end = do -- 2 6+ !a <- peek src++ let !t = look (unsafeShiftR (a .&. 0xf8) 3)+ !u = look (unsafeShiftL (a .&. 0x07) 2)++ poke dst t+ poke (plusPtr dst 1) u++ return (PS dfp 0 (n + 2))++ | plusPtr src 2 == end = do -- 4 4+ !a <- peek src+ !b <- peek (plusPtr src 1)++ let !t = look (unsafeShiftR (a .&. 0xf8) 3)+ !u = look ((unsafeShiftL (a .&. 0x07) 2) .|. (unsafeShiftR (b .&. 0xc0) 6))+ !v = look (unsafeShiftR (b .&. 0x3e) 1)+ !w = look (unsafeShiftL (b .&. 0x01) 4)++ poke dst t+ poke (plusPtr dst 1) u+ poke (plusPtr dst 2) v+ poke (plusPtr dst 3) w++ return (PS dfp 0 (n + 4))++ | plusPtr src 3 == end = do -- 5 3+ !a <- peek src+ !b <- peek (plusPtr src 1)+ !c <- peek (plusPtr src 2)++ let !t = look (unsafeShiftR (a .&. 0xf8) 3)+ !u = look ((unsafeShiftL (a .&. 0x07) 2) .|. (unsafeShiftR (b .&. 0xc0) 6))+ !v = look (unsafeShiftR (b .&. 0x3e) 1)+ !w = look ((unsafeShiftL (b .&. 0x01) 4) .|. (unsafeShiftR (c .&. 0xf0) 4))+ !x = look (unsafeShiftL (c .&. 0x0f) 1)++ poke dst t+ poke (plusPtr dst 1) u+ poke (plusPtr dst 2) v+ poke (plusPtr dst 3) w+ poke (plusPtr dst 4) x+ return (PS dfp 0 (n + 5))++ | plusPtr src 4 == end = do -- 7 1+ !a <- peek src+ !b <- peek (plusPtr src 1)+ !c <- peek (plusPtr src 2)+ !d <- peek (plusPtr src 3)++ let !t = look (unsafeShiftR (a .&. 0xf8) 3)+ !u = look ((unsafeShiftL (a .&. 0x07) 2) .|. (unsafeShiftR (b .&. 0xc0) 6))+ !v = look (unsafeShiftR (b .&. 0x3e) 1)+ !w = look ((unsafeShiftL (b .&. 0x01) 4) .|. (unsafeShiftR (c .&. 0xf0) 4))+ !x = look ((unsafeShiftL (c .&. 0x0f) 1) .|. (unsafeShiftR (d .&. 0x80) 7))+ !y = look (unsafeShiftR (d .&. 0x7c) 2)+ !z = look (unsafeShiftL (d .&. 0x03) 3)++ poke dst t+ poke (plusPtr dst 1) u+ poke (plusPtr dst 2) v+ poke (plusPtr dst 3) w+ poke (plusPtr dst 4) x+ poke (plusPtr dst 5) y+ poke (plusPtr dst 6) z+ return (PS dfp 0 (n + 7))++ | otherwise = return (PS dfp 0 n)+ where+ look !i = aix i lut+{-# INLINE loopTailNoPad #-}++-- ------------------------------------------------------------------------ --+-- Decoding loops++decodeTail+ :: Addr#+ -> ForeignPtr Word8+ -> Ptr Word8+ -> Ptr Word8+ -> Ptr Word8+ -> Int+ -> IO (Either Text ByteString)+decodeTail !lut !dfp !end !dptr !sptr !n = go dptr sptr+ where+ lix a = aix a lut+ {-# INLINE lix #-}++ ps !m = return (Right (PS dfp 0 m))+ {-# INLINE ps #-}++ err = return . Left . T.pack+ {-# INLINE err #-}++ decodeOctet (!a,!b,!c,!d,!e,!f,!g,!h) =+ case (lix a, lix b, lix c, lix d, lix e, lix f, lix g, lix h) of+ (0xff,_,_,_,_,_,_,_) -> Left (0 :: Int)+ (_,0xff,_,_,_,_,_,_) -> Left 1+ (_,_,0xff,_,_,_,_,_) -> Left 2+ (_,_,_,0xff,_,_,_,_) -> Left 3+ (_,_,_,_,0xff,_,_,_) -> Left 4+ (_,_,_,_,_,0xff,_,_) -> Left 5+ (_,_,_,_,_,_,0xff,_) -> Left 6+ (_,_,_,_,_,_,_,0xff) -> Left 7+ (ri1,ri2,ri3,ri4,ri5,ri6,ri7,ri8) ->+ let !o1 = (ri1 `unsafeShiftL` 3) .|. (ri2 `unsafeShiftR` 2)+ !o2 = (ri2 `unsafeShiftL` 6) .|. (ri3 `unsafeShiftL` 1) .|. (ri4 `unsafeShiftR` 4)+ !o3 = (ri4 `unsafeShiftL` 4) .|. (ri5 `unsafeShiftR` 1)+ !o4 = (ri5 `unsafeShiftL` 7) .|. (ri6 `unsafeShiftL` 2) .|. (ri7 `unsafeShiftR` 3)+ !o5 = (ri7 `unsafeShiftL` 5) .|. ri8+ in Right (o1, o2, o3, o4, o5)++ go !dst !src+ | src == end = ps n+ | otherwise = do+ !a <- peek @Word8 src+ !b <- peek @Word8 (plusPtr src 1)+ !c <- peek @Word8 (plusPtr src 2)+ !d <- peek @Word8 (plusPtr src 3)+ !e <- peek @Word8 (plusPtr src 4)+ !f <- peek @Word8 (plusPtr src 5)+ !g <- peek @Word8 (plusPtr src 6)+ !h <- peek @Word8 (plusPtr src 7)++ let (!m, !c', !d', !e', !f', !g', !h') = case (c,d,e,f,g,h) of+ (0x3d,0x3d,0x3d,0x3d,0x3d,0x3d) -> (6,0x41,0x41,0x41,0x41,0x41,0x41)+ (_,0x3d,0x3d,0x3d,0x3d,0x3d) -> (5,c,0x41,0x41,0x41,0x41,0x41)+ (_,_,0x3d,0x3d,0x3d,0x3d) -> (4,c,d,0x41,0x41,0x41,0x41)+ (_,_,_,0x3d,0x3d,0x3d) -> (3,c,d,e,0x41,0x41,0x41)+ (_,_,_,_,0x3d,0x3d) -> (2,c,d,e,f,0x41,0x41)+ (_,_,_,_,_,0x3d) -> (1,c,d,e,f,g,0x41)+ _ -> (0 :: Int,c,d,e,f,g,h)++ case decodeOctet (a,b,c',d',e',f',g',h') of+ Left ofs -> err $ "invalid character at offset: " ++ show (n + ofs)+ Right (!v,!w,!x,!y,!z) -> do+ poke dst v+ poke (plusPtr dst 1) w++ if+ | m == 0 -> do+ poke (plusPtr dst 2) x+ poke (plusPtr dst 3) y+ poke (plusPtr dst 4) z+ ps (n + 5)+ | m == 1 -> do+ poke (plusPtr dst 2) x+ poke (plusPtr dst 3) y+ poke (plusPtr dst 4) z+ ps (n + 4)+ | m < 4 -> do+ poke (plusPtr dst 2) x+ poke (plusPtr dst 3) y+ ps (n + 3)+ | m < 5 -> do+ poke (plusPtr dst 2) x+ ps (n + 2)+ | otherwise -> ps (n + 1)
+ src/Data/ByteString/Base32/Internal/Utils.hs view
@@ -0,0 +1,56 @@+{-# LANGUAGE BangPatterns #-}+{-# LANGUAGE MagicHash #-}+module Data.ByteString.Base32.Internal.Utils+( aix+, w32+, w64+, w64_32+, writeNPlainForeignPtrBytes+) where++import Foreign.Ptr+import Foreign.ForeignPtr+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_32 :: Word32 -> Word64+w64_32 = fromIntegral+{-# INLINE w64_32 #-}++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+{-# INLINE writeNPlainForeignPtrBytes #-}
+ src/Data/Text/Encoding/Base32.hs view
@@ -0,0 +1,91 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module : Data.Text.Encoding.Base32+-- 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 Base32 encoding including+-- unpadded and lenient variants+--+module Data.Text.Encoding.Base32+( encodeBase32+, decodeBase32+, encodeBase32Unpadded+, decodeBase32Unpadded+-- , decodeBase32Lenient+, isBase32+, isValidBase32+) where+++import qualified Data.ByteString.Base32 as B32++import Data.Text (Text)+import qualified Data.Text.Encoding as T++-- | Encode a 'Text' value in Base32 with padding.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+encodeBase32 :: Text -> Text+encodeBase32 = B32.encodeBase32 . T.encodeUtf8+{-# INLINE encodeBase32 #-}++-- | Decode a padded Base32-encoded 'Text' value+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+decodeBase32 :: Text -> Either Text Text+decodeBase32 = fmap T.decodeUtf8 . B32.decodeBase32 . T.encodeUtf8+{-# INLINE decodeBase32 #-}++-- | Encode a 'Text' value in Base32 without padding.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+encodeBase32Unpadded :: Text -> Text+encodeBase32Unpadded = B32.encodeBase32 . T.encodeUtf8+{-# INLINE encodeBase32Unpadded #-}++-- | Decode an arbitrarily padded Base32-encoded 'Text'+--+-- See: <https://tools.ietf.org/html/rfc4648#section-3.2 RFC-4648 section 3.2>+--+decodeBase32Unpadded :: Text -> Either Text Text+decodeBase32Unpadded = fmap T.decodeUtf8+ . B32.decodeBase32Unpadded+ . T.encodeUtf8+{-# INLINE decodeBase32Unpadded #-}++-- -- | Leniently decode a Base32-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.+-- --+-- -- __Note:__ This is not RFC 4648-compliant.+-- --+-- decodeBase32Lenient :: Text -> Text+-- decodeBase32Lenient = T.decodeUtf8+-- . B32.decodeBase32Lenient+-- . T.encodeUtf8+-- {-# INLINE decodeBase32Lenient #-}++-- | Tell whether a 'Text' value is Base32-encoded.+--+isBase32 :: Text -> Bool+isBase32 = B32.isBase32 . T.encodeUtf8+{-# INLINE isBase32 #-}++-- | Tell whether a 'Text' value is a valid Base32 format.+--+-- This will not tell you whether or not this is a correct Base32 representation,+-- only that it conforms to the correct shape. To check whether it is a true+-- Base32 encoded 'Text' value, use 'isBase32'.+--+isValidBase32 :: Text -> Bool+isValidBase32 = B32.isValidBase32 . T.encodeUtf8+{-# INLINE isValidBase32 #-}
+ src/Data/Text/Encoding/Base32/Hex.hs view
@@ -0,0 +1,90 @@+{-# LANGUAGE OverloadedStrings #-}+-- |+-- Module : Data.Text.Encoding.Base32.Hex+-- 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 Base32-Hex encoding including+-- unpadded and lenient variants+module Data.Text.Encoding.Base32.Hex+( encodeBase32+, decodeBase32+, encodeBase32Unpadded+, decodeBase32Unpadded+-- , decodeBase32Lenient+, isBase32Hex+, isValidBase32Hex+) where+++import qualified Data.ByteString.Base32.Hex as B32U++import Data.Text (Text)+import qualified Data.Text.Encoding as T++-- | Encode a 'Text' value in Base32hex with padding.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-5 RFC-4648 section 5>+--+encodeBase32 :: Text -> Text+encodeBase32 = B32U.encodeBase32 . T.encodeUtf8+{-# INLINE encodeBase32 #-}++-- | Decode a padded Base32hex-encoded 'Text' value.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+decodeBase32 :: Text -> Either Text Text+decodeBase32 = fmap T.decodeUtf8 . B32U.decodeBase32 . T.encodeUtf8+{-# INLINE decodeBase32 #-}++-- | Encode a 'Text' value in Base32hex without padding.+--+-- See: <https://tools.ietf.org/html/rfc4648#section-3.2 RFC-4648 section 3.2>+--+encodeBase32Unpadded :: Text -> Text+encodeBase32Unpadded = B32U.encodeBase32Unpadded . T.encodeUtf8+{-# INLINE encodeBase32Unpadded #-}++-- | Decode an arbitrarily padded Base32hex encoded 'Text' value+--+-- See: <https://tools.ietf.org/html/rfc4648#section-4 RFC-4648 section 4>+--+decodeBase32Unpadded :: Text -> Either Text Text+decodeBase32Unpadded = fmap T.decodeUtf8+ . B32U.decodeBase32Unpadded+ . T.encodeUtf8+{-# INLINE decodeBase32Unpadded #-}++-- -- -- | Leniently decode an unpadded Base32hex-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.+-- -- --+-- -- -- __Note:__ This is not RFC 4648-compliant.+-- -- --+-- -- decodeBase32Lenient :: Text -> Text+-- -- decodeBase32Lenient = T.decodeUtf8+-- -- . B32U.decodeBase32Lenient+-- -- . T.encodeUtf8+-- -- {-# INLINE decodeBase32Lenient #-}++-- | Tell whether a 'Text' value is Base32hex-encoded.+--+isBase32Hex :: Text -> Bool+isBase32Hex = B32U.isBase32Hex . T.encodeUtf8+{-# INLINE isBase32Hex #-}++-- | Tell whether a 'Text' value is a valid Base32hex format.+--+-- This will not tell you whether or not this is a correct Base32hex representation,+-- only that it conforms to the correct shape. To check whether it is a true+-- Base32 encoded 'Text' value, use 'isBase32Hex'.+--+isValidBase32Hex :: Text -> Bool+isValidBase32Hex = B32U.isValidBase32Hex . T.encodeUtf8+{-# INLINE isValidBase32Hex #-}
+ test/Base32Tests.hs view
@@ -0,0 +1,148 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE PackageImports #-}+{-# LANGUAGE TypeApplications #-}+module Main+( main+, tests+) where+++import Data.Bifunctor+import Data.ByteString (ByteString)+import "base32" Data.ByteString.Base32 as B32+import "base32" Data.ByteString.Base32.Hex as B32H+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 "Base32 Tests"+ [ testVectors+ , sanityTests+ , alphabetTests+ ]++testVectors :: TestTree+testVectors = testGroup "RFC 4648 Test Vectors"+ [ testGroup "encode/decode"+ [ testCaseB32 "" ""+ , testCaseB32 "f" "MY======"+ , testCaseB32 "fo" "MZXQ===="+ , testCaseB32 "foo" "MZXW6==="+ , testCaseB32 "foob" "MZXW6YQ="+ , testCaseB32 "fooba" "MZXW6YTB"+ , testCaseB32 "foobar" "MZXW6YTBOI======"+ ]+ , testGroup "encode/decode hex"+ [ testCaseB32' "" ""+ , testCaseB32' "f" "CO======"+ , testCaseB32' "fo" "CPNG===="+ , testCaseB32' "foo" "CPNMU==="+ , testCaseB32' "foob" "CPNMUOG="+ , testCaseB32' "fooba" "CPNMUOJ1"+ , testCaseB32' "foobar" "CPNMUOJ1E8======"+ ]+ ]+ where+ testCaseB32 s t =+ testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do+ let t' = B32.encodeBase32' s+ s' = B32.decodeBase32 t'++ step "compare encoding + decoding w/ padding"+ t @=? t'++ step "compare decoding w/ padding"+ Right s @=? s'++ testCaseB32' s t =+ testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do+ let t' = B32H.encodeBase32' s+ s' = B32H.decodeBase32 t'+ u = B32H.encodeBase32' s+ v = B32H.decodeBase32 u++ step "compare hex encoding w/ padding"+ t @=? t'++ step "compare hex decoding w/ padding"+ Right s @=? s'++ step "compare hex encoding w/o padding"+ t @=? t'++ step "compare hex decoding w/o padding"+ Right s @=? v++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 $ B32.encodeBase32' bs+ void $ return $ B32H.encodeBase32' bs++ compare32 n = testCase ("Testing " ++ show n ++ "-sized bytestrings") $ do+ bs <- random n+ B32.encodeBase32' bs @=? Mem.convertToBase Mem.Base32 bs+ B32.decodeBase32 (B32.encodeBase32' bs) @=?+ first pack (Mem.convertFromBase @ByteString Mem.Base32 (Mem.convertToBase Mem.Base32 bs))++ roundtrip n = testCase ("Roundtrip encode/decode for " ++ show n ++ "-sized bytestrings") $ do+ bs <- random n+ B32.decodeBase32 (B32.encodeBase32' bs) @=? Right bs+ B32H.decodeBase32 (B32H.encodeBase32' bs) @=? Right bs++alphabetTests :: TestTree+alphabetTests = testGroup "Alphabet tests"+ [ base32Tests 0+ , base32Tests 4+ , base32Tests 5+ , base32Tests 6+ , base32Tests 100+ , base32HexTests 0+ , base32HexTests 4+ , base32HexTests 5+ , base32HexTests 6+ , base32HexTests 100+ ]+ where+ base32Tests n = testCase ("Conforms to Base32 alphabet: " ++ show n) $ do+ bs <- random n+ let b = B32.encodeBase32' bs+ assertBool ("failed validity: " ++ show b) $ B32.isValidBase32 b+ assertBool ("failed correctness: " ++ show b) $ B32.isBase32 b++ base32HexTests n = testCase ("Conforms to Base32hex alphabet: " ++ show n) $ do+ bs <- random n+ let b = B32H.encodeBase32' bs+ assertBool ("failed validity: " ++ show b) $ B32H.isValidBase32Hex b+ assertBool ("failed correctness: " ++ show b) $ B32H.isBase32Hex b