diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for base32 + +## 0.1.0.0 -- 2020-02-16 + +* First version. Released on an unsuspecting world. diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,22 @@ +# Base32 + +[![Build Status](https://travis-ci.com/emilypi/base32.svg?branch=master)](https://travis-ci.com/emilypi/base32) +[![Hackage](https://img.shields.io/hackage/v/base32.svg)](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: + +![base32 dependencies](https://i.imgur.com/8CdVsey.png) diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/base32.cabal b/base32.cabal new file mode 100644 --- /dev/null +++ b/base32.cabal @@ -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 diff --git a/benchmarks/Base32Bench.hs b/benchmarks/Base32Bench.hs new file mode 100644 --- /dev/null +++ b/benchmarks/Base32Bench.hs @@ -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) diff --git a/src/Data/ByteString/Base32.hs b/src/Data/ByteString/Base32.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base32.hs @@ -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 +-- 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: +-- +encodeBase32 :: ByteString -> Text +encodeBase32 = T.decodeUtf8 . encodeBase32' +{-# INLINE encodeBase32 #-} + +-- | Encode a 'ByteString' value as a Base32 'ByteString' value with padding. +-- +-- See: +-- +encodeBase32' :: ByteString -> ByteString +encodeBase32' = encodeBase32_ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# +{-# INLINE encodeBase32' #-} + +-- | Decode a padded Base32-encoded 'ByteString' value. +-- +-- See: +-- +decodeBase32 :: ByteString -> Either Text ByteString +decodeBase32 = decodeBase32_ False stdDecodeTable +{-# INLINE decodeBase32 #-} + +-- | Encode a 'ByteString' value as a Base32 'Text' value without padding. +-- +-- See: +-- +encodeBase32Unpadded :: ByteString -> Text +encodeBase32Unpadded = T.decodeUtf8 . encodeBase32Unpadded' +{-# INLINE encodeBase32Unpadded #-} + +-- | Encode a 'ByteString' value as a Base32 'ByteString' value with padding. +-- +-- See: +-- +encodeBase32Unpadded' :: ByteString -> ByteString +encodeBase32Unpadded' = encodeBase32NoPad_ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# +{-# INLINE encodeBase32Unpadded' #-} + +-- | Decode an arbitarily padded Base32-encoded 'ByteString' value. +-- +-- See: +-- +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 #-} diff --git a/src/Data/ByteString/Base32/Hex.hs b/src/Data/ByteString/Base32/Hex.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base32/Hex.hs @@ -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 +-- 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: +-- +encodeBase32 :: ByteString -> Text +encodeBase32 = T.decodeUtf8 . encodeBase32' +{-# INLINE encodeBase32 #-} + +-- | Encode a 'ByteString' as a Base32hex 'ByteString' value with padding. +-- +-- See: +-- +encodeBase32' :: ByteString -> ByteString +encodeBase32' = encodeBase32_ "0123456789ABCDEFGHIJKLMNOPQRSTUV"# +{-# INLINE encodeBase32' #-} + +-- | Decode a padded Base32hex encoded 'ByteString' value. +-- +-- See: +-- +decodeBase32 :: ByteString -> Either Text ByteString +decodeBase32 = decodeBase32_ False hexDecodeTable +{-# INLINE decodeBase32 #-} + +-- | Encode a 'ByteString' as a Base32hex 'Text' value without padding. +-- +-- See: +-- +encodeBase32Unpadded :: ByteString -> Text +encodeBase32Unpadded = T.decodeUtf8 . encodeBase32Unpadded' +{-# INLINE encodeBase32Unpadded #-} + +-- | Encode a 'ByteString' as a Base32hex 'ByteString' value without padding. +-- +-- See: +-- +encodeBase32Unpadded' :: ByteString -> ByteString +encodeBase32Unpadded' = encodeBase32NoPad_ "0123456789ABCDEFGHIJKLMNOPQRSTUV"# +{-# INLINE encodeBase32Unpadded' #-} + +-- | Decode an arbitrarily padded Base32hex encoded 'ByteString' value. +-- +-- See: +-- +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 #-} diff --git a/src/Data/ByteString/Base32/Internal.hs b/src/Data/ByteString/Base32/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base32/Internal.hs @@ -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 +-- 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 #-} diff --git a/src/Data/ByteString/Base32/Internal/Head.hs b/src/Data/ByteString/Base32/Internal/Head.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base32/Internal/Head.hs @@ -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) diff --git a/src/Data/ByteString/Base32/Internal/Loop.hs b/src/Data/ByteString/Base32/Internal/Loop.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base32/Internal/Loop.hs @@ -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) diff --git a/src/Data/ByteString/Base32/Internal/Tables.hs b/src/Data/ByteString/Base32/Internal/Tables.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base32/Internal/Tables.hs @@ -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 #-} diff --git a/src/Data/ByteString/Base32/Internal/Tail.hs b/src/Data/ByteString/Base32/Internal/Tail.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base32/Internal/Tail.hs @@ -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) diff --git a/src/Data/ByteString/Base32/Internal/Utils.hs b/src/Data/ByteString/Base32/Internal/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base32/Internal/Utils.hs @@ -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 #-} diff --git a/src/Data/Text/Encoding/Base32.hs b/src/Data/Text/Encoding/Base32.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Encoding/Base32.hs @@ -0,0 +1,91 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Data.Text.Encoding.Base32 +-- Copyright : (c) 2019 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- 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: +-- +encodeBase32 :: Text -> Text +encodeBase32 = B32.encodeBase32 . T.encodeUtf8 +{-# INLINE encodeBase32 #-} + +-- | Decode a padded Base32-encoded 'Text' value +-- +-- See: +-- +decodeBase32 :: Text -> Either Text Text +decodeBase32 = fmap T.decodeUtf8 . B32.decodeBase32 . T.encodeUtf8 +{-# INLINE decodeBase32 #-} + +-- | Encode a 'Text' value in Base32 without padding. +-- +-- See: +-- +encodeBase32Unpadded :: Text -> Text +encodeBase32Unpadded = B32.encodeBase32 . T.encodeUtf8 +{-# INLINE encodeBase32Unpadded #-} + +-- | Decode an arbitrarily padded Base32-encoded 'Text' +-- +-- See: +-- +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 #-} diff --git a/src/Data/Text/Encoding/Base32/Hex.hs b/src/Data/Text/Encoding/Base32/Hex.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Encoding/Base32/Hex.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE OverloadedStrings #-} +-- | +-- Module : Data.Text.Encoding.Base32.Hex +-- Copyright : (c) 2019 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- 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: +-- +encodeBase32 :: Text -> Text +encodeBase32 = B32U.encodeBase32 . T.encodeUtf8 +{-# INLINE encodeBase32 #-} + +-- | Decode a padded Base32hex-encoded 'Text' value. +-- +-- See: +-- +decodeBase32 :: Text -> Either Text Text +decodeBase32 = fmap T.decodeUtf8 . B32U.decodeBase32 . T.encodeUtf8 +{-# INLINE decodeBase32 #-} + +-- | Encode a 'Text' value in Base32hex without padding. +-- +-- See: +-- +encodeBase32Unpadded :: Text -> Text +encodeBase32Unpadded = B32U.encodeBase32Unpadded . T.encodeUtf8 +{-# INLINE encodeBase32Unpadded #-} + +-- | Decode an arbitrarily padded Base32hex encoded 'Text' value +-- +-- See: +-- +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 #-} diff --git a/test/Base32Tests.hs b/test/Base32Tests.hs new file mode 100644 --- /dev/null +++ b/test/Base32Tests.hs @@ -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