diff --git a/CHANGELOG.md b/CHANGELOG.md --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,15 @@ # Revision history for base32 +## 0.2.0.0 + +* Bugfix: fix unpadded base32 encoding ([#4](https://github.com/emilypi/Base32/pull/4)) +* Bugfix: Use `decodeLatin1` when decoding, defer to `decodeWith*` primitives for finer-grained + `Text` to `ByteString` conversions. ([#5](https://github.com/emilypi/Base32/pull/5)) +* Add short and lazy variants for `Text` and `ByteString` ([#6](https://github.com/emilypi/Base32/pull/6)) +* Expanded test coverage to 96% ([#7](https://github.com/emilypi/Base32/pull/7)) +* Improved performance and better error reporting in final quanta ([#9](https://github.com/emilypi/Base32/pull/9)) +* Improved docs + trustworthy/safe annotations ([#10](https://github.com/emilypi/Base32/pull/10)) + ## 0.1.1.1 -- 2020-02-16 * Documentation now references correct RFC section diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -7,16 +7,21 @@ 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: +The following types are supported for both padded and unpadded std and extended hex alphabets: -- 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 +- `Data.ByteString` +- `Data.ByteString.Lazy` +- `Data.ByteString.Short` +- `Data.Text` +- `Data.Text.Lazy` +- `Data.Text.Short` -There are no dependencies aside from those bundled with GHC: +Additionally this library has -![base32 dependencies](https://i.imgur.com/8CdVsey.png) +- Better performance than `memory` for encode and decode 3-4x. +- Optics for handling more complex structures with Base32 representations via the `base32-lens` package +- Checks for both validity and correctness of Base32 and Base32hex encodings + +There are no dependencies aside from those bundled with GHC, `text-short`, and the `ghc-byteorder` re-export. diff --git a/base32.cabal b/base32.cabal --- a/base32.cabal +++ b/base32.cabal @@ -1,7 +1,7 @@ cabal-version: 2.0 name: base32 -version: 0.1.1.2 -synopsis: RFC 4648-compliant Base32 encodings/decodings +version: 0.2.0.0 +synopsis: Fast RFC 4648-compliant Base32 encoding description: RFC 4648-compliant Base32 encodings and decodings. This library provides performant encoding and decoding primitives, as well as support for textual values. @@ -30,8 +30,17 @@ exposed-modules: Data.ByteString.Base32 Data.ByteString.Base32.Hex + Data.ByteString.Lazy.Base32 + Data.ByteString.Lazy.Base32.Hex + Data.ByteString.Short.Base32 + Data.ByteString.Short.Base32.Hex Data.Text.Encoding.Base32 + Data.Text.Encoding.Base32.Error Data.Text.Encoding.Base32.Hex + Data.Text.Lazy.Encoding.Base32 + Data.Text.Lazy.Encoding.Base32.Hex + Data.Text.Short.Encoding.Base32 + Data.Text.Short.Encoding.Base32.Hex other-modules: Data.ByteString.Base32.Internal @@ -42,9 +51,12 @@ Data.ByteString.Base32.Internal.Utils build-depends: - base >=4.10 && <5 - , bytestring ^>=0.10 - , text ^>=1.2 + base >=4.10 && <5 + , bytestring ^>=0.10 + , deepseq >=1.4.3.0 && <1.4.5.0 + , ghc-byteorder ^>=4.11.0.0 + , text ^>=1.2 + , text-short ^>=0.1 hs-source-dirs: src default-language: Haskell2010 @@ -54,16 +66,20 @@ default-language: Haskell2010 type: exitcode-stdio-1.0 hs-source-dirs: test - main-is: Base32Tests.hs + other-modules: Internal + main-is: Main.hs build-depends: base >=4.10 && <5 , base32 , bytestring , memory + , QuickCheck , random-bytestring , tasty , tasty-hunit + , tasty-quickcheck , text + , text-short benchmark bench default-language: Haskell2010 diff --git a/benchmarks/Base32Bench.hs b/benchmarks/Base32Bench.hs --- a/benchmarks/Base32Bench.hs +++ b/benchmarks/Base32Bench.hs @@ -20,33 +20,62 @@ bgroup "encode" [ bgroup "25" [ bench "memory" $ whnf ctob bs25 - , bench "base64" $ whnf B32.encodeBase32' bs25 + , bench "base32" $ whnf B32.encodeBase32' bs25 ] , bgroup "100" [ bench "memory" $ whnf ctob bs100 - , bench "base64" $ whnf B32.encodeBase32' bs100 + , bench "base32" $ whnf B32.encodeBase32' bs100 ] , bgroup "1k" [ bench "memory" $ whnf ctob bs1k - , bench "base64" $ whnf B32.encodeBase32' bs1k + , bench "base32" $ whnf B32.encodeBase32' bs1k ] , bgroup "10k" [ bench "memory" $ whnf ctob bs10k - , bench "base64" $ whnf B32.encodeBase32' bs10k + , bench "base32" $ whnf B32.encodeBase32' bs10k ] , bgroup "100k" [ bench "memory" $ whnf ctob bs100k - , bench "base64" $ whnf B32.encodeBase32' bs100k + , bench "base32" $ whnf B32.encodeBase32' bs100k ] , bgroup "1mm" [ bench "memory" $ whnf ctob bs1mm - , bench "base64" $ whnf B32.encodeBase32' bs1mm + , bench "base32" $ whnf B32.encodeBase32' bs1mm ] ] + , env bs' $ \ ~(bs25,bs100,bs1k,bs10k,bs100k,bs1mm) -> + bgroup "decode" + [ bgroup "25" + [ bench "memory" $ whnf btoc bs25 + , bench "base32" $ whnf B32.decodeBase32 bs25 + ] + , bgroup "100" + [ bench "memory" $ whnf btoc bs100 + , bench "base32" $ whnf B32.decodeBase32 bs100 + ] + , bgroup "1k" + [ bench "memory" $ whnf btoc bs1k + , bench "base32" $ whnf B32.decodeBase32 bs1k + ] + , bgroup "10k" + [ bench "memory" $ whnf btoc bs10k + , bench "base32" $ whnf B32.decodeBase32 bs10k + ] + , bgroup "100k" + [ bench "memory" $ whnf btoc bs100k + , bench "base32" $ whnf B32.decodeBase32 bs100k + ] + , bgroup "1mm" + [ bench "memory" $ whnf btoc bs1mm + , bench "base32" $ whnf B32.decodeBase32 bs1mm + ] + ] ] where ctob :: ByteString -> ByteString ctob = Mem.convertToBase Mem.Base32 + btoc :: ByteString -> Either String ByteString + btoc = Mem.convertFromBase Mem.Base32 bs = do a <- random 25 @@ -55,4 +84,13 @@ d <- random 10000 e <- random 100000 f <- random 1000000 + return (a,b,c,d,e,f) + + bs' = do + a <- B32.encodeBase32' <$> random 25 + b <- B32.encodeBase32' <$> random 100 + c <- B32.encodeBase32' <$> random 1000 + d <- B32.encodeBase32' <$> random 10000 + e <- B32.encodeBase32' <$> random 100000 + f <- B32.encodeBase32' <$> random 1000000 return (a,b,c,d,e,f) diff --git a/src/Data/ByteString/Base32.hs b/src/Data/ByteString/Base32.hs --- a/src/Data/ByteString/Base32.hs +++ b/src/Data/ByteString/Base32.hs @@ -1,18 +1,20 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} -- | -- Module : Data.ByteString.Base32 --- Copyright : (c) 2020 Emily Pillmore --- License : BSD-style +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style -- --- Maintainer : Emily Pillmore --- Stability : Experimental --- Portability : portable +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable -- --- This module contains the combinators implementing the --- RFC 4648 specification for the Base32 encoding including --- unpadded and lenient variants +-- This module contains 'Data.ByteString.ByteString'-valued combinators for +-- implementing the RFC 4648 specification of the Base32 +-- encoding format. This includes padded and unpadded decoding variants, as well as +-- internal and external validation for canonicity. -- module Data.ByteString.Base32 ( encodeBase32 @@ -21,13 +23,15 @@ , encodeBase32Unpadded , encodeBase32Unpadded' , decodeBase32Unpadded +, decodeBase32Padded -- , decodeBase32Lenient , isBase32 , isValidBase32 ) where -import Data.ByteString (ByteString) +import qualified Data.ByteString as BS +import Data.ByteString.Internal (ByteString(..)) import Data.ByteString.Base32.Internal import Data.ByteString.Base32.Internal.Head import Data.ByteString.Base32.Internal.Tables @@ -35,59 +39,147 @@ import Data.Text (Text) import qualified Data.Text.Encoding as T +import System.IO.Unsafe (unsafeDupablePerformIO) --- | Encode a 'ByteString' value as Base32 'Text' with padding. + +-- | Encode a 'ByteString' value as a Base32 'Text' value with padding. -- -- See: -- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "KN2W4===" +-- encodeBase32 :: ByteString -> Text encodeBase32 = T.decodeUtf8 . encodeBase32' {-# INLINE encodeBase32 #-} --- | Encode a 'ByteString' value as a Base32 'ByteString' value with padding. +-- | Encode a 'ByteString' value as a Base32 'ByteString' value with padding. -- -- See: -- +-- === __Examples__: +-- +-- >>> encodeBase32' "Sun" +-- "KN2W4===" +-- encodeBase32' :: ByteString -> ByteString encodeBase32' = encodeBase32_ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# {-# INLINE encodeBase32' #-} --- | Decode a padded Base32-encoded 'ByteString' value. +-- | Decode an arbitrarily padded Base32-encoded 'ByteString' value. If its length +-- is not a multiple of 8, then padding characters will be added to fill out the +-- input to a multiple of 8 for safe decoding, as Base32-encoded values are +-- optionally padded. -- -- See: -- +-- === __Examples__: +-- +-- >>> decodeBase32 "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W===" +-- Left "Base32-encoded bytestring has invalid padding" +-- decodeBase32 :: ByteString -> Either Text ByteString -decodeBase32 = decodeBase32_ False stdDecodeTable +decodeBase32 bs@(PS _ _ !l) + | l == 0 = Right bs + | r == 0 = unsafeDupablePerformIO $ decodeBase32_ dlen stdDecodeTable bs + | r == 2 = unsafeDupablePerformIO $ decodeBase32_ dlen stdDecodeTable (BS.append bs "======") + | r == 4 = validateLastNPads 2 bs $ decodeBase32_ dlen stdDecodeTable (BS.append bs "====") + | r == 5 = validateLastNPads 3 bs $ decodeBase32_ dlen stdDecodeTable (BS.append bs "===") + | r == 7 = validateLastNPads 5 bs $ decodeBase32_ dlen stdDecodeTable (BS.append bs "=") + | otherwise = Left "Base32-encoded bytestring has invalid size" + where + !r = l `rem` 8 + !q = l `quot` 8 + !dlen = q * 5 {-# INLINE decodeBase32 #-} -- | Encode a 'ByteString' value as a Base32 'Text' value without padding. -- --- See: , --- +-- See: -- +-- === __Examples__: -- +-- >>> encodeBase32Unpadded "Sun" +-- "KN2W4" +-- encodeBase32Unpadded :: ByteString -> Text encodeBase32Unpadded = T.decodeUtf8 . encodeBase32Unpadded' {-# INLINE encodeBase32Unpadded #-} --- | Encode a 'ByteString' value as a Base32 'ByteString' value with padding. +-- | Encode a 'ByteString' value as a Base32 'ByteString' value without padding. -- --- See: , --- +-- See: -- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "KN2W4" +-- encodeBase32Unpadded' :: ByteString -> ByteString encodeBase32Unpadded' = encodeBase32NoPad_ "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567"# {-# INLINE encodeBase32Unpadded' #-} --- | Decode an arbitarily padded Base32-encoded 'ByteString' value. +-- | Decode an unpadded Base32-encoded 'ByteString' value. -- --- See: , --- +-- See: -- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "KN2W4===" +-- Left "Base32-encoded bytestring has invalid padding" +-- decodeBase32Unpadded :: ByteString -> Either Text ByteString -decodeBase32Unpadded = decodeBase32_ True stdDecodeTable +decodeBase32Unpadded bs@(PS _ _ !l) + | l == 0 = Right bs + | r == 0 = validateLastNPads 1 bs $ decodeBase32_ dlen stdDecodeTable bs + | r == 2 = unsafeDupablePerformIO $ decodeBase32_ dlen stdDecodeTable (BS.append bs "======") + | r == 4 = validateLastNPads 1 bs $ decodeBase32_ dlen stdDecodeTable (BS.append bs "====") + | r == 5 = validateLastNPads 1 bs $ decodeBase32_ dlen stdDecodeTable (BS.append bs "===") + | r == 7 = validateLastNPads 1 bs $ decodeBase32_ dlen stdDecodeTable (BS.append bs "=") + | otherwise = Left "Base32-encoded bytestring has invalid size" + where + !q = l `quot` 8 + !r = l `rem` 8 + !dlen = q * 5 {-# INLINE decodeBase32Unpadded #-} +-- | Decode a padded Base32-encoded 'ByteString' value. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "KN2W4" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: ByteString -> Either Text ByteString +decodeBase32Padded bs@(PS _ _ !l) + | l == 0 = Right bs + | r == 1 = Left "Base32-encoded bytestring has invalid size" + | r == 3 = Left "Base32-encoded bytestring has invalid size" + | r == 6 = Left "Base32-encoded bytestring has invalid size" + | r /= 0 = Left "Base32-encoded bytestring requires padding" + | otherwise = unsafeDupablePerformIO $ decodeBase32_ dlen stdDecodeTable bs + where + !q = l `quot` 8 + !r = l `rem` 8 + !dlen = q * 5 +{-# INLINE decodeBase32Padded #-} + -- -- | 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. @@ -98,8 +190,19 @@ -- decodeBase32Lenient = decodeBase32Lenient_ decodeB32Table -- {-# INLINE decodeBase32Lenient #-} --- | Tell whether a 'ByteString' value is base32 encoded. +-- | Tell whether a 'ByteString' value is encoded in padded or unpadded Base32 format -- +-- === __Examples__: +-- +-- >>> isBase32 "KN2W4" +-- True +-- +-- >>> isBase32 "KN2W4===" +-- True +-- +-- >>> isBase32 "KN2W4==" +-- False +-- isBase32 :: ByteString -> Bool isBase32 bs = isValidBase32 bs && isRight (decodeBase32 bs) {-# INLINE isBase32 #-} @@ -107,8 +210,19 @@ -- | 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'. +-- only that it conforms to the correct shape (including padding/size etc.). +-- To check whether it is a true Base32 encoded 'ByteString' value, use 'isBase32'. +-- +-- === __Examples__: +-- +-- >>> isValidBase32 "KN2W4" +-- True +-- +-- >>> isValidBase32 "KN2W4=" +-- False +-- +-- >>> isValidBase32 "KN2W4%" +-- False -- isValidBase32 :: ByteString -> Bool isValidBase32 = validateBase32 "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567" diff --git a/src/Data/ByteString/Base32/Hex.hs b/src/Data/ByteString/Base32/Hex.hs --- a/src/Data/ByteString/Base32/Hex.hs +++ b/src/Data/ByteString/Base32/Hex.hs @@ -1,18 +1,20 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE MagicHash #-} {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} -- | -- Module : Data.ByteString.Base32.Hex --- Copyright : (c) 2020 Emily Pillmore --- License : BSD-style +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style -- --- Maintainer : Emily Pillmore --- Stability : Experimental --- Portability : portable +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable -- --- This module contains the combinators implementing the --- RFC 4648 specification for the Base32-Hex encoding including --- unpadded and lenient variants +-- This module contains 'Data.ByteString.ByteString'-valued combinators for +-- implementing the RFC 4648 specification of the Base32hex +-- encoding format. This includes padded and unpadded decoding variants, as well as +-- internal and external validation for canonicity. -- module Data.ByteString.Base32.Hex ( encodeBase32 @@ -21,12 +23,15 @@ , encodeBase32Unpadded , encodeBase32Unpadded' , decodeBase32Unpadded +, decodeBase32Padded -- , decodeBase32Lenient , isBase32Hex , isValidBase32Hex ) where -import Data.ByteString (ByteString) + +import qualified Data.ByteString as BS +import Data.ByteString.Internal (ByteString(..)) import Data.ByteString.Base32.Internal import Data.ByteString.Base32.Internal.Head import Data.ByteString.Base32.Internal.Tables @@ -34,79 +39,180 @@ import Data.Text (Text) import qualified Data.Text.Encoding as T +import System.IO.Unsafe (unsafeDupablePerformIO) + -- | Encode a 'ByteString' value as a Base32hex 'Text' value with padding. -- -- See: -- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "ADQMS===" +-- encodeBase32 :: ByteString -> Text encodeBase32 = T.decodeUtf8 . encodeBase32' {-# INLINE encodeBase32 #-} --- | Encode a 'ByteString' as a Base32hex 'ByteString' value with padding. +-- | Encode a 'ByteString' value as a Base32hex 'ByteString' value with padding. -- -- See: -- +-- === __Examples__: +-- +-- >>> encodeBase32' "Sun" +-- "ADQMS===" +-- encodeBase32' :: ByteString -> ByteString encodeBase32' = encodeBase32_ "0123456789ABCDEFGHIJKLMNOPQRSTUV"# {-# INLINE encodeBase32' #-} --- | Decode a padded Base32hex encoded 'ByteString' value. +-- | Decode an arbitrarily padded Base32hex-encoded 'ByteString' value. If its length +-- is not a multiple of 8, then padding characters will be added to fill out the +-- input to a multiple of 8 for safe decoding, as Base32hex-encoded values are +-- optionally padded. -- -- See: -- +-- === __Examples__: +-- +-- >>> decodeBase32 "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQM===" +-- Left "Base32-encoded bytestring has invalid padding" +-- decodeBase32 :: ByteString -> Either Text ByteString -decodeBase32 = decodeBase32_ False hexDecodeTable +decodeBase32 bs@(PS _ _ !l) + | l == 0 = Right bs + | r == 0 = unsafeDupablePerformIO $ decodeBase32_ dlen hexDecodeTable bs + | r == 2 = unsafeDupablePerformIO $ decodeBase32_ dlen hexDecodeTable (BS.append bs "======") + | r == 4 = validateLastNPads 2 bs $ decodeBase32_ dlen hexDecodeTable (BS.append bs "====") + | r == 5 = validateLastNPads 3 bs $ decodeBase32_ dlen hexDecodeTable (BS.append bs "===") + | r == 7 = validateLastNPads 5 bs $ decodeBase32_ dlen hexDecodeTable (BS.append bs "=") + | otherwise = Left "Base32-encoded bytestring has invalid size" + where + !r = l `rem` 8 + !q = l `quot` 8 + !dlen = q * 8 {-# INLINE decodeBase32 #-} --- | Encode a 'ByteString' as a Base32hex 'Text' value without padding. +-- | Encode a 'ByteString' value as a Base32hex 'Text' value without padding. -- --- See: , --- +-- See: -- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "ADQMS" +-- encodeBase32Unpadded :: ByteString -> Text encodeBase32Unpadded = T.decodeUtf8 . encodeBase32Unpadded' {-# INLINE encodeBase32Unpadded #-} --- | Encode a 'ByteString' as a Base32hex 'ByteString' value without padding. +-- | Encode a 'ByteString' value as a Base32hex 'ByteString' value without padding. -- --- See: , --- +-- See: -- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "ADQMS" +-- encodeBase32Unpadded' :: ByteString -> ByteString encodeBase32Unpadded' = encodeBase32NoPad_ "0123456789ABCDEFGHIJKLMNOPQRSTUV"# {-# INLINE encodeBase32Unpadded' #-} --- | Decode an arbitrarily padded Base32hex encoded 'ByteString' value. +-- | Decode an unpadded Base32hex-encoded 'ByteString' value. -- --- See: , --- +-- See: -- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- decodeBase32Unpadded :: ByteString -> Either Text ByteString -decodeBase32Unpadded = decodeBase32_ True hexDecodeTable +decodeBase32Unpadded bs@(PS _ _ !l) + | l == 0 = Right bs + | r == 0 = validateLastNPads 1 bs $ decodeBase32_ dlen hexDecodeTable bs + | r == 2 = unsafeDupablePerformIO $ decodeBase32_ dlen hexDecodeTable (BS.append bs "======") + | r == 4 = validateLastNPads 1 bs $ decodeBase32_ dlen hexDecodeTable (BS.append bs "====") + | r == 5 = validateLastNPads 1 bs $ decodeBase32_ dlen hexDecodeTable (BS.append bs "===") + | r == 7 = validateLastNPads 1 bs $ decodeBase32_ dlen hexDecodeTable (BS.append bs "=") + | otherwise = Left "Base32-encoded bytestring has invalid size" + where + !q = l `quot` 8 + !r = l `rem` 8 + !dlen = q * 5 {-# 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 #-} +-- | Decode a padded Base32hex-encoded 'ByteString' value. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "ADQMS" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: ByteString -> Either Text ByteString +decodeBase32Padded bs@(PS _ _ !l) + | l == 0 = Right bs + | r == 1 = Left "Base32-encoded bytestring has invalid size" + | r == 3 = Left "Base32-encoded bytestring has invalid size" + | r == 6 = Left "Base32-encoded bytestring has invalid size" + | r /= 0 = Left "Base32-encoded bytestring requires padding" + | otherwise = unsafeDupablePerformIO $ decodeBase32_ dlen hexDecodeTable bs + where + !q = l `quot` 8 + !r = l `rem` 8 + !dlen = q * 5 +{-# INLINE decodeBase32Padded #-} --- | Tell whether a 'ByteString' is Base32hex-encoded. +-- | Tell whether a 'ByteString' value is encoded in padded or unpadded Base32hex format -- +-- === __Examples__: +-- +-- >>> isBase32Hex "ADQMS" +-- True +-- +-- >>> isBase32Hex "ADQMS===" +-- True +-- +-- >>> isBase32Hex "ADQMS==" +-- False +-- isBase32Hex :: ByteString -> Bool isBase32Hex bs = isValidBase32Hex bs && isRight (decodeBase32 bs) {-# INLINE isBase32Hex #-} --- | Tell whether a 'ByteString' is a valid Base32hex format. +-- | Tell whether a 'ByteString' 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 'ByteString' value, use 'isBase32Hex'. +-- only that it conforms to the correct shape (including padding/size etc.). +-- To check whether it is a true Base32hex encoded 'ByteString' value, use 'isBase32'. +-- +-- === __Examples__: +-- +-- >>> isValidBase32Hex "ADQMS" +-- True +-- +-- >>> isValidBase32Hex "ADQMS=" +-- False +-- +-- >>> isValidBase32Hex "ADQMS%" +-- False -- isValidBase32Hex :: ByteString -> Bool isValidBase32Hex = validateBase32 "0123456789ABCDEFGHIJKLMNOPQRSTUV" diff --git a/src/Data/ByteString/Base32/Internal.hs b/src/Data/ByteString/Base32/Internal.hs --- a/src/Data/ByteString/Base32/Internal.hs +++ b/src/Data/ByteString/Base32/Internal.hs @@ -18,30 +18,46 @@ -- module Data.ByteString.Base32.Internal ( validateBase32 +, validateLastNPads ) where import qualified Data.ByteString as BS import Data.ByteString.Internal +import Data.Text (Text) import Foreign.ForeignPtr import Foreign.Ptr import Foreign.Storable +import GHC.Word + +import System.IO.Unsafe + -- -------------------------------------------------------------------------- -- --- Validating Base64 +-- Validating Base32 validateBase32 :: ByteString -> ByteString -> Bool -validateBase32 !alphabet (PS fp off l) = - accursedUnutterablePerformIO $ withForeignPtr fp $ \p -> - go (plusPtr p off) (plusPtr p (l + off)) +validateBase32 !alphabet bs@(PS _ _ l) + | l == 0 = True + | r == 0 = f bs + | r == 2 = f (BS.append bs "======") + | r == 4 = f (BS.append bs "====") + | r == 5 = f (BS.append bs "===") + | r == 7 = f (BS.append bs "=") + | otherwise = False where + r = l `rem` 8 + + f (PS fp o l') = accursedUnutterablePerformIO $ withForeignPtr fp $ \p -> + go (plusPtr p o) (plusPtr p (l' + o)) + go !p !end | p == end = return True | otherwise = do w <- peek p - let f a + let check a | a == 0x3d, plusPtr p 1 == end = True | a == 0x3d, plusPtr p 2 == end = True | a == 0x3d, plusPtr p 3 == end = True @@ -51,5 +67,53 @@ | a == 0x3d = False | otherwise = BS.elem a alphabet - if f w then go (plusPtr p 1) end else return False + if check w then go (plusPtr p 1) end else return False {-# INLINE validateBase32 #-} + +-- | This function checks that the last N-chars of a bytestring are '=' +-- and, if true, fails with a message or completes some io action. +-- +-- This is necessary to check when decoding permissively (i.e. filling in padding chars). +-- Consider the following 8 cases of a string of length l: +-- +-- l = 0 mod 8: No pad chars are added, since the input is assumed to be good. +-- l = 1 mod 8: Never an admissible length in base32 +-- l = 2 mod 8: 6 padding chars are added. If padding chars are present in the string, they will fail as to decode as final quanta +-- l = 3 mod 8: Never an admissible length in base32 +-- l = 4 mod 8: 4 padding chars are added. If 2 padding chars are present in the string this can be "completed" in the sense that +-- it now acts like a string `l == 2 mod 8` with 6 padding chars, and could potentially form corrupted data. +-- l = 5 mod 8: 3 padding chars are added. If 3 padding chars are present in the string, this could form corrupted data like in the +-- previous case. +-- l = 6 mod 8: Never an admissible length in base32 +-- l = 7 mod 8: 1 padding char is added. If 5 padding chars are present in the string, this could form corrupted data like the +-- previous cases. +-- +-- Hence, permissive decodes should only fill in padding chars when it makes sense to add them. That is, +-- if an input is degenerate, it should never succeed when we add padding chars. We need the following invariant to hold: +-- +-- @ +-- B32.decodeUnpadded <|> B32.decodePadded ~ B32.decode +-- @ +-- +validateLastNPads + :: Int + -> ByteString + -> IO (Either Text ByteString) + -> Either Text ByteString +validateLastNPads !n (PS !fp !o !l) io + | not valid = Left "Base32-encoded bytestring has invalid padding" + | otherwise = unsafeDupablePerformIO io + where + !lo = l + o + valid = accursedUnutterablePerformIO $ withForeignPtr fp $ \p -> do + let end = plusPtr p lo + + let go :: Ptr Word8 -> IO Bool + go !q + | q == end = return True + | otherwise = do + a <- peek q + if a == 0x3d then return False else go (plusPtr q 1) + + go (plusPtr p (lo - n)) +{-# INLINE validateLastNPads #-} diff --git a/src/Data/ByteString/Base32/Internal/Head.hs b/src/Data/ByteString/Base32/Internal/Head.hs --- a/src/Data/ByteString/Base32/Internal/Head.hs +++ b/src/Data/ByteString/Base32/Internal/Head.hs @@ -9,10 +9,10 @@ ) where -import qualified Data.ByteString as BS import Data.ByteString.Internal import Data.ByteString.Base32.Internal.Loop import Data.ByteString.Base32.Internal.Tail +import Data.ByteString.Base32.Internal.Utils import Data.Text (Text) import Foreign.Ptr @@ -28,64 +28,49 @@ -- | 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) +encodeBase32_ !lut (PS !sfp !o !l) = + unsafeDupablePerformIO $ do + dfp <- mallocPlainForeignPtrBytes dlen + withForeignPtr dfp $ \dptr -> + withForeignPtr sfp $ \sptr -> do + let !end = plusPtr sptr (l + o) + innerLoop + lut + (castPtr dptr) + (plusPtr sptr o) + end + (loopTail lut dfp dptr end) where - !dlen = 8 * ((slen + 4) `div` 5) + !q = (l * 8) `quot` 5 + !r = (l * 8) `rem` 5 + !dlen = padCeilN 8 (q + if r == 0 then 0 else 1) -- | Head of the unpadded base32 encoding loop - marshal data, assemble loops -- encodeBase32NoPad_ :: Addr# -> ByteString -> ByteString -encodeBase32NoPad_ !lut (PS !sfp !soff !slen) - = unsafeDupablePerformIO $ do +encodeBase32NoPad_ !lut (PS !sfp !o !l) = + unsafeDupablePerformIO $ do !dfp <- mallocPlainForeignPtrBytes dlen withForeignPtr dfp $ \dptr -> withForeignPtr sfp $ \sptr -> do - let !end = plusPtr sptr (soff + slen) - innerLoopNoPad - lut + let !end = plusPtr sptr (l + o) + innerLoop lut (castPtr dptr) - (plusPtr sptr soff) + (plusPtr sptr o) end - (loopTailNoPad lut dfp end) + (loopTailNoPad lut dfp dptr end) where - !dlen = 8 * ((slen + 4) `div` 5) + !q = (l * 8) `quot` 5 + !r = (l * 8) `rem` 5 + !dlen = padCeilN 8 (q + if r == 0 then 0 else 1) -- | 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) +decodeBase32_ :: Int -> ForeignPtr Word8 -> ByteString -> IO (Either Text ByteString) +decodeBase32_ !dlen !dtfp (PS !sfp !soff !slen) = + withForeignPtr dtfp $ \(Ptr dtable) -> + withForeignPtr sfp $ \sptr -> do + dfp <- mallocPlainForeignPtrBytes dlen + withForeignPtr dfp $ \dptr -> do + let !end = plusPtr sptr (soff + slen) + decodeLoop dtable dfp dptr (plusPtr sptr soff) end diff --git a/src/Data/ByteString/Base32/Internal/Loop.hs b/src/Data/ByteString/Base32/Internal/Loop.hs --- a/src/Data/ByteString/Base32/Internal/Loop.hs +++ b/src/Data/ByteString/Base32/Internal/Loop.hs @@ -1,20 +1,21 @@ {-# LANGUAGE BangPatterns #-} {-# LANGUAGE CPP #-} {-# LANGUAGE MagicHash #-} +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE TypeApplications #-} module Data.ByteString.Base32.Internal.Loop ( innerLoop -, innerLoopNoPad , decodeLoop ) where import Data.Bits -import Data.ByteString (ByteString) +import Data.ByteString.Internal (ByteString(..)) 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 @@ -29,132 +30,179 @@ -> Ptr Word64 -> Ptr Word8 -> Ptr Word8 - -> (Ptr Word8 -> Ptr Word8 -> IO ()) - -> IO () + -> (Ptr Word8 -> Ptr Word8 -> IO ByteString) + -> IO ByteString innerLoop !lut !dptr !sptr !end finish = go dptr sptr where - lix a = return $ w64 (aix (fromIntegral a .&. 0x1f) lut) + lix a = 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 + !t <- peekWord32BE (castPtr src) !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 + let !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) + let !w = 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# + -> ForeignPtr Word8 -> 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 +decodeLoop !lut !dfp !dptr !sptr !end = go dptr sptr where lix a = w64 (aix (fromIntegral a) lut) - roll !w !acc = (acc `unsafeShiftL` 5) .|. lix w + err :: Ptr Word64 -> IO (Either Text ByteString) + err p = return . Left . T.pack + $ "invalid character at offset: " + ++ show (p `minusPtr` sptr) - err = return . Left . T.pack + padErr :: Ptr Word64 -> IO (Either Text ByteString) + padErr p = return . Left . T.pack + $ "invalid padding at offset: " + ++ show (p `minusPtr` sptr) - go !dst !src !n - | plusPtr src 8 == end = finish dst (castPtr src) n + look :: Ptr Word8 -> IO Word64 + look !p = lix . w64 <$> peek @Word8 p + + go !dst !src + | plusPtr src 8 >= end = do + + let src' = castPtr src + + a <- look src' + b <- look (plusPtr src' 1) + c <- look (plusPtr src' 2) + d <- look (plusPtr src' 3) + e <- look (plusPtr src' 4) + f <- look (plusPtr src' 5) + g <- look (plusPtr src' 6) + h <- look (plusPtr src' 7) + finalChunk dst src a b c d e f g h + | 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 + !t <- peekWord64BE src - 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) + let a = lix (unsafeShiftR t 56) + b = lix (unsafeShiftR t 48) + c = lix (unsafeShiftR t 40) + d = lix (unsafeShiftR t 32) + e = lix (unsafeShiftR t 24) + f = lix (unsafeShiftR t 16) + g = lix (unsafeShiftR t 8) + h = lix t + + decodeChunk dst src a b c d e f g h + + finalChunk !dst !src !a !b !c !d !e !f !g !h + | a == 0x63 = padErr src + | b == 0x63 = padErr (plusPtr src 1) + | a == 0xff = err src + | b == 0xff = err (plusPtr src 1) + | c == 0xff = err (plusPtr src 2) + | d == 0xff = err (plusPtr src 3) + | e == 0xff = err (plusPtr src 4) + | f == 0xff = err (plusPtr src 5) + | g == 0xff = err (plusPtr src 6) + | h == 0xff = err (plusPtr src 7) + | otherwise = do + + let !o1 = (fromIntegral a `unsafeShiftL` 3) .|. (fromIntegral b `unsafeShiftR` 2) + !o2 = (fromIntegral b `unsafeShiftL` 6) + .|. (fromIntegral c `unsafeShiftL` 1) + .|. (fromIntegral d `unsafeShiftR` 4) + !o3 = (fromIntegral d `unsafeShiftL` 4) .|. (fromIntegral e `unsafeShiftR` 1) + !o4 = (fromIntegral e `unsafeShiftL` 7) + .|. (fromIntegral f `unsafeShiftL` 2) + .|. (fromIntegral g `unsafeShiftR` 3) + !o5 = (fromIntegral g `unsafeShiftL` 5) .|. fromIntegral h + + poke @Word8 dst o1 + poke @Word8 (plusPtr dst 1) o2 + + case (c,d,e,f,g,h) of + (0x63,0x63,0x63,0x63,0x63,0x63) -> + return (Right (PS dfp 0 (1 + minusPtr dst dptr))) + (0x63,_,_,_,_,_) -> padErr (plusPtr src 3) + (_,0x63,0x63,0x63,0x63,0x63) -> padErr (plusPtr src 3) + (_,0x63,_,_,_,_) -> padErr (plusPtr src 4) + (_,_,0x63,0x63,0x63,0x63) -> do + poke @Word8 (plusPtr dst 2) o3 + return (Right (PS dfp 0 (2 + minusPtr dst dptr))) + (_,_,0x63,_,_,_) -> padErr (plusPtr src 5) + (_,_,_,0x63,0x63,0x63) -> do + poke @Word8 (plusPtr dst 2) o3 + poke @Word8 (plusPtr dst 3) o4 + return (Right (PS dfp 0 (3 + minusPtr dst dptr))) + (_,_,_,0x63,_,_) -> padErr (plusPtr src 6) + (_,_,_,_,0x63,0x63) -> padErr (plusPtr src 6) + (_,_,_,_,0x63,_) -> padErr (plusPtr src 7) + (_,_,_,_,_,0x63) -> do + poke @Word8 (plusPtr dst 2) o3 + poke @Word8 (plusPtr dst 3) o4 + poke @Word8 (plusPtr dst 4) o5 + return (Right (PS dfp 0 (4 + minusPtr dst dptr))) + (_,_,_,_,_,_) -> do + poke @Word8 (plusPtr dst 2) o3 + poke @Word8 (plusPtr dst 3) o4 + poke @Word8 (plusPtr dst 4) o5 + return (Right (PS dfp 0 (5 + minusPtr dst dptr))) + + decodeChunk !dst !src !a !b !c !d !e !f !g !h + | a == 0x63 = padErr src + | b == 0x63 = padErr (plusPtr src 1) + | c == 0x63 = padErr (plusPtr src 2) + | d == 0x63 = padErr (plusPtr src 3) + | e == 0x63 = padErr (plusPtr src 4) + | f == 0x63 = padErr (plusPtr src 5) + | g == 0x63 = padErr (plusPtr src 6) + | h == 0x63 = padErr (plusPtr src 7) + | a == 0xff = err src + | b == 0xff = err (plusPtr src 1) + | c == 0xff = err (plusPtr src 2) + | d == 0xff = err (plusPtr src 3) + | e == 0xff = err (plusPtr src 4) + | f == 0xff = err (plusPtr src 5) + | g == 0xff = err (plusPtr src 6) + | h == 0xff = err (plusPtr src 7) + | otherwise = do + + let !w = ((unsafeShiftL a 35) + .|. (unsafeShiftL b 30) + .|. (unsafeShiftL c 25) + .|. (unsafeShiftL d 20) + .|. (unsafeShiftL e 15) + .|. (unsafeShiftL f 10) + .|. (unsafeShiftL g 5) + .|. h) :: Word64 + + poke @Word32 (castPtr dst) (byteSwap32 (fromIntegral (unsafeShiftR w 8))) + poke @Word8 (plusPtr dst 4) (fromIntegral w) + go (plusPtr dst 5) (plusPtr src 8) diff --git a/src/Data/ByteString/Base32/Internal/Tables.hs b/src/Data/ByteString/Base32/Internal/Tables.hs --- a/src/Data/ByteString/Base32/Internal/Tables.hs +++ b/src/Data/ByteString/Base32/Internal/Tables.hs @@ -18,7 +18,7 @@ [ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,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,0xff,0x1a,0x1b,0x1c,0x1d,0x1e,0x1f,0xff,0xff,0xff,0xff,0xff,0x63,0xff,0xff , 0xff,0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a,0x0b,0x0c,0x0d,0x0e , 0x0f,0x10,0x11,0x12,0x13,0x14,0x15,0x16,0x17,0x18,0x19,0xff,0xff,0xff,0xff,0xff , 0xff,0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0x0a,0x0b,0x0c,0x0d,0x0e @@ -39,7 +39,7 @@ [ 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff , 0xff,0xff,0xff,0xff,0xff,0xff,0xff,0xff,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 + , 0x00,0x01,0x02,0x03,0x04,0x05,0x06,0x07,0x08,0x09,0xff,0xff,0xff,0x63,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 diff --git a/src/Data/ByteString/Base32/Internal/Tail.hs b/src/Data/ByteString/Base32/Internal/Tail.hs --- a/src/Data/ByteString/Base32/Internal/Tail.hs +++ b/src/Data/ByteString/Base32/Internal/Tail.hs @@ -7,15 +7,12 @@ 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 @@ -29,11 +26,14 @@ -- loopTail :: Addr# + -> ForeignPtr Word8 -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 - -> IO () -loopTail !lut !end !dst !src + -> Ptr Word8 + -> IO ByteString +loopTail !lut !dfp !dptr !end !dst !src + | src == end = return (PS dfp 0 (minusPtr dst dptr)) | plusPtr src 1 == end = do -- 2 6 !a <- peek src @@ -44,6 +44,7 @@ poke (plusPtr dst 1) u padN (plusPtr dst 2) 6 + return (PS dfp 0 (8 + minusPtr dst dptr)) | plusPtr src 2 == end = do -- 4 4 !a <- peek src !b <- peek (plusPtr src 1) @@ -59,6 +60,7 @@ poke (plusPtr dst 3) w padN (plusPtr dst 4) 4 + return (PS dfp 0 (8 + minusPtr dst dptr)) | plusPtr src 3 == end = do -- 5 3 !a <- peek src !b <- peek (plusPtr src 1) @@ -76,8 +78,9 @@ poke (plusPtr dst 3) w poke (plusPtr dst 4) x padN (plusPtr dst 5) 3 + return (PS dfp 0 (8 + minusPtr dst dptr)) - | plusPtr src 4 == end = do -- 7 1 + | otherwise = do -- 7 1 !a <- peek src !b <- peek (plusPtr src 1) !c <- peek (plusPtr src 2) @@ -99,8 +102,7 @@ poke (plusPtr dst 5) y poke (plusPtr dst 6) z padN (plusPtr dst 7) 1 - - | otherwise = return () + return (PS dfp 0 (8 + minusPtr dst dptr)) where look !n = aix n lut @@ -117,9 +119,10 @@ -> Ptr Word8 -> Ptr Word8 -> Ptr Word8 - -> Int + -> Ptr Word8 -> IO ByteString -loopTailNoPad !lut !dfp !end !dst !src !n +loopTailNoPad !lut !dfp !dptr !end !dst !src + | src == end = return (PS dfp 0 (minusPtr dst dptr)) | plusPtr src 1 == end = do -- 2 6 !a <- peek src @@ -129,7 +132,7 @@ poke dst t poke (plusPtr dst 1) u - return (PS dfp 0 (n + 2)) + return (PS dfp 0 (2 + minusPtr dst dptr)) | plusPtr src 2 == end = do -- 4 4 !a <- peek src @@ -145,7 +148,7 @@ poke (plusPtr dst 2) v poke (plusPtr dst 3) w - return (PS dfp 0 (n + 4)) + return (PS dfp 0 (4 + minusPtr dst dptr)) | plusPtr src 3 == end = do -- 5 3 !a <- peek src @@ -163,9 +166,9 @@ poke (plusPtr dst 2) v poke (plusPtr dst 3) w poke (plusPtr dst 4) x - return (PS dfp 0 (n + 5)) + return (PS dfp 0 (5 + minusPtr dst dptr)) - | plusPtr src 4 == end = do -- 7 1 + | otherwise = do -- 7 1 !a <- peek src !b <- peek (plusPtr src 1) !c <- peek (plusPtr src 2) @@ -186,96 +189,7 @@ 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) + return (PS dfp 0 (7 + minusPtr dst dptr)) 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 --- a/src/Data/ByteString/Base32/Internal/Utils.hs +++ b/src/Data/ByteString/Base32/Internal/Utils.hs @@ -2,16 +2,26 @@ {-# LANGUAGE MagicHash #-} module Data.ByteString.Base32.Internal.Utils ( aix +, padCeilN +, peekWord32BE +, peekWord64BE +, reChunkN , w32 , w64 , w64_32 , writeNPlainForeignPtrBytes ) where + +import Data.Bits +import Data.ByteString (ByteString) +import qualified Data.ByteString as BS + import Foreign.Ptr import Foreign.ForeignPtr import Foreign.Storable +import GHC.ByteOrder import GHC.Exts import GHC.ForeignPtr import GHC.Word @@ -37,6 +47,14 @@ w64 = fromIntegral {-# INLINE w64 #-} +padCeilN :: Int -> Int -> Int +padCeilN !n !x + | r == 0 = x + | otherwise = (x - r) + n + where + r = x .&. (n - 1) +{-# INLINE padCeilN #-} + -- | Allocate and fill @n@ bytes with some data -- writeNPlainForeignPtrBytes @@ -54,3 +72,38 @@ go !_ [] = return () go !p (x:xs) = poke p x >> go (plusPtr p 1) xs {-# INLINE writeNPlainForeignPtrBytes #-} + +peekWord32BE :: Ptr Word32 -> IO Word32 +peekWord32BE p = case targetByteOrder of + LittleEndian -> byteSwap32 <$> peek p + BigEndian -> peek p +{-# inline peekWord32BE #-} + +peekWord64BE :: Ptr Word64 -> IO Word64 +peekWord64BE p = case targetByteOrder of + LittleEndian -> byteSwap64 <$> peek p + BigEndian -> peek p +{-# inline peekWord64BE #-} + +-- | Rechunk a list of bytestrings in multiples of @n@ +-- +reChunkN :: Int -> [ByteString] -> [ByteString] +reChunkN n = go + where + go [] = [] + go (b:bs) = case divMod (BS.length b) n of + (_, 0) -> b : go bs + (d, _) -> case BS.splitAt (d * n) b of + ~(h, t) -> h : accum t bs + + accum acc [] = [acc] + accum acc (c:cs) = + case BS.splitAt (n - BS.length acc) c of + ~(h, t) -> + let acc' = BS.append acc h + in if BS.length acc' == n + then + let cs' = if BS.null t then cs else t : cs + in acc' : go cs' + else accum acc' cs +{-# INLINE reChunkN #-} diff --git a/src/Data/ByteString/Lazy/Base32.hs b/src/Data/ByteString/Lazy/Base32.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Lazy/Base32.hs @@ -0,0 +1,244 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} +-- | +-- Module : Data.ByteString.Lazy.Base32 +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains 'Data.ByteString.Lazy.ByteString'-valued combinators for +-- implementing the RFC 4648 specification of the Base32 +-- encoding format. This includes strictly padded/unpadded +-- decoding variants, as well as internal and external validation for canonicity. +-- +module Data.ByteString.Lazy.Base32 +( -- * Encoding + encodeBase32 +, encodeBase32' +, encodeBase32Unpadded +, encodeBase32Unpadded' + -- * Decoding +, decodeBase32 +, decodeBase32Unpadded +, decodeBase32Padded +--, decodeBase32Lenient + -- * Validation +, isBase32 +, isValidBase32 +) where + + +import Prelude hiding (all, elem) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base32 as B32 +import Data.ByteString.Base32.Internal.Utils (reChunkN) +import Data.ByteString.Lazy (elem, fromChunks, toChunks) +import Data.ByteString.Lazy.Internal (ByteString(..)) +import Data.Either (isRight) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + + +-- | Encode a 'ByteString' value as a Base32 'Text' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "KN2W4===" +-- +encodeBase32 :: ByteString -> TL.Text +encodeBase32 = TL.decodeUtf8 . encodeBase32' +{-# INLINE encodeBase32 #-} + +-- | Encode a 'ByteString' as a Base32 'ByteString' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "KN2W4===" +-- +encodeBase32' :: ByteString -> ByteString +encodeBase32' = fromChunks + . fmap B32.encodeBase32' + . reChunkN 5 + . toChunks + +-- | Decode an arbitrarily padded Base32 encoded 'ByteString' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as Base32-encoded values are optionally padded. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32 "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32 :: ByteString -> Either T.Text ByteString +decodeBase32 = fmap (fromChunks . (:[])) + . B32.decodeBase32 + . BS.concat + . toChunks +{-# INLINE decodeBase32 #-} + +-- | Encode a 'ByteString' value as Base32 'Text' without padding. Note that for Base32, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32 and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded "Sun" +-- "KN2W4" +-- +encodeBase32Unpadded :: ByteString -> TL.Text +encodeBase32Unpadded = TL.decodeUtf8 . encodeBase32Unpadded' +{-# INLINE encodeBase32Unpadded #-} + +-- | Encode a 'ByteString' value as Base32 without padding. Note that for Base32, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32 and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "KN2W4" +-- +encodeBase32Unpadded' :: ByteString -> ByteString +encodeBase32Unpadded' = fromChunks + . fmap B32.encodeBase32Unpadded' + . reChunkN 5 + . toChunks + +-- | Decode an unpadded Base32-encoded 'ByteString' value. Input strings are +-- required to be unpadded, and will undergo validation prior to decoding to +-- confirm. +-- +-- In general, unless unpadded Base32 is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "KN2W4===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32Unpadded :: ByteString -> Either T.Text ByteString +decodeBase32Unpadded = fmap (fromChunks . (:[])) + . B32.decodeBase32Unpadded + . BS.concat + . toChunks +{-# INLINE decodeBase32Unpadded #-} + +-- | Decode a padded Base32-encoded 'ByteString' value. Input strings are +-- required to be correctly padded, and will be validated prior to decoding +-- to confirm. +-- +-- In general, unless padded Base32 is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "KN2W4" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: ByteString -> Either T.Text ByteString +decodeBase32Padded = fmap (fromChunks . (:[])) + . B32.decodeBase32Padded + . BS.concat + . toChunks +{-# INLINE decodeBase32Padded #-} + +-- -- | Leniently decode an unpadded Base32-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. +-- -- +-- -- === __Examples__: +-- -- +-- -- >>> decodeBase32Lenient "PDw_Pj4=" +-- -- "<>" +-- -- +-- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" +-- -- "<>" +-- -- +-- decodeBase32Lenient :: ByteString -> ByteString +-- decodeBase32Lenient = fromChunks +-- . fmap B32.decodeBase32Lenient +-- . reChunkN 8 +-- . fmap (BS.filter (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567=")) +-- . toChunks +-- {-# INLINE decodeBase32Lenient #-} + +-- | Tell whether a 'ByteString' is Base32-encoded. +-- +-- === __Examples__: +-- +-- >>> isBase32 "KN2W4" +-- True +-- +-- >>> isBase32 "KN2W4===" +-- True +-- +-- >>> isBase32 "KN2W4==" +-- False +-- +isBase32 :: ByteString -> Bool +isBase32 bs = isValidBase32 bs && isRight (decodeBase32 bs) +{-# INLINE isBase32 #-} + +-- | Tell whether a 'ByteString' 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'. +-- +-- === __Examples__: +-- +-- >>> isValidBase32 "KN2W4" +-- True +-- +-- >>> isValidBase32 "KN2W4=" +-- False +-- +-- >>> isValidBase32 "KN2W4%" +-- False +-- +isValidBase32 :: ByteString -> Bool +isValidBase32 = go . toChunks + where + go [] = True + go [c] = B32.isValidBase32 c + go (c:cs) = -- note the lack of padding char + BS.all (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567") c + && go cs +{-# INLINE isValidBase32 #-} diff --git a/src/Data/ByteString/Lazy/Base32/Hex.hs b/src/Data/ByteString/Lazy/Base32/Hex.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Lazy/Base32/Hex.hs @@ -0,0 +1,245 @@ +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Trustworthy #-} +-- | +-- Module : Data.ByteString.Lazy.Base32.Hex +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains 'Data.ByteString.Lazy.ByteString'-valued combinators for +-- implementing the RFC 4648 specification of the Base32hex +-- encoding format. This includes strictly padded/unpadded +-- decoding variants, as well as internal and external validation for canonicity. +-- +module Data.ByteString.Lazy.Base32.Hex +( -- * Encoding + encodeBase32 +, encodeBase32' +, encodeBase32Unpadded +, encodeBase32Unpadded' + -- * Decoding +, decodeBase32 +, decodeBase32Unpadded +, decodeBase32Padded +--, decodeBase32Lenient + -- * Validation +, isBase32Hex +, isValidBase32Hex +) where + + +import Prelude hiding (all, elem) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Base32.Hex as B32H +import Data.ByteString.Base32.Internal.Utils (reChunkN) +import Data.ByteString.Lazy (elem, fromChunks, toChunks) +import Data.ByteString.Lazy.Internal (ByteString(..)) +import Data.Either (isRight) +import qualified Data.Text as T +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + + +-- | Encode a 'ByteString' value as a Base32hex 'Text' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "ADQMS===" +-- +encodeBase32 :: ByteString -> TL.Text +encodeBase32 = TL.decodeUtf8 . encodeBase32' +{-# INLINE encodeBase32 #-} + +-- | Encode a 'ByteString' as a Base32hex 'ByteString' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32' "Sun" +-- "ADQMS===" +-- +encodeBase32' :: ByteString -> ByteString +encodeBase32' = fromChunks + . fmap B32H.encodeBase32' + . reChunkN 5 + . toChunks + +-- | Decode an arbitrarily padded Base32hex encoded 'ByteString' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as Base32hex-encoded values are optionally padded. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32 "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32 :: ByteString -> Either T.Text ByteString +decodeBase32 = fmap (fromChunks . (:[])) + . B32H.decodeBase32 + . BS.concat + . toChunks +{-# INLINE decodeBase32 #-} + +-- | Encode a 'ByteString' value as Base32hex 'Text' without padding. Note that for Base32hex, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32hex and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded "Sun" +-- "ADQMS" +-- +encodeBase32Unpadded :: ByteString -> TL.Text +encodeBase32Unpadded = TL.decodeUtf8 . encodeBase32Unpadded' +{-# INLINE encodeBase32Unpadded #-} + +-- | Encode a 'ByteString' value as Base32hex without padding. Note that for Base32hex, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32hex and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "ADQMS" +-- +encodeBase32Unpadded' :: ByteString -> ByteString +encodeBase32Unpadded' = fromChunks + . fmap B32H.encodeBase32Unpadded' + . reChunkN 5 + . toChunks + +-- | Decode an unpadded Base32hex-encoded 'ByteString' value. Input strings are +-- required to be unpadded, and will undergo validation prior to decoding to +-- confirm. +-- +-- In general, unless unpadded Base32hex is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32Unpadded :: ByteString -> Either T.Text ByteString +decodeBase32Unpadded = fmap (fromChunks . (:[])) + . B32H.decodeBase32Unpadded + . BS.concat + . toChunks +{-# INLINE decodeBase32Unpadded #-} + +-- | Decode a padded Base32hex-encoded 'ByteString' value. Input strings are +-- required to be correctly padded, and will be validated prior to decoding +-- to confirm. +-- +-- In general, unless padded Base32hex is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "ADQMS" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: ByteString -> Either T.Text ByteString +decodeBase32Padded = fmap (fromChunks . (:[])) + . B32H.decodeBase32Padded + . BS.concat + . toChunks +{-# INLINE decodeBase32Padded #-} + +-- -- | 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. +-- -- +-- -- === __Examples__: +-- -- +-- -- >>> decodeBase32Lenient "PDw_Pj4=" +-- -- "<>" +-- -- +-- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" +-- -- "<>" +-- -- +-- decodeBase32Lenient :: ByteString -> ByteString +-- decodeBase32Lenient = fromChunks +-- . fmap B32H.decodeBase32Lenient +-- . reChunkN 8 +-- . fmap (BS.filter (flip elem "ABCDEFGHIJKLMNOPQRSTUVWXYZ234567=")) +-- . toChunks +-- {-# INLINE decodeBase32Lenient #-} + +-- | Tell whether a 'ByteString' is Base32hex-encoded. +-- +-- === __Examples__: +-- +-- >>> isBase32Hex "ADQMS" +-- True +-- +-- >>> isBase32Hex "ADQMS===" +-- True +-- +-- >>> isBase32Hex "ADQMS==" +-- False +-- +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 +-- Base32hex encoded 'ByteString' value, use 'isBase32Hex'. +-- +-- === __Examples__: +-- +-- +-- >>> isValidBase32Hex "ADQMS" +-- True +-- +-- >>> isValidBase32Hex "ADQMS=" +-- False +-- +-- >>> isValidBase32Hex "ADQMS%" +-- False +-- +isValidBase32Hex :: ByteString -> Bool +isValidBase32Hex = go . toChunks + where + go [] = True + go [c] = B32H.isValidBase32Hex c + go (c:cs) = -- note the lack of padding char + BS.all (flip elem "0123456789ABCDEFGHIJKLMNOPQRSTUV") c + && go cs +{-# INLINE isValidBase32Hex #-} diff --git a/src/Data/ByteString/Short/Base32.hs b/src/Data/ByteString/Short/Base32.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Short/Base32.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE Trustworthy #-} +-- | +-- Module : Data.ByteString.Short.Base32 +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains 'Data.ByteString.Short.ShortByteString'-valued combinators for +-- implementing the RFC 4648 specification of the Base32 +-- encoding format. This includes strictly padded/unpadded decoding +-- variants, as well as internal and external validation for canonicity. +-- +module Data.ByteString.Short.Base32 +( -- * Encoding + encodeBase32 +, encodeBase32' +, encodeBase32Unpadded +, encodeBase32Unpadded' + -- * Decoding +, decodeBase32 +, decodeBase32Unpadded +, decodeBase32Padded +--, decodeBase32Lenient + -- * Validation +, isBase32 +, isValidBase32 +) where + + +import qualified Data.ByteString.Base32 as B32 +import Data.ByteString.Short (ShortByteString, fromShort, toShort) +import Data.Text (Text) +import Data.Text.Short (ShortText) +import Data.Text.Short.Unsafe (fromShortByteStringUnsafe) + + +-- | Encode a 'ShortByteString' value as a Base32 'Text' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "KN2W4===" +-- +encodeBase32 :: ShortByteString -> ShortText +encodeBase32 = fromShortByteStringUnsafe . encodeBase32' +{-# INLINE encodeBase32 #-} + +-- | Encode a 'ShortByteString' as a Base32 'ShortByteString' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32' "Sun" +-- "KN2W4===" +-- +encodeBase32' :: ShortByteString -> ShortByteString +encodeBase32' = toShort . B32.encodeBase32' . fromShort + +-- | Decode an arbitrarily padded Base32 encoded 'ShortByteString' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as Base32-encoded values are optionally padded. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32 "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32 :: ShortByteString -> Either Text ShortByteString +decodeBase32 = fmap toShort . B32.decodeBase32 . fromShort + +{-# INLINE decodeBase32 #-} + +-- | Encode a 'ShortByteString' value as Base32 'Text' without padding. Note that for Base32, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32 and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded "Sun" +-- "KN2W4" +-- +encodeBase32Unpadded :: ShortByteString -> ShortText +encodeBase32Unpadded = fromShortByteStringUnsafe . encodeBase32Unpadded' +{-# INLINE encodeBase32Unpadded #-} + +-- | Encode a 'ShortByteString' value as Base32 without padding. Note that for Base32, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32 and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "KN2W4" +-- +encodeBase32Unpadded' :: ShortByteString -> ShortByteString +encodeBase32Unpadded' = toShort . B32.encodeBase32Unpadded' . fromShort + +-- | Decode an unpadded Base32-encoded 'ShortByteString' value. Input strings are +-- required to be unpadded, and will undergo validation prior to decoding to +-- confirm. +-- +-- In general, unless unpadded Base32 is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "KN2W4===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32Unpadded :: ShortByteString -> Either Text ShortByteString +decodeBase32Unpadded = fmap toShort . B32.decodeBase32Unpadded . fromShort +{-# INLINE decodeBase32Unpadded #-} + +-- | Decode a padded Base32-encoded 'ShortByteString' value. Input strings are +-- required to be correctly padded, and will be validated prior to decoding +-- to confirm. +-- +-- In general, unless padded Base32 is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "KN2W4" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: ShortByteString -> Either Text ShortByteString +decodeBase32Padded = fmap toShort . B32.decodeBase32Padded . fromShort +{-# INLINE decodeBase32Padded #-} + +-- -- | Leniently decode an unpadded Base32-encoded 'ShortByteString'. 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. +-- -- +-- -- === __Examples__: +-- -- +-- -- >>> decodeBase32Lenient "PDw_Pj4=" +-- -- "<>" +-- -- +-- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" +-- -- "<>" +-- -- +-- decodeBase32Lenient :: ShortByteString -> ShortByteString +-- decodeBase32Lenient = toShort . B32.decodeBase32Lenient . fromShort +-- {-# INLINE decodeBase32Lenient #-} + +-- | Tell whether a 'ShortByteString' is Base32-encoded. +-- +-- === __Examples__: +-- +-- >>> isBase32 "KN2W4" +-- True +-- +-- >>> isBase32 "KN2W4===" +-- True +-- +-- >>> isBase32 "KN2W4==" +-- False +-- +isBase32 :: ShortByteString -> Bool +isBase32 = B32.isBase32 . fromShort +{-# INLINE isBase32 #-} + +-- | Tell whether a 'ShortByteString' 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 'ShortByteString' value, use 'isBase32'. +-- +-- === __Examples__: +-- +-- >>> isValidBase32 "KN2W4" +-- True +-- +-- >>> isValidBase32 "KN2W4=" +-- False +-- +-- >>> isValidBase32 "KN2W4%" +-- False +-- +isValidBase32 :: ShortByteString -> Bool +isValidBase32 = B32.isValidBase32 . fromShort +{-# INLINE isValidBase32 #-} diff --git a/src/Data/ByteString/Short/Base32/Hex.hs b/src/Data/ByteString/Short/Base32/Hex.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Short/Base32/Hex.hs @@ -0,0 +1,210 @@ +{-# LANGUAGE Trustworthy #-} +-- | +-- Module : Data.ByteString.Short.Base32.Hex +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains 'Data.ByteString.Short.ShortByteString'-valued combinators for +-- implementing the RFC 4648 specification of the Base32hex +-- encoding format. This includes strictly padded/unpadded and decoding +-- variants, as well as internal and external validation for canonicity. +-- +module Data.ByteString.Short.Base32.Hex +( -- * Encoding + encodeBase32 +, encodeBase32' +, encodeBase32Unpadded +, encodeBase32Unpadded' + -- * Decoding +, decodeBase32 +, decodeBase32Unpadded +, decodeBase32Padded +--, decodeBase32Lenient + -- * Validation +, isBase32Hex +, isValidBase32Hex +) where + + +import qualified Data.ByteString.Base32.Hex as B32H +import Data.ByteString.Short (ShortByteString, fromShort, toShort) +import Data.Text (Text) +import Data.Text.Short (ShortText) +import Data.Text.Short.Unsafe (fromShortByteStringUnsafe) + +-- | Encode a 'ShortByteString' value as a Base32hex 'Text' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "ADQMS===" +-- +encodeBase32 :: ShortByteString -> ShortText +encodeBase32 = fromShortByteStringUnsafe . encodeBase32' +{-# INLINE encodeBase32 #-} + +-- | Encode a 'ShortByteString' as a Base32hex 'ShortByteString' value with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32' "Sun" +-- "ADQMS===" +-- +encodeBase32' :: ShortByteString -> ShortByteString +encodeBase32' = toShort . B32H.encodeBase32' . fromShort + +-- | Decode an arbitrarily padded Base32hex encoded 'ShortByteString' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as Base32hex-encoded values are optionally padded. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32 "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQM===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32 :: ShortByteString -> Either Text ShortByteString +decodeBase32 = fmap toShort . B32H.decodeBase32 . fromShort +{-# INLINE decodeBase32 #-} + +-- | Encode a 'ShortByteString' value as Base32hex 'Text' without padding. Note that for Base32hex, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32hex and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "ADQMS" +-- +encodeBase32Unpadded :: ShortByteString -> ShortText +encodeBase32Unpadded = fromShortByteStringUnsafe . encodeBase32Unpadded' +{-# INLINE encodeBase32Unpadded #-} + +-- | Encode a 'ShortByteString' value as Base32hex without padding. Note that for Base32hex, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32hex and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded' "Sun" +-- "ADQMS" +-- +encodeBase32Unpadded' :: ShortByteString -> ShortByteString +encodeBase32Unpadded' = toShort . B32H.encodeBase32Unpadded' . fromShort + +-- | Decode an unpadded Base32hex-encoded 'ShortByteString' value. Input strings are +-- required to be unpadded, and will undergo validation prior to decoding to +-- confirm. +-- +-- In general, unless unpadded Base32hex is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32Unpadded :: ShortByteString -> Either Text ShortByteString +decodeBase32Unpadded = fmap toShort . B32H.decodeBase32Unpadded . fromShort +{-# INLINE decodeBase32Unpadded #-} + +-- | Decode a padded Base32hex-encoded 'ShortByteString' value. Input strings are +-- required to be correctly padded, and will be validated prior to decoding +-- to confirm. +-- +-- In general, unless padded Base32hex is explicitly required, it is +-- safer to call 'decodeBase32'. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "ADQMS" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: ShortByteString -> Either Text ShortByteString +decodeBase32Padded = fmap toShort . B32H.decodeBase32Padded . fromShort +{-# INLINE decodeBase32Padded #-} + +-- -- | Leniently decode an unpadded Base32hex-encoded 'ShortByteString'. 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. +-- -- +-- -- === __Examples__: +-- -- +-- -- >>> decodeBase32Lenient "PDw_Pj4=" +-- -- "<>" +-- -- +-- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" +-- -- "<>" +-- -- +-- decodeBase32Lenient :: ShortByteString -> ShortByteString +-- decodeBase32Lenient = toShort . B32H.decodeBase32Lenient . fromShort +-- {-# INLINE decodeBase32Lenient #-} + +-- | Tell whether a 'ShortByteString' is Base32hex-encoded. +-- +-- === __Examples__: +-- +-- >>> isBase32Hex "ADQMS" +-- True +-- +-- >>> isBase32Hex "ADQMS===" +-- True +-- +-- >>> isBase32Hex "ADQMS==" +-- False +-- +isBase32Hex :: ShortByteString -> Bool +isBase32Hex = B32H.isBase32Hex . fromShort +{-# INLINE isBase32Hex #-} + +-- | Tell whether a 'ShortByteString' 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 'ShortByteString' value, use 'isBase32Hex'. +-- +-- === __Examples__: +-- +-- >>> isValidBase32Hex "ADQMS" +-- True +-- +-- >>> isValidBase32Hex "ADQMS=" +-- False +-- +-- >>> isValidBase32Hex "ADQMS%" +-- False +-- +isValidBase32Hex :: ShortByteString -> Bool +isValidBase32Hex = B32H.isValidBase32Hex . fromShort +{-# INLINE isValidBase32Hex #-} diff --git a/src/Data/Text/Encoding/Base32.hs b/src/Data/Text/Encoding/Base32.hs --- a/src/Data/Text/Encoding/Base32.hs +++ b/src/Data/Text/Encoding/Base32.hs @@ -1,69 +1,217 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} -- | -- Module : Data.Text.Encoding.Base32 --- Copyright : (c) 2019 Emily Pillmore --- License : BSD-style +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style -- --- Maintainer : Emily Pillmore --- Stability : Experimental --- Portability : portable +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable -- --- This module contains the combinators implementing the --- RFC 4648 specification for the Base32 encoding including --- unpadded and lenient variants +-- This module contains 'Data.Text.Text'-valued combinators for +-- implementing the RFC 4648 specification of the Base32 +-- encoding format. This includes strictly padded/unpadded decoding variants, as well as +-- internal and external validation for canonicity. -- module Data.Text.Encoding.Base32 ( encodeBase32 , decodeBase32 +, decodeBase32With , encodeBase32Unpadded , decodeBase32Unpadded +, decodeBase32UnpaddedWith +, decodeBase32Padded +, decodeBase32PaddedWith -- , decodeBase32Lenient , isBase32 , isValidBase32 ) where +import Data.Bifunctor (first) +import Data.ByteString (ByteString) import qualified Data.ByteString.Base32 as B32 import Data.Text (Text) import qualified Data.Text.Encoding as T +import Data.Text.Encoding.Base32.Error (Base32Error(..)) -- | Encode a 'Text' value in Base32 with padding. -- -- See: -- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "KN2W4===" +-- encodeBase32 :: Text -> Text encodeBase32 = B32.encodeBase32 . T.encodeUtf8 {-# INLINE encodeBase32 #-} --- | Decode a padded Base32-encoded 'Text' value +-- | Decode an arbitrarily padded Base32-encoded 'Text' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as base32 encodings are optionally padded. -- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32With` +-- and pass in a custom decode function. +-- -- See: -- +-- === __Examples__: +-- +-- >>> decodeBase32 "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W===" +-- Left "Base32-encoded bytestring has invalid padding" +-- decodeBase32 :: Text -> Either Text Text -decodeBase32 = fmap T.decodeUtf8 . B32.decodeBase32 . T.encodeUtf8 +decodeBase32 = fmap T.decodeLatin1 + . B32.decodeBase32 + . T.encodeUtf8 {-# INLINE decodeBase32 #-} +-- | Attempt to decode a 'Text' value as Base32, converting from +-- 'ByteString' to 'Text' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Example__: +-- +-- @ +-- 'decodeBase32With' 'T.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' +-- @ +-- +decodeBase32With + :: (ByteString -> Either err Text) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base32Error err) Text +decodeBase32With f t = case B32.decodeBase32 t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32With #-} + -- | Encode a 'Text' value in Base32 without padding. -- --- See: , --- +-- See: -- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded "Sun" +-- "KN2W4" +-- encodeBase32Unpadded :: Text -> Text encodeBase32Unpadded = B32.encodeBase32Unpadded . T.encodeUtf8 {-# INLINE encodeBase32Unpadded #-} --- | Decode an arbitrarily padded Base32-encoded 'Text' +-- | Decode an unpadded Base32 encoded 'Text' value. -- --- See: , --- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32WUnpaddedWith` +-- and pass in a custom decode function. -- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "KN2W4===" +-- Left "Base32-encoded bytestring has invalid padding" +-- decodeBase32Unpadded :: Text -> Either Text Text -decodeBase32Unpadded = fmap T.decodeUtf8 +decodeBase32Unpadded = fmap T.decodeLatin1 . B32.decodeBase32Unpadded . T.encodeUtf8 {-# INLINE decodeBase32Unpadded #-} +-- | Attempt to decode an unpadded 'ByteString' value as Base32, converting from +-- 'ByteString' to 'Text' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Example__: +-- +-- @ +-- 'decodeBase32UnpaddedWith' 'T.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' +-- @ +-- +decodeBase32UnpaddedWith + :: (ByteString -> Either err Text) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base32Error err) Text +decodeBase32UnpaddedWith f t = case B32.decodeBase32Unpadded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32UnpaddedWith #-} + + +-- | Decode an padded Base32 encoded 'Text' value +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32PaddedWith` +-- and pass in a custom decode function. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "KN2W4" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: Text -> Either Text Text +decodeBase32Padded = fmap T.decodeLatin1 + . B32.decodeBase32Padded + . T.encodeUtf8 +{-# INLINE decodeBase32Padded #-} + +-- | Attempt to decode a padded 'ByteString' value as Base32, converting from +-- 'ByteString' to 'Text' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Example__: +-- +-- @ +-- 'decodeBase32PaddedWith' 'T.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' +-- @ +-- +decodeBase32PaddedWith + :: (ByteString -> Either err Text) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base32Error err) Text +decodeBase32PaddedWith f t = case B32.decodeBase32Padded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32PaddedWith #-} + -- -- | 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. @@ -76,8 +224,19 @@ -- . T.encodeUtf8 -- {-# INLINE decodeBase32Lenient #-} --- | Tell whether a 'Text' value is Base32-encoded. +-- | Tell whether a 'Text' value is Base32-encoded -- +-- === __Examples__: +-- +-- >>> isBase32 "KN2W4" +-- True +-- +-- >>> isBase32 "KN2W4===" +-- True +-- +-- >>> isBase32 "KN2W4==" +-- False +-- isBase32 :: Text -> Bool isBase32 = B32.isBase32 . T.encodeUtf8 {-# INLINE isBase32 #-} @@ -87,6 +246,17 @@ -- 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'. +-- +-- === __Examples__: +-- +-- >>> isValidBase32 "KN2W4" +-- True +-- +-- >>> isValidBase32 "KN2W4=" +-- False +-- +-- >>> isValidBase32 "KN2W4%" +-- False -- isValidBase32 :: Text -> Bool isValidBase32 = B32.isValidBase32 . T.encodeUtf8 diff --git a/src/Data/Text/Encoding/Base32/Error.hs b/src/Data/Text/Encoding/Base32/Error.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Encoding/Base32/Error.hs @@ -0,0 +1,56 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE Safe #-} +-- | +-- Module : Data.Text.Encoding.Base32.Error +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains the error types raised (not as exceptions!) +-- in the decoding process. +-- +module Data.Text.Encoding.Base32.Error +( Base32Error(..) +) where + + +import Control.DeepSeq (NFData(..)) +import Control.Exception (Exception(..)) + +import Data.Text (Text) + +import GHC.Generics + +-- | This data type represents the type of decoding errors of +-- various kinds as they pertain to decoding 'Text' values. +-- Namely, to distinguish between decoding errors from opaque +-- unicode exceptions caught in the unicode decoding process. +-- +data Base32Error e + = DecodeError Text + -- ^ The error associated with decoding failure + -- as a result of the Base32 decoding process + | ConversionError e + -- ^ The error associated with the decoding failure + -- as a result of the conversion process + deriving + ( Eq, Show + , Generic + -- ^ @since 0.2.0.0 + ) + +-- | +-- +-- @since 0.2.0.0 +-- +instance Exception e => Exception (Base32Error e) + + +-- | +-- +-- @since 0.2.0.0 +-- +instance NFData e => NFData (Base32Error e) diff --git a/src/Data/Text/Encoding/Base32/Hex.hs b/src/Data/Text/Encoding/Base32/Hex.hs --- a/src/Data/Text/Encoding/Base32/Hex.hs +++ b/src/Data/Text/Encoding/Base32/Hex.hs @@ -1,68 +1,220 @@ -{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE Safe #-} -- | -- Module : Data.Text.Encoding.Base32.Hex --- Copyright : (c) 2019 Emily Pillmore --- License : BSD-style +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style -- --- Maintainer : Emily Pillmore --- Stability : Experimental --- Portability : portable +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable -- --- This module contains the combinators implementing the --- RFC 4648 specification for the Base32-Hex encoding including --- unpadded and lenient variants +-- This module contains 'Data.Text.Text'-valued combinators for +-- implementing the RFC 4648 specification of the Base32hex +-- encoding format. This includes strictly padded and unpadded +-- decoding variants, as well as internal and external validation +-- for canonicity. +-- module Data.Text.Encoding.Base32.Hex ( encodeBase32 , decodeBase32 +, decodeBase32With , encodeBase32Unpadded , decodeBase32Unpadded +, decodeBase32UnpaddedWith +, decodeBase32Padded +, decodeBase32PaddedWith -- , decodeBase32Lenient , isBase32Hex , isValidBase32Hex ) where -import qualified Data.ByteString.Base32.Hex as B32U +import Data.Bifunctor (first) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Base32.Hex as B32H import Data.Text (Text) import qualified Data.Text.Encoding as T +import Data.Text.Encoding.Base32.Error (Base32Error(..)) -- | Encode a 'Text' value in Base32hex with padding. -- --- See: +-- See: -- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "ADQMS===" +-- encodeBase32 :: Text -> Text -encodeBase32 = B32U.encodeBase32 . T.encodeUtf8 +encodeBase32 = B32H.encodeBase32 . T.encodeUtf8 {-# INLINE encodeBase32 #-} --- | Decode a padded Base32hex-encoded 'Text' value. +-- | Decode a padded Base32hex-encoded 'Text' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as base32hex encodings are optionally padded. -- --- See: +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32With` +-- and pass in a custom decode function. -- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32 "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- decodeBase32 :: Text -> Either Text Text -decodeBase32 = fmap T.decodeUtf8 . B32U.decodeBase32 . T.encodeUtf8 +decodeBase32 = fmap T.decodeLatin1 . B32H.decodeBase32 . T.encodeUtf8 {-# INLINE decodeBase32 #-} --- | Encode a 'Text' value in Base32hex without padding. +-- | Attempt to decode a 'ByteString' value as Base32hex, converting from +-- 'ByteString' to 'Text' according to some encoding function. In practice, +-- This is something like 'T.decodeUtf8'', which may produce an error. -- --- See: , --- +-- See: -- +-- === __Examples__: +-- +-- @ +-- 'decodeBase32With' 'T.decodeUtf8'' +-- :: 'Text' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' +-- @ +-- +decodeBase32With + :: (ByteString -> Either err Text) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base32Error err) Text +decodeBase32With f t = case B32H.decodeBase32 t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32With #-} + +-- | Encode a 'Text' value in Base32hex without padding. Note that for Base32hex, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32hex and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded "Sun" +-- "ADQMS" +-- encodeBase32Unpadded :: Text -> Text -encodeBase32Unpadded = B32U.encodeBase32Unpadded . T.encodeUtf8 +encodeBase32Unpadded = B32H.encodeBase32Unpadded . T.encodeUtf8 {-# INLINE encodeBase32Unpadded #-} --- | Decode an arbitrarily padded Base32hex encoded 'Text' value + +-- | Decode an unpadded Base32hex encoded 'Text' value. -- --- See: , --- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32WUnpaddedWith` +-- and pass in a custom decode function. -- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- decodeBase32Unpadded :: Text -> Either Text Text -decodeBase32Unpadded = fmap T.decodeUtf8 - . B32U.decodeBase32Unpadded +decodeBase32Unpadded = fmap T.decodeLatin1 + . B32H.decodeBase32Unpadded . T.encodeUtf8 {-# INLINE decodeBase32Unpadded #-} + +-- | Attempt to decode an unpadded 'ByteString' value as Base32hex, converting from +-- 'ByteString' to 'Text' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Example__: +-- +-- @ +-- 'decodeBase32UnpaddedWith' 'T.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' +-- @ +-- +decodeBase32UnpaddedWith + :: (ByteString -> Either err Text) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base32Error err) Text +decodeBase32UnpaddedWith f t = case B32H.decodeBase32Unpadded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32UnpaddedWith #-} + + +-- | Decode an padded Base32hex encoded 'Text' value +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32PaddedWith` +-- and pass in a custom decode function. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "ADQMS" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: Text -> Either Text Text +decodeBase32Padded = fmap T.decodeLatin1 + . B32H.decodeBase32Padded + . T.encodeUtf8 +{-# INLINE decodeBase32Padded #-} + +-- | Attempt to decode a padded 'ByteString' value as Base32hex, converting from +-- 'ByteString' to 'Text' according to some encoding function. In practice, +-- This is something like 'T.decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Example__: +-- +-- @ +-- 'decodeBase32PaddedWith' 'T.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' +-- @ +-- +decodeBase32PaddedWith + :: (ByteString -> Either err Text) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base32Error err) Text +decodeBase32PaddedWith f t = case B32H.decodeBase32Padded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32PaddedWith #-} + -- -- -- | 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. @@ -71,14 +223,25 @@ -- -- -- -- -- decodeBase32Lenient :: Text -> Text -- -- decodeBase32Lenient = T.decodeUtf8 --- -- . B32U.decodeBase32Lenient +-- -- . B32H.decodeBase32Lenient -- -- . T.encodeUtf8 -- -- {-# INLINE decodeBase32Lenient #-} -- | Tell whether a 'Text' value is Base32hex-encoded. -- +-- === __Examples__: +-- +-- >>> isBase32Hex "ADQMS" +-- True +-- +-- >>> isBase32Hex "ADQMS===" +-- True +-- +-- >>> isBase32Hex "ADQMS==" +-- False +-- isBase32Hex :: Text -> Bool -isBase32Hex = B32U.isBase32Hex . T.encodeUtf8 +isBase32Hex = B32H.isBase32Hex . T.encodeUtf8 {-# INLINE isBase32Hex #-} -- | Tell whether a 'Text' value is a valid Base32hex format. @@ -87,6 +250,17 @@ -- only that it conforms to the correct shape. To check whether it is a true -- Base32 encoded 'Text' value, use 'isBase32Hex'. -- +-- === __Examples__: +-- +-- >>> isValidBase32Hex "ADQMS" +-- True +-- +-- >>> isValidBase32Hex "ADQMS=" +-- False +-- +-- >>> isValidBase32Hex "ADQMS%" +-- False +-- isValidBase32Hex :: Text -> Bool -isValidBase32Hex = B32U.isValidBase32Hex . T.encodeUtf8 +isValidBase32Hex = B32H.isValidBase32Hex . T.encodeUtf8 {-# INLINE isValidBase32Hex #-} diff --git a/src/Data/Text/Lazy/Encoding/Base32.hs b/src/Data/Text/Lazy/Encoding/Base32.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Lazy/Encoding/Base32.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE Safe #-} +-- | +-- Module : Data.Text.Lazy.Encoding.Base32 +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains 'Data.Text.Lazy.Text'-valued combinators for +-- implementing the RFC 4648 specification of the Base32 +-- encoding format. This includes strictly padded/unpadded decoding +-- variants, as well as internal and external validation for canonicity. +-- +module Data.Text.Lazy.Encoding.Base32 +( -- * Encoding + encodeBase32 +, encodeBase32Unpadded + -- * Decoding +, decodeBase32 +, decodeBase32With +, decodeBase32Unpadded +, decodeBase32UnpaddedWith +, decodeBase32Padded +, decodeBase32PaddedWith +--, decodeBase32Lenient + -- * Validation +, isBase32 +, isValidBase32 +) where + + +import Data.Bifunctor (first) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Base32 as BL32 + +import qualified Data.Text as T +import Data.Text.Encoding.Base32.Error +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + +-- | Encode a 'TL.Text' value in Base32 with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "KN2W4===" +-- +encodeBase32 :: TL.Text -> TL.Text +encodeBase32 = BL32.encodeBase32 . TL.encodeUtf8 +{-# INLINE encodeBase32 #-} + +-- | Decode an arbitrarily padded Base32-encoded 'TL.Text' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as base32 encodings are optionally padded. +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'TL.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32With` +-- and pass in a custom decode function. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32 "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32 :: TL.Text -> Either T.Text TL.Text +decodeBase32 = fmap TL.decodeLatin1 . BL32.decodeBase32 . TL.encodeUtf8 +{-# INLINE decodeBase32 #-} + +-- | Attempt to decode a lazy 'ByteString' value as Base32, converting from +-- 'ByteString' to 'TL.Text' according to some encoding function. In practice, +-- This is something like 'TL.decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Examples__: +-- +-- @ +-- 'decodeBase32With' 'TL.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'TL.Text' +-- @ +-- +decodeBase32With + :: (ByteString -> Either err TL.Text) + -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base32Error err) TL.Text +decodeBase32With f t = case BL32.decodeBase32 t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32With #-} + +-- | Encode a 'TL.Text' value in Base32 without padding. Note that for Base32, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32 and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded "Sun" +-- "KN2W4" +-- +encodeBase32Unpadded :: TL.Text -> TL.Text +encodeBase32Unpadded = BL32.encodeBase32Unpadded . TL.encodeUtf8 +{-# INLINE encodeBase32Unpadded #-} + +-- | Decode an unpadded Base32 encoded 'TL.Text' value. +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'TL.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32WUnpaddedWith` +-- and pass in a custom decode function. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "KN2W4===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32Unpadded :: TL.Text -> Either T.Text TL.Text +decodeBase32Unpadded = fmap TL.decodeLatin1 + . BL32.decodeBase32Unpadded + . TL.encodeUtf8 +{-# INLINE decodeBase32Unpadded #-} + +-- | Attempt to decode an unpadded lazy 'ByteString' value as Base32, converting from +-- 'ByteString' to 'TL.Text' according to some encoding function. In practice, +-- This is something like 'TL.decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Examples__: +-- +-- @ +-- 'decodeBase32UnpaddedWith' 'TL.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'TL.Text' +-- @ +-- +decodeBase32UnpaddedWith + :: (ByteString -> Either err TL.Text) + -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base32Error err) TL.Text +decodeBase32UnpaddedWith f t = case BL32.decodeBase32Unpadded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32UnpaddedWith #-} + +-- | Decode an padded Base32 encoded 'TL.Text' value +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'TL.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32PaddedWith` +-- and pass in a custom decode function. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "KN2W4" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: TL.Text -> Either T.Text TL.Text +decodeBase32Padded = fmap TL.decodeLatin1 + . BL32.decodeBase32Padded + . TL.encodeUtf8 +{-# INLINE decodeBase32Padded #-} + +-- | Attempt to decode a padded lazy 'ByteString' value as Base32, converting from +-- 'ByteString' to 'TL.Text' according to some encoding function. In practice, +-- This is something like 'TL.decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Example__: +-- +-- @ +-- 'decodeBase32PaddedWith' 'TL.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' +-- @ +-- +decodeBase32PaddedWith + :: (ByteString -> Either err TL.Text) + -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base32Error err) TL.Text +decodeBase32PaddedWith f t = case BL32.decodeBase32Padded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32PaddedWith #-} + +-- -- | Leniently decode an unpadded Base32-encoded 'TL.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. +-- -- +-- -- === __Examples__: +-- -- +-- -- >>> decodeBase32Lenient "PDw_Pj4=" +-- -- "<>" +-- -- +-- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" +-- -- "<>" +-- -- +-- decodeBase32Lenient :: TL.Text -> TL.Text +-- decodeBase32Lenient = TL.decodeLatin1 +-- . BL32.decodeBase32Lenient +-- . TL.encodeUtf8 +-- {-# INLINE decodeBase32Lenient #-} + +-- | Tell whether a 'TL.Text' value is Base32-encoded +-- +-- === __Examples__: +-- +-- >>> isBase32 "KN2W4" +-- True +-- +-- >>> isBase32 "KN2W4===" +-- True +-- +-- >>> isBase32 "KN2W4==" +-- False +-- +isBase32 :: TL.Text -> Bool +isBase32 = BL32.isBase32 . TL.encodeUtf8 +{-# INLINE isBase32 #-} + +-- | Tell whether a 'TL.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 'TL.Text' value, use 'isBase32'. +-- +-- === __Examples__: +-- +-- >>> isValidBase32 "KN2W4" +-- True +-- +-- >>> isValidBase32 "KN2W4=" +-- False +-- +-- >>> isValidBase32 "KN2W4%" +-- False +-- +isValidBase32 :: TL.Text -> Bool +isValidBase32 = BL32.isValidBase32 . TL.encodeUtf8 +{-# INLINE isValidBase32 #-} diff --git a/src/Data/Text/Lazy/Encoding/Base32/Hex.hs b/src/Data/Text/Lazy/Encoding/Base32/Hex.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Lazy/Encoding/Base32/Hex.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE Safe #-} +-- | +-- Module : Data.Text.Lazy.Encoding.Base32.Hex +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains 'Data.Text.Lazy.Text'-valued combinators for +-- implementing the RFC 4648 specification of the Base32hex +-- encoding format. This includes strictly padded/unpadded decoding +-- variants, as well as internal and external validation for canonicity. +-- +module Data.Text.Lazy.Encoding.Base32.Hex +( -- * Encoding + encodeBase32 +, encodeBase32Unpadded + -- * Decoding +, decodeBase32 +, decodeBase32With +, decodeBase32Unpadded +, decodeBase32UnpaddedWith +, decodeBase32Padded +, decodeBase32PaddedWith +--, decodeBase32Lenient + -- * Validation +, isBase32Hex +, isValidBase32Hex +) where + + +import Data.Bifunctor (first) +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy.Base32.Hex as BL32H + +import qualified Data.Text as T +import Data.Text.Encoding.Base32.Error +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL + +-- | Encode a 'TL.Text' value in Base32hex with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "ADQMS===" +-- +encodeBase32 :: TL.Text -> TL.Text +encodeBase32 = BL32H.encodeBase32 . TL.encodeUtf8 +{-# INLINE encodeBase32 #-} + +-- | Decode a padded Base32hex-encoded 'TL.Text' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as base32hex encodings are optionally padded. +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'TL.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32With` +-- and pass in a custom decode function. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32 "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32 :: TL.Text -> Either T.Text TL.Text +decodeBase32 = fmap TL.decodeLatin1 . BL32H.decodeBase32 . TL.encodeUtf8 +{-# INLINE decodeBase32 #-} + +-- | Attempt to decode a lazy 'ByteString' value as Base32hex, converting from +-- 'ByteString' to 'TL.Text' according to some encoding function. In practice, +-- This is something like 'TL.decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Examples__: +-- +-- @ +-- 'decodeBase32With' 'TL.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'TL.Text' +-- @ +-- +decodeBase32With + :: (ByteString -> Either err TL.Text) + -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base32Error err) TL.Text +decodeBase32With f t = case BL32H.decodeBase32 t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32With #-} + +-- | Encode a 'TL.Text' value in Base32hex without padding. Note that for Base32hex, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32hex and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded "Sun" +-- "ADQMS" +-- +encodeBase32Unpadded :: TL.Text -> TL.Text +encodeBase32Unpadded = BL32H.encodeBase32Unpadded . TL.encodeUtf8 +{-# INLINE encodeBase32Unpadded #-} + +-- | Decode an unpadded Base32hex encoded 'TL.Text' value. +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'TL.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32WUnpaddedWith` +-- and pass in a custom decode function. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32Unpadded :: TL.Text -> Either T.Text TL.Text +decodeBase32Unpadded = fmap TL.decodeLatin1 + . BL32H.decodeBase32Unpadded + . TL.encodeUtf8 +{-# INLINE decodeBase32Unpadded #-} + +-- | Attempt to decode an unpadded lazy 'ByteString' value as Base32hex, converting from +-- 'ByteString' to 'TL.Text' according to some encoding function. In practice, +-- This is something like 'TL.decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Examples__: +-- +-- @ +-- 'decodeBase32UnpaddedWith' 'TL.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'TL.Text' +-- @ +-- +decodeBase32UnpaddedWith + :: (ByteString -> Either err TL.Text) + -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base32Error err) TL.Text +decodeBase32UnpaddedWith f t = case BL32H.decodeBase32Unpadded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32UnpaddedWith #-} + +-- | Decode an padded Base32hex encoded 'TL.Text' value +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'TL.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32PaddedWith` +-- and pass in a custom decode function. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "ADQMS" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: TL.Text -> Either T.Text TL.Text +decodeBase32Padded = fmap TL.decodeLatin1 + . BL32H.decodeBase32Padded + . TL.encodeUtf8 +{-# INLINE decodeBase32Padded #-} + +-- | Attempt to decode a padded lazy 'ByteString' value as Base32hex, converting from +-- 'ByteString' to 'TL.Text' according to some encoding function. In practice, +-- This is something like 'TL.decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Example__: +-- +-- @ +-- 'decodeBase32PaddedWith' 'TL.decodeUtf8'' +-- :: 'ByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'Text' +-- @ +-- +decodeBase32PaddedWith + :: (ByteString -> Either err TL.Text) + -- ^ convert a bytestring to text (e.g. 'TL.decodeUtf8'') + -> ByteString + -- ^ Input text to decode + -> Either (Base32Error err) TL.Text +decodeBase32PaddedWith f t = case BL32H.decodeBase32Padded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32PaddedWith #-} + +-- -- | Leniently decode an unpadded Base32hex-encoded 'TL.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. +-- -- +-- -- === __Examples__: +-- -- +-- -- >>> decodeBase32Lenient "PDw_Pj4=" +-- -- "<>" +-- -- +-- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" +-- -- "<>" +-- -- +-- decodeBase32Lenient :: TL.Text -> TL.Text +-- decodeBase32Lenient = TL.decodeLatin1 +-- . BL32H.decodeBase32Lenient +-- . TL.encodeUtf8 +-- {-# INLINE decodeBase32Lenient #-} + +-- | Tell whether a 'TL.Text' value is Base32hex-encoded +-- +-- === __Examples__: +-- +-- >>> isBase32Hex "ADQMS" +-- True +-- +-- >>> isBase32Hex "ADQMS===" +-- True +-- +-- >>> isBase32Hex "ADQMS==" +-- False +-- +isBase32Hex :: TL.Text -> Bool +isBase32Hex = BL32H.isBase32Hex . TL.encodeUtf8 +{-# INLINE isBase32Hex #-} + +-- | Tell whether a 'TL.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 'TL.Text' value, use 'isBase32Hex'. +-- +-- === __Examples__: +-- +-- >>> isValidBase32Hex "ADQMS" +-- True +-- +-- >>> isValidBase32Hex "ADQMS=" +-- False +-- +-- >>> isValidBase32Hex "ADQMS%" +-- False +-- +isValidBase32Hex :: TL.Text -> Bool +isValidBase32Hex = BL32H.isValidBase32Hex . TL.encodeUtf8 +{-# INLINE isValidBase32Hex #-} diff --git a/src/Data/Text/Short/Encoding/Base32.hs b/src/Data/Text/Short/Encoding/Base32.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Short/Encoding/Base32.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE Trustworthy #-} +-- | +-- Module : Data.Text.Short.Encoding.Base32 +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains 'Data.Text.Short.ShortText'-valued combinators +-- implementing the RFC 4648 specification for the Base32 +-- encoding format. This includes strictly padded/unpadded decoding +-- variants, and external + internal validations for canonicity. +-- +module Data.Text.Short.Encoding.Base32 +( -- * Encoding + encodeBase32 +, encodeBase32Unpadded + -- * Decoding +, decodeBase32 +, decodeBase32With +, decodeBase32Unpadded +, decodeBase32UnpaddedWith +, decodeBase32Padded +, decodeBase32PaddedWith +--, decodeBase32Lenient + -- * Validation +, isBase32 +, isValidBase32 +) where + + +import Data.Bifunctor (first) +import qualified Data.ByteString.Base32 as B32 +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short.Base32 as BS32 +import Data.Text (Text) +import qualified Data.Text.Encoding.Base32 as B32T +import Data.Text.Encoding.Base32.Error +import Data.Text.Short +import Data.Text.Short.Unsafe + +-- | Encode a 'ShortText' value in Base32 with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "KN2W4===" +-- +encodeBase32 :: ShortText -> ShortText +encodeBase32 = fromByteStringUnsafe + . B32.encodeBase32' + . toByteString +{-# INLINE encodeBase32 #-} + +-- | Decode an arbitrarily padded Base32-encoded 'ShortText' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as base32 encodings are optionally padded. +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'Data.Text.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32With` +-- and pass in a custom decode function. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32 "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32 "KN2W===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32 :: ShortText -> Either Text ShortText +decodeBase32 = fmap fromText . B32T.decodeBase32 . toText +{-# INLINE decodeBase32 #-} + +-- | Attempt to decode a 'ShortByteString' value as Base32, converting from +-- 'ByteString' to 'ShortText' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Examples__: +-- +-- @ +-- 'decodeBase32With' '(fmap fromText . T.decodeUtf8' . toText)' +-- :: 'ShortByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'ShortText' +-- @ +-- +decodeBase32With + :: (ShortByteString -> Either err ShortText) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ShortByteString + -- ^ Input text to decode + -> Either (Base32Error err) ShortText +decodeBase32With f t = case BS32.decodeBase32 t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32With #-} + +-- | Encode a 'ShortText' value in Base32 without padding. Note that for Base32, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32 and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded "Sun" +-- "KN2W4" +-- +encodeBase32Unpadded :: ShortText -> ShortText +encodeBase32Unpadded = fromByteStringUnsafe + . B32.encodeBase32Unpadded' + . toByteString +{-# INLINE encodeBase32Unpadded #-} + +-- | Decode an unpadded Base32 encoded 'ShortText' value. +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32UnpaddedWith` +-- and pass in a custom decode function. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "KN2W4" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "KN2W4===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32Unpadded :: ShortText -> Either Text ShortText +decodeBase32Unpadded = fmap fromText . B32T.decodeBase32Unpadded . toText +{-# INLINE decodeBase32Unpadded #-} + +-- | Attempt to decode an unpadded 'ShortByteString' value as Base32, converting from +-- 'ShortByteString' to 'ShortText' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Examples__: +-- +-- @ +-- 'decodeBase32UnpaddedWith' '(fmap fromText . T.decodeUtf8' . toText)' +-- :: 'ShortByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'ShortText' +-- @ +-- +decodeBase32UnpaddedWith + :: (ShortByteString -> Either err ShortText) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ShortByteString + -- ^ Input text to decode + -> Either (Base32Error err) ShortText +decodeBase32UnpaddedWith f t = case BS32.decodeBase32Unpadded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32UnpaddedWith #-} + +-- | Decode an padded Base32 encoded 'ShortText' value +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'T.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32PaddedWith` +-- and pass in a custom decode function. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "KN2W4===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "KN2W4" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: ShortText -> Either Text ShortText +decodeBase32Padded = fmap fromText . B32T.decodeBase32Padded . toText +{-# INLINE decodeBase32Padded #-} + +-- | Attempt to decode a padded 'ShortByteString' value as Base32, converting from +-- 'ByteString' to 'ShortText' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Examples__: +-- +-- @ +-- 'decodeBase32With' '(fmap fromText . T.decodeUtf8' . toText)' +-- :: 'ShortByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'ShortText' +-- @ +-- +decodeBase32PaddedWith + :: (ShortByteString -> Either err ShortText) + -- ^ convert a bytestring to text (e.g. 'T.decodeUtf8'') + -> ShortByteString + -- ^ Input text to decode + -> Either (Base32Error err) ShortText +decodeBase32PaddedWith f t = case BS32.decodeBase32Padded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32PaddedWith #-} + +-- -- | Leniently decode an unpadded Base32-encoded 'ShortText'. 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 4328-compliant. +-- -- +-- -- === __Examples__: +-- -- +-- -- >>> decodeBase32Lenient "PDw_Pj4=" +-- -- "<>" +-- -- +-- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" +-- -- "<>" +-- -- +-- decodeBase32Lenient :: ShortText -> ShortText +-- decodeBase32Lenient = fromText . B32T.decodeBase32Lenient . toText +-- {-# INLINE decodeBase32Lenient #-} + +-- | Tell whether a 'ShortText' value is Base32-encoded. +-- +-- === __Examples__: +-- +-- >>> isBase32 "KN2W4" +-- True +-- +-- >>> isBase32 "KN2W4===" +-- True +-- +-- >>> isBase32 "KN2W4==" +-- False +-- +isBase32 :: ShortText -> Bool +isBase32 = B32.isBase32 . toByteString +{-# INLINE isBase32 #-} + +-- | Tell whether a 'ShortText' 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 'ShortText' value, use 'isBase32'. +-- +-- === __Examples__: +-- +-- >>> isValidBase32 "KN2W4" +-- True +-- +-- >>> isValidBase32 "KN2W4=" +-- False +-- +-- >>> isValidBase32 "KN2W4%" +-- False +-- +isValidBase32 :: ShortText -> Bool +isValidBase32 = B32.isValidBase32 . toByteString +{-# INLINE isValidBase32 #-} diff --git a/src/Data/Text/Short/Encoding/Base32/Hex.hs b/src/Data/Text/Short/Encoding/Base32/Hex.hs new file mode 100644 --- /dev/null +++ b/src/Data/Text/Short/Encoding/Base32/Hex.hs @@ -0,0 +1,273 @@ +{-# LANGUAGE Trustworthy #-} +-- | +-- Module : Data.Text.Short.Encoding.Base32.Hex +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : stable +-- Portability : non-portable +-- +-- This module contains 'Data.Text.Short.ShortText'-valued combinators +-- implementing the RFC 4648 specification for the Base32hex +-- encoding format. This includes strictly padded/unpadded +-- decoding variants, and external + internal validations for canonicity. +-- +module Data.Text.Short.Encoding.Base32.Hex +( -- * Encoding + encodeBase32 +, encodeBase32Unpadded + -- * Decoding +, decodeBase32 +, decodeBase32With +, decodeBase32Unpadded +, decodeBase32UnpaddedWith +, decodeBase32Padded +, decodeBase32PaddedWith +--, decodeBase32Lenient + -- * Validation +, isBase32Hex +, isValidBase32Hex +) where + + +import Data.Bifunctor (first) +import qualified Data.ByteString.Base32.Hex as B32H +import Data.ByteString.Short (ShortByteString) +import qualified Data.ByteString.Short.Base32.Hex as BS32H +import Data.Text (Text) +import qualified Data.Text.Encoding.Base32.Hex as B32TH +import Data.Text.Encoding.Base32.Error +import Data.Text.Short +import Data.Text.Short.Unsafe + +-- | Encode a 'ShortText' value in Base32hex with padding. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32 "Sun" +-- "ADQMS===" +-- +encodeBase32 :: ShortText -> ShortText +encodeBase32 = fromByteStringUnsafe + . B32H.encodeBase32' + . toByteString +{-# INLINE encodeBase32 #-} + +-- | Decode an arbitrarily padded Base32hex-encoded 'ShortText' value. If its length is not a multiple +-- of 4, then padding chars will be added to fill out the input to a multiple of +-- 4 for safe decoding as base32hex encodings are optionally padded. +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'Data.Text.Encoding.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32With` +-- and pass in a custom decode function. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32 "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32 "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32 :: ShortText -> Either Text ShortText +decodeBase32 = fmap fromText . B32TH.decodeBase32 . toText +{-# INLINE decodeBase32 #-} + +-- | Attempt to decode a 'ShortByteString' value as Base32hex, converting from +-- 'ByteString' to 'ShortText' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Examples__: +-- +-- @ +-- 'decodeBase32With' '(fmap fromText . Data.Text.Encoding.decodeUtf8' . toText)' +-- :: 'ShortByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'ShortText' +-- @ +-- +decodeBase32With + :: (ShortByteString -> Either err ShortText) + -- ^ convert a bytestring to text (e.g. '(fmap fromText . Data.Text.Encoding.decodeUtf8' . toText)') + -> ShortByteString + -- ^ Input text to decode + -> Either (Base32Error err) ShortText +decodeBase32With f t = case BS32H.decodeBase32 t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32With #-} + +-- | Encode a 'ShortText' value in Base32hex without padding. Note that for Base32hex, +-- padding is optional. If you call this function, you will simply be encoding +-- as Base32hex and stripping padding chars from the output. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> encodeBase32Unpadded "Sun" +-- "ADQMS" +-- +encodeBase32Unpadded :: ShortText -> ShortText +encodeBase32Unpadded = fromByteStringUnsafe + . B32H.encodeBase32Unpadded' + . toByteString +{-# INLINE encodeBase32Unpadded #-} + +-- | Decode an unpadded Base32hex encoded 'ShortText' value. +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'Data.Text.Encoding.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32UnpaddedWith` +-- and pass in a custom decode function. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Unpadded "ADQMS" +-- Right "Sun" +-- +-- >>> decodeBase32Unpadded "ADQMS===" +-- Left "Base32-encoded bytestring has invalid padding" +-- +decodeBase32Unpadded :: ShortText -> Either Text ShortText +decodeBase32Unpadded = fmap fromText . B32TH.decodeBase32Unpadded . toText +{-# INLINE decodeBase32Unpadded #-} + +-- | Attempt to decode an unpadded 'ShortByteString' value as Base32hex, converting from +-- 'ShortByteString' to 'ShortText' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Examples__: +-- +-- @ +-- 'decodeBase32UnpaddedWith' '(fmap fromText . Data.Text.Encoding.decodeUtf8' . toText)' +-- :: 'ShortByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'ShortText' +-- @ +-- +decodeBase32UnpaddedWith + :: (ShortByteString -> Either err ShortText) + -- ^ convert a bytestring to text (e.g. '(fmap fromText . Data.Text.Encoding.decodeUtf8' . toText)') + -> ShortByteString + -- ^ Input text to decode + -> Either (Base32Error err) ShortText +decodeBase32UnpaddedWith f t = case BS32H.decodeBase32Unpadded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32UnpaddedWith #-} + +-- | Decode an padded Base32hex encoded 'ShortText' value +-- +-- /Note:/ This function makes sure that decoding is total by deferring to +-- 'Data.Text.Encoding.decodeLatin1'. This will always round trip for any valid Base32-encoded +-- text value, but it may not round trip for bad inputs. The onus is on the +-- caller to make sure inputs are valid. If unsure, defer to `decodeBase32PaddedWith` +-- and pass in a custom decode function. +-- +-- See: +-- +-- === __Examples__: +-- +-- >>> decodeBase32Padded "ADQMS===" +-- Right "Sun" +-- +-- >>> decodeBase32Padded "ADQMS" +-- Left "Base32-encoded bytestring requires padding" +-- +decodeBase32Padded :: ShortText -> Either Text ShortText +decodeBase32Padded = fmap fromText . B32TH.decodeBase32Padded . toText +{-# INLINE decodeBase32Padded #-} + +-- | Attempt to decode a padded 'ShortByteString' value as Base32hex, converting from +-- 'ByteString' to 'ShortText' according to some encoding function. In practice, +-- This is something like 'decodeUtf8'', which may produce an error. +-- +-- See: +-- +-- === __Examples__: +-- +-- @ +-- 'decodeBase32With' '(fmap fromText . Data.Text.Encoding.decodeUtf8' . toText)' +-- :: 'ShortByteString' -> 'Either' ('Base32Error' 'UnicodeException') 'ShortText' +-- @ +-- +decodeBase32PaddedWith + :: (ShortByteString -> Either err ShortText) + -- ^ convert a bytestring to text (e.g. 'Data.Text.Encoding.decodeUtf8'') + -> ShortByteString + -- ^ Input text to decode + -> Either (Base32Error err) ShortText +decodeBase32PaddedWith f t = case BS32H.decodeBase32Padded t of + Left de -> Left $ DecodeError de + Right a -> first ConversionError (f a) +{-# INLINE decodeBase32PaddedWith #-} + +-- -- | Leniently decode an unpadded Base32hex-encoded 'ShortText'. 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. +-- -- +-- -- === __Examples__: +-- -- +-- -- >>> decodeBase32Lenient "PDw_Pj4=" +-- -- "<>" +-- -- +-- -- >>> decodeBase32Lenient "PDw_%%%$}Pj4" +-- -- "<>" +-- -- +-- decodeBase32Lenient :: ShortText -> ShortText +-- decodeBase32Lenient = fromText . B32TH.decodeBase32Lenient . toText +-- {-# INLINE decodeBase32Lenient #-} + +-- | Tell whether a 'ShortText' value is Base32hex-encoded. +-- +-- === __Examples__: +-- +-- >>> isBase32Hex "ADQMS" +-- True +-- +-- >>> isBase32Hex "ADQMS===" +-- True +-- +-- >>> isBase32Hex "ADQMS==" +-- False +-- +isBase32Hex :: ShortText -> Bool +isBase32Hex = B32H.isBase32Hex . toByteString +{-# INLINE isBase32Hex #-} + +-- | Tell whether a 'ShortText' 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 'ShortText' value, use 'isBase32Hex'. +-- +-- === __Examples__: +-- +-- >>> isValidBase32Hex "ADQMS" +-- True +-- +-- >>> isValidBase32Hex "ADQMS=" +-- False +-- +-- >>> isValidBase32Hex "ADQMS%" +-- False +-- +isValidBase32Hex :: ShortText -> Bool +isValidBase32Hex = B32H.isValidBase32Hex . toByteString +{-# INLINE isValidBase32Hex #-} diff --git a/test/Base32Tests.hs b/test/Base32Tests.hs deleted file mode 100644 --- a/test/Base32Tests.hs +++ /dev/null @@ -1,148 +0,0 @@ -{-# 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 diff --git a/test/Internal.hs b/test/Internal.hs new file mode 100644 --- /dev/null +++ b/test/Internal.hs @@ -0,0 +1,308 @@ +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE EmptyDataDecls #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE PackageImports #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} +-- | +-- Module : Main +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- This module contains internal test harnesses for `base32` +-- +module Internal where + + +import qualified Data.ByteString as BS +import "base32" Data.ByteString.Base32 as B32 +import "base32" Data.ByteString.Base32.Hex as B32H +import qualified Data.ByteString.Lazy as LBS +import "base32" Data.ByteString.Lazy.Base32 as BL32 +import "base32" Data.ByteString.Lazy.Base32.Hex as BL32H +import qualified Data.ByteString.Short as SBS +import "base32" Data.ByteString.Short.Base32 as BS32 +import "base32" Data.ByteString.Short.Base32.Hex as BS32H +import Data.Proxy +import Data.String +import Data.Text (Text) +import qualified Data.Text as T +import "base32" Data.Text.Encoding.Base32 as T32 +import "base32" Data.Text.Encoding.Base32.Error (Base32Error) +import "base32" Data.Text.Encoding.Base32.Hex as T32H +import qualified Data.Text.Lazy as TL +import "base32" Data.Text.Lazy.Encoding.Base32 as TL32 +import "base32" Data.Text.Lazy.Encoding.Base32.Hex as TL32H +import qualified Data.Text.Short as TS +import "base32" Data.Text.Short.Encoding.Base32 as TS32 +import "base32" Data.Text.Short.Encoding.Base32.Hex as TS32H + +import Test.QuickCheck hiding (label) + +-- ------------------------------------------------------------------ -- +-- Test Harnesses + +data Impl + = B32 + | BL32 + | BS32 + | T32 + | TL32 + | TS32 + +b32 :: Proxy 'B32 +b32 = Proxy + +bl32 :: Proxy 'BL32 +bl32 = Proxy + +bs32 :: Proxy 'BS32 +bs32 = Proxy + +t32 :: Proxy 'T32 +t32 = Proxy + +tl32 :: Proxy 'TL32 +tl32 = Proxy + +ts32 :: Proxy 'TS32 +ts32 = Proxy + +-- | This class provides the generic API definition for +-- the base32 std alphabet +-- +class + ( Eq bs + , Show bs + , Arbitrary bs + , CoArbitrary bs + , IsString bs + ) => Harness (a :: Impl) bs | a -> bs, bs -> a + where + + label :: String + + encode :: bs -> bs + encodeNopad :: bs -> bs + encodeHex :: bs -> bs + encodeHexNopad :: bs -> bs + + decode :: bs -> Either Text bs + decodeHex :: bs -> Either Text bs + decodePad :: bs -> Either Text bs + decodeHexPad :: bs -> Either Text bs + decodeNopad :: bs -> Either Text bs + decodeHexNopad :: bs -> Either Text bs + + correct :: bs -> Bool + correctHex :: bs -> Bool + + validate :: bs -> Bool + validateHex :: bs -> Bool + + +instance Harness 'B32 BS.ByteString where + label = "ByteString" + + encode = B32.encodeBase32' + encodeNopad = B32.encodeBase32Unpadded' + + decode = B32.decodeBase32 + decodePad = B32.decodeBase32Padded + decodeNopad = B32.decodeBase32Unpadded + correct = B32.isBase32 + validate = B32.isValidBase32 + + encodeHex = B32H.encodeBase32' + encodeHexNopad = B32H.encodeBase32Unpadded' + decodeHex = B32H.decodeBase32 + decodeHexPad = B32H.decodeBase32Padded + decodeHexNopad = B32H.decodeBase32Unpadded + correctHex = B32H.isBase32Hex + validateHex = B32H.isValidBase32Hex + +instance Harness 'BL32 LBS.ByteString where + label = "Lazy ByteString" + + encode = BL32.encodeBase32' + encodeNopad = BL32.encodeBase32Unpadded' + + decode = BL32.decodeBase32 + decodePad = BL32.decodeBase32Padded + decodeNopad = BL32.decodeBase32Unpadded + correct = BL32.isBase32 + validate = BL32.isValidBase32 + + encodeHex = BL32H.encodeBase32' + encodeHexNopad = BL32H.encodeBase32Unpadded' + decodeHex = BL32H.decodeBase32 + decodeHexPad = BL32H.decodeBase32Padded + decodeHexNopad = BL32H.decodeBase32Unpadded + correctHex = BL32H.isBase32Hex + validateHex = BL32H.isValidBase32Hex + +instance Harness 'BS32 SBS.ShortByteString where + label = "Short ByteString" + + encode = BS32.encodeBase32' + encodeNopad = BS32.encodeBase32Unpadded' + + decode = BS32.decodeBase32 + decodePad = BS32.decodeBase32Padded + decodeNopad = BS32.decodeBase32Unpadded + correct = BS32.isBase32 + validate = BS32.isValidBase32 + + encodeHex = BS32H.encodeBase32' + encodeHexNopad = BS32H.encodeBase32Unpadded' + decodeHex = BS32H.decodeBase32 + decodeHexPad = BS32H.decodeBase32Padded + decodeHexNopad = BS32H.decodeBase32Unpadded + correctHex = BS32H.isBase32Hex + validateHex = BS32H.isValidBase32Hex + +instance Harness 'T32 T.Text where + label = "Text" + + encode = T32.encodeBase32 + encodeNopad = T32.encodeBase32Unpadded + decode = T32.decodeBase32 + decodeNopad = T32.decodeBase32Unpadded + decodePad = T32.decodeBase32Padded + correct = T32.isBase32 + + encodeHex = T32H.encodeBase32 + encodeHexNopad = T32H.encodeBase32Unpadded + decodeHex = T32H.decodeBase32 + decodeHexPad = T32H.decodeBase32Padded + decodeHexNopad = T32H.decodeBase32Unpadded + + correctHex = T32H.isBase32Hex + validateHex = T32H.isValidBase32Hex + validate = T32.isValidBase32 + +instance Harness 'TL32 TL.Text where + label = "Lazy Text" + + encode = TL32.encodeBase32 + encodeNopad = TL32.encodeBase32Unpadded + decode = TL32.decodeBase32 + decodeNopad = TL32.decodeBase32Unpadded + decodePad = TL32.decodeBase32Padded + correct = TL32.isBase32 + + encodeHex = TL32H.encodeBase32 + encodeHexNopad = TL32H.encodeBase32Unpadded + decodeHex = TL32H.decodeBase32 + decodeHexPad = TL32H.decodeBase32Padded + decodeHexNopad = TL32H.decodeBase32Unpadded + + correctHex = TL32H.isBase32Hex + validateHex = TL32H.isValidBase32Hex + validate = TL32.isValidBase32 + +instance Harness 'TS32 TS.ShortText where + label = "Short Text" + + encode = TS32.encodeBase32 + encodeNopad = TS32.encodeBase32Unpadded + decode = TS32.decodeBase32 + decodeNopad = TS32.decodeBase32Unpadded + decodePad = TS32.decodeBase32Padded + correct = TS32.isBase32 + + encodeHex = TS32H.encodeBase32 + encodeHexNopad = TS32H.encodeBase32Unpadded + decodeHex = TS32H.decodeBase32 + decodeHexPad = TS32H.decodeBase32Padded + decodeHexNopad = TS32H.decodeBase32Unpadded + + correctHex = TS32H.isBase32Hex + validateHex = TS32H.isValidBase32Hex + validate = TS32.isValidBase32 + +class Harness a cs + => TextHarness (a :: Impl) cs bs + | a -> cs, bs -> cs, cs -> a, cs -> bs where + decodeWith_ :: (bs -> Either err cs) -> bs -> Either (Base32Error err) cs + decodePaddedWith_ :: (bs -> Either err cs) -> bs -> Either (Base32Error err) cs + decodeUnpaddedWith_ :: (bs -> Either err cs) -> bs -> Either (Base32Error err) cs + decodeHexWith_ :: (bs -> Either err cs) -> bs -> Either (Base32Error err) cs + decodeHexPaddedWith_ :: (bs -> Either err cs) -> bs -> Either (Base32Error err) cs + decodeHexUnpaddedWith_ :: (bs -> Either err cs) -> bs -> Either (Base32Error err) cs + + +instance TextHarness 'T32 Text BS.ByteString where + decodeWith_ = T32.decodeBase32With + decodePaddedWith_ = T32.decodeBase32PaddedWith + decodeUnpaddedWith_ = T32.decodeBase32UnpaddedWith + decodeHexWith_ = T32H.decodeBase32With + decodeHexPaddedWith_ = T32H.decodeBase32PaddedWith + decodeHexUnpaddedWith_ = T32H.decodeBase32UnpaddedWith + +instance TextHarness 'TL32 TL.Text LBS.ByteString where + decodeWith_ = TL32.decodeBase32With + decodePaddedWith_ = TL32.decodeBase32PaddedWith + decodeUnpaddedWith_ = TL32.decodeBase32UnpaddedWith + decodeHexWith_ = TL32H.decodeBase32With + decodeHexPaddedWith_ = TL32H.decodeBase32PaddedWith + decodeHexUnpaddedWith_ = TL32H.decodeBase32UnpaddedWith + +instance TextHarness 'TS32 TS.ShortText SBS.ShortByteString where + decodeWith_ = TS32.decodeBase32With + decodePaddedWith_ = TS32.decodeBase32PaddedWith + decodeUnpaddedWith_ = TS32.decodeBase32UnpaddedWith + decodeHexWith_ = TS32H.decodeBase32With + decodeHexPaddedWith_ = TS32H.decodeBase32PaddedWith + decodeHexUnpaddedWith_ = TS32H.decodeBase32UnpaddedWith + +-- ------------------------------------------------------------------ -- +-- Quickcheck instances + +instance Arbitrary BS.ByteString where + arbitrary = BS.pack <$> arbitrary + shrink xs = BS.pack <$> shrink (BS.unpack xs) + +instance CoArbitrary BS.ByteString where + coarbitrary = coarbitrary . BS.unpack + +instance Arbitrary LBS.ByteString where + arbitrary = LBS.pack <$> arbitrary + shrink xs = LBS.pack <$> shrink (LBS.unpack xs) + +instance CoArbitrary LBS.ByteString where + coarbitrary = coarbitrary . LBS.unpack + +instance Arbitrary SBS.ShortByteString where + arbitrary = SBS.pack <$> arbitrary + shrink xs = SBS.pack <$> shrink (SBS.unpack xs) + +instance CoArbitrary SBS.ShortByteString where + coarbitrary = coarbitrary . SBS.unpack + +instance Arbitrary T.Text where + arbitrary = T.pack <$> arbitrary + shrink xs = T.pack <$> shrink (T.unpack xs) + +instance Arbitrary TL.Text where + arbitrary = TL.pack <$> arbitrary + shrink xs = TL.pack <$> shrink (TL.unpack xs) + +instance CoArbitrary T.Text where + coarbitrary = coarbitrary . T.unpack + +instance CoArbitrary TL.Text where + coarbitrary = coarbitrary . TL.unpack + +instance Arbitrary TS.ShortText where + arbitrary = TS.fromText <$> arbitrary + shrink xs = fmap TS.fromText $ shrink (TS.toText xs) + +instance CoArbitrary TS.ShortText where + coarbitrary = coarbitrary . TS.toText diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,465 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PackageImports #-} +{-# LANGUAGE AllowAmbiguousTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} +-- | +-- Module : Main +-- Copyright : (c) 2019-2020 Emily Pillmore +-- License : BSD-style +-- +-- Maintainer : Emily Pillmore +-- Stability : Experimental +-- Portability : portable +-- +-- This module contains the test implementation for the `base32` package +-- +module Main +( main +) where + + +import Prelude hiding (length) + +import Data.Bifunctor (second) +import qualified "memory" Data.ByteArray.Encoding as Mem +import qualified Data.ByteString as BS +import Data.ByteString.Internal (c2w) +import "base32" Data.ByteString.Base32 as B32 +import "base32" Data.ByteString.Base32.Hex as B32H +import qualified Data.ByteString.Lazy as LBS +import qualified Data.ByteString.Short as SBS +import qualified Data.Text as T +import qualified Data.Text.Encoding as T +import Data.Text.Encoding.Base32.Error (Base32Error(..)) +import qualified Data.Text.Lazy as TL +import qualified Data.Text.Lazy.Encoding as TL +import qualified Data.Text.Short as TS +import Data.Word + +import Internal + +import Test.Tasty +import Test.Tasty.HUnit +import Test.Tasty.QuickCheck (testProperty) + + +main :: IO () +main = defaultMain tests + + +tests :: TestTree +tests = testGroup "Base32 Tests" + [ mkTree b32 + [ mkPropTree + , mkUnitTree + ] + , mkTree bl32 + [ mkPropTree + , mkUnitTree + ] + , mkTree bs32 + [ mkPropTree + , mkUnitTree + ] + , mkTree t32 + [ mkPropTree + , mkUnitTree + , mkDecodeTree T.decodeUtf8' b32 + ] + , mkTree tl32 + [ mkPropTree + , mkUnitTree + , mkDecodeTree TL.decodeUtf8' bl32 + ] + , mkTree ts32 + [ mkPropTree + , mkUnitTree + , mkDecodeTree + (second TS.fromText . T.decodeUtf8' . SBS.fromShort) bs32 + ] + ] + +-- ---------------------------------------------------------------- -- +-- Test tree generation + +-- | Make a test tree for a given label +-- +mkTree + :: forall a b proxy + . Harness a b + => proxy a + -> [proxy a -> TestTree] + -> TestTree +mkTree a = testGroup (label @a) . fmap ($ a) + +-- | Make a test group with some name, lifting a test tree up to the correct +-- type information via some Harness +-- +mkTests + :: forall a b proxy + . Harness a b + => String + -> [proxy a -> TestTree] + -> proxy a + -> TestTree +mkTests context ts = testGroup context . (<*>) ts . pure + +-- | Make property tests for a given harness instance +-- +mkPropTree :: forall a b proxy. Harness a b => proxy a -> TestTree +mkPropTree = mkTests "Property Tests" + [ prop_roundtrip + , prop_correctness + , prop_padding_invariants + , const prop_mem_coherence + ] + +-- | Make unit tests for a given harness instance +-- +mkUnitTree + :: forall a b proxy + . Harness a b + => proxy a + -> TestTree +mkUnitTree = mkTests "Unit tests" + [ rfcVectors + , offsetVectors + , validityTests + ] + +-- | Make unit tests for textual 'decode*With' functions +-- +mkDecodeTree + :: forall t a b c e proxy + . ( TextHarness a b c + , Harness t c + , Show e + ) + => (c -> Either e b) + -> proxy t + -> proxy a + -> TestTree +mkDecodeTree utf8 t = mkTests "Decoding tests" + [ decodeWithVectors utf8 t + ] + +-- ---------------------------------------------------------------- -- +-- Property tests + +prop_roundtrip :: forall a b proxy. Harness a b => proxy a -> TestTree +prop_roundtrip _ = testGroup "prop_roundtrip" + [ testProperty "prop_std_roundtrip" $ \(bs :: b) -> + Right (encode bs) == decode (encode (encode bs)) + , testProperty "prop_hex_roundtrip" $ \(bs :: b) -> + Right (encodeHex bs) == decodeHex (encodeHex (encodeHex bs)) + , testProperty "prop_hex_roundtrip_nopad" $ \(bs :: b) -> + Right (encodeHexNopad bs) + == decodeHexNopad (encodeHexNopad (encodeHexNopad bs)) + ] + +prop_correctness :: forall a b proxy. Harness a b => proxy a -> TestTree +prop_correctness _ = testGroup "prop_validity" + [ testProperty "prop_std_valid" $ \(bs :: b) -> + validate (encode bs) + , testProperty "prop_hex_valid" $ \(bs :: b) -> + validateHex (encodeHex bs) + , testProperty "prop_std_correct" $ \(bs :: b) -> + correct (encode bs) + , testProperty "prop_hex_correct" $ \(bs :: b) -> + correctHex (encodeHex bs) + ] + +prop_padding_invariants :: forall a b proxy. Harness a b => proxy a -> TestTree +prop_padding_invariants _ = testGroup "prop_padding_invariants" + [ testProperty "prop_hex_nopad_roundtrip" $ \(bs :: b) -> + Right (encodeHexNopad bs) + == decodeHexNopad (encodeHexNopad (encodeHexNopad bs)) + + , testProperty "prop_hex_pad_roundtrip" $ \(bs :: b) -> + Right (encodeHex bs) == decodeHexPad (encodeHex (encodeHex bs)) + + , testProperty "prop_hex_decode_invariant" $ \(bs :: b) -> + ( decodeHexNopad (encodeHexNopad (encodeHex bs)) + == decodeHex (encodeHex (encodeHex bs)) + ) || + ( decodeHexPad (encodeHex (encodeHex bs)) + == decodeHex (encodeHex (encodeHex bs)) + ) + + , testProperty "prop_std_decode_invariant" $ \(bs :: b) -> + ( decodeNopad (encodeNopad (encode bs)) + == decode (encode (encode bs)) + ) || + ( decodePad (encode (encode bs)) + == decode (encode (encode bs)) + ) + + , testProperty "prop_hex_padding_coherence" $ \(bs :: b) -> + Right (encodeHex bs) == decodeHex (encodeHex (encodeHex bs)) + && Right (encodeHex bs) == decodeHexPad (encodeHex (encodeHex bs)) + + , testProperty "prop_hex_nopadding_coherence" $ \(bs :: b) -> + Right (encodeHexNopad bs) == decodeHexNopad (encodeHexNopad (encodeHexNopad bs)) + && Right (encodeHexNopad bs) == decodeHex (encodeHexNopad (encodeHexNopad bs)) + ] + +-- | just a sanity check against `memory` +-- +prop_mem_coherence :: TestTree +prop_mem_coherence = testGroup "prop_mem_coherence" + [ testProperty "prop_std_mem_coherence" $ \bs -> + Right bs == B32.decodeBase32 (B32.encodeBase32' bs) + && Right bs == Mem.convertFromBase Mem.Base32 (Mem.convertToBase @BS.ByteString @BS.ByteString Mem.Base32 bs) + ] + +-- ---------------------------------------------------------------- -- +-- Unit tests + +-- | RFC 4328 test vectors +-- +rfcVectors :: forall a b proxy. Harness a b => proxy a -> TestTree +rfcVectors _ = testGroup "RFC 4648 Test Vectors" + [ testGroup "std alphabet" + [ testCaseStd "" "" + , testCaseStd "f" "MY======" + , testCaseStd "fo" "MZXQ====" + , testCaseStd "foo" "MZXW6===" + , testCaseStd "foob" "MZXW6YQ=" + , testCaseStd "fooba" "MZXW6YTB" + , testCaseStd "foobar" "MZXW6YTBOI======" + ] + , testGroup "hex alphabet" + [ testCaseHex "" "" + , testCaseHex "f" "CO======" + , testCaseHex "fo" "CPNG====" + , testCaseHex "foo" "CPNMU===" + , testCaseHex "foob" "CPNMUOG=" + , testCaseHex "fooba" "CPNMUOJ1" + , testCaseHex "foobar" "CPNMUOJ1E8======" + ] + ] + where + testCaseStd s t = + testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do + step "encode is sound" + t @=? encode @a s + + step "decode is sound" + Right s @=? decode (encode s) + + testCaseHex s t = + testCaseSteps (show $ if s == "" then "empty" else s) $ \step -> do + step "encode is sound" + t @=? encodeHex @a s + + step "decode is sound" + Right s @=? decodeHexPad t + +-- | Unit test trees for the `decode*With` family of text-valued functions +-- +decodeWithVectors + :: forall t a b c e proxy + . ( TextHarness a c b + , Harness t b + , Show e + ) + => (b -> Either e c) + -- ^ utf8 + -> proxy t + -- ^ witness to the bytestring-ey dictionaries + -> proxy a + -- ^ witness to the text dictionaries + -> TestTree +decodeWithVectors utf8 _ _ = testGroup "DecodeWith* unit tests" + [ testGroup "decodeWith negative tests" + [ testCase "decodeWith non-utf8 inputs on decodeUtf8" $ do + case decodeWith_ @a utf8 "\1079743" of + Left (DecodeError _) -> return () + _ -> assertFailure "decoding phase" + , testCase "decodeWith valid utf8 inputs on decodeUtf8" $ do + case decodeWith_ @a utf8 (encode @t "\1079743") of + Left (ConversionError _) -> return () + _ -> assertFailure "conversion phase" + , testCase "decodeHexWith non-utf8 inputs on decodeUtf8" $ do + case decodeHexWith_ @a utf8 "\1079743" of + Left (DecodeError _) -> return () + _ -> assertFailure "decoding phase" + , testCase "decodePaddedWith non-utf8 inputs on decodeUtf8" $ do + case decodePaddedWith_ @a utf8 "\1079743" of + Left (DecodeError _) -> return () + _ -> assertFailure "decoding phase" + , testCase "decodePaddedWith valid utf8 inputs on decodeUtf8" $ do + case decodePaddedWith_ @a utf8 (encode @t "\1079743") of + Left (ConversionError _) -> return () + _ -> assertFailure "conversion phase" + , testCase "decodeUnpaddedWith non-utf8 inputs on decodeUtf8" $ do + case decodeUnpaddedWith_ @a utf8 "\1079743" of + Left (DecodeError _) -> return () + _ -> assertFailure "decoding phase" + , testCase "decodeUnpaddedWith valid utf8 inputs on decodeUtf8" $ do + case decodeUnpaddedWith_ @a utf8 (encodeNopad @t "\1079743") of + Left (ConversionError _) -> return () + _ -> assertFailure "conversion phase" + , testCase "decodeHexWith valid utf8 inputs on decodeUtf8" $ do + case decodeHexWith_ @a utf8 (encodeHex @t "\1079743") of + Left (ConversionError _) -> return () + _ -> assertFailure "conversion phase" + , testCase "decodeHexPaddedWith non-utf8 inputs on decodeUtf8" $ do + case decodeHexPaddedWith_ @a utf8 "\1079743" of + Left (DecodeError _) -> return () + _ -> assertFailure "decoding phase" + , testCase "decodeHexPaddedWith valid utf8 inputs on decodeUtf8" $ do + case decodeHexPaddedWith_ @a utf8 (encodeHex @t "\1079743") of + Left (ConversionError _) -> return () + _ -> assertFailure "conversion phase" + , testCase "decodeHexUnpaddedWith non-utf8 inputs on decodeUtf8" $ do + case decodeHexUnpaddedWith_ @a utf8 "\1079743" of + Left (DecodeError _) -> return () + _ -> assertFailure "decoding phase" + , testCase "decodeHexUnpaddedWith valid utf8 inputs on decodeUtf8" $ do + case decodeHexUnpaddedWith_ @a utf8 (encodeHexNopad @t "\1079743") of + Left (ConversionError _) -> return () + _ -> assertFailure "conversion phase" + ] + , testGroup "decodeWith positive tests" + [ testCase "decodeWith utf8 inputs on decodeUtf8" $ do + a <- either (assertFailure . show) pure $ decode @a "MZXW6YTBOI======" + b <- either (assertFailure . show) pure $ decodeWith_ @a utf8 "MZXW6YTBOI======" + a @=? b + , testCase "decodePaddedWith utf8 inputs on decodeUtf8" $ do + a <- either (assertFailure . show) pure $ decodePad @a "MZXW6YTBOI======" + b <- either (assertFailure . show) pure $ decodePaddedWith_ @a utf8 "MZXW6YTBOI======" + a @=? b + , testCase "decodeUnpaddedWith utf8 inputs on decodeUtf8" $ do + a <- either (assertFailure . show) pure $ decodeNopad @a "MZXW6YTBOI" + b <- either (assertFailure . show) pure $ decodeUnpaddedWith_ @a utf8 "MZXW6YTBOI" + a @=? b + , testCase "decodeHexWith utf8 inputs on decodeUtf8" $ do + a <- either (assertFailure . show) pure $ decodeHex @a "CPNMUOJ1E8======" + b <- either (assertFailure . show) pure $ decodeHexWith_ @a utf8 "CPNMUOJ1E8======" + a @=? b + , testCase "decodeHexPaddedWith utf8 inputs on decodeUtf8" $ do + a <- either (assertFailure . show) pure $ decodeHexPad @a "CPNMUOJ1E8======" + b <- either (assertFailure . show) pure $ decodeHexPaddedWith_ @a utf8 "CPNMUOJ1E8======" + a @=? b + , testCase "decodeHexUnpaddedWith utf8 inputs on decodeUtf8" $ do + a <- either (assertFailure . show) pure $ decodeHexNopad @a "CPNMUOJ1" + b <- either (assertFailure . show) pure $ decodeHexUnpaddedWith_ @a utf8 "CPNMUOJ1" + a @=? b + ] + ] + +-- | Validity unit tests for the URL workflow +-- +validityTests :: forall a b proxy. Harness a b => proxy a -> TestTree +validityTests _ = testGroup "Validity and correctness unit tests" + [ testGroup "Validity unit tests" + [ testCase "Hex padding tests" $ do + not (validateHex @a "C") @? "C" + validateHex @a "CO" @? "CO" + validateHex @a "CPNG" @? "CPNG" + validateHex @a "CPNMU" @? "CPNMU" + validateHex @a "CPNMUOG" @? "CPNMUOG" + validateHex @a "CPNMUOJ1" @? "CPNMUOJ1" + validateHex @a "CPNMUOJ1E8" @? "CPNMUOJ1E8" + validateHex @a "CO======" @? "CO======" + validateHex @a "CPNG====" @? "CPNG====" + validateHex @a "CPNMU===" @? "CPNMU===" + validateHex @a "CPNMUOG=" @? "CPNMUOG=" + validateHex @a "CPNMUOJ1" @? "CPNMUOJ1" + validateHex @a "CPNMUOJ1E8======" @? "CPNMUOJ1E8======" + , testCase "Std padding tests" $ do + not (validate @a "M") @? "M" + validate @a "MY" @? "MY" + validate @a "MZXQ" @? "MZXQ" + validate @a "MZXW6" @? "MZXW6" + validate @a "MZXW6YQ" @? "MZXW6YQ" + validate @a "MZXW6YTB" @? "MZXW6YTB" + validate @a "MZXW6YTBOI" @? "MZXW6YTBOI" + validate @a "MY======" @? "MY======" + validate @a "MZXQ====" @? "MZXQ====" + validate @a "MZXW6===" @? "MZXW6===" + validate @a "MZXW6YQ=" @? "MZXW6YQ=" + validate @a "MZXW6YTB" @? "MZXW6YTB" + validate @a "MZXW6YTBOI======" @? "MZXW6YTBOI======" + ] + , testGroup "Correctness unit tests" + [ testCase "Hex tests" $ do + not (correctHex @a "C") @? "C" + correctHex @a "CO" @? "CO" + correctHex @a "CPNG" @? "CPNG" + correctHex @a "CPNMU" @? "CPNMU" + correctHex @a "CPNMUOG" @? "CPNMUOG" + correctHex @a "CPNMUOJ1" @? "CPNMUOJ1" + correctHex @a "CPNMUOJ1E8" @? "CPNMUOJ1E8" + correctHex @a "CO======" @? "CO======" + correctHex @a "CPNG====" @? "CPNG====" + correctHex @a "CPNMU===" @? "CPNMU===" + correctHex @a "CPNMUOG=" @? "CPNMUOG=" + correctHex @a "CPNMUOJ1" @? "CPNMUOJ1" + correctHex @a "CPNMUOJ1E8======" @? "CPNMUOJ1E8======" + , testCase "Std tests" $ do + not (correct @a "M") @? "M" + correct @a "MY" @? "MY" + correct @a "MZXQ" @? "MZXQ" + correct @a "MZXW6" @? "MZXW6" + correct @a "MZXW6YQ" @? "MZXW6YQ" + correct @a "MZXW6YTB" @? "MZXW6YTB" + correct @a "MZXW6YTBOI" @? "MZXW6YTBOI" + correct @a "MY======" @? "MY======" + correct @a "MZXQ====" @? "MZXQ====" + correct @a "MZXW6===" @? "MZXW6===" + correct @a "MZXW6YQ=" @? "MZXW6YQ=" + correct @a "MZXW6YTB" @? "MZXW6YTB" + correct @a "MZXW6YTBOI======" @? "MZXW6YTBOI======" + ] + ] + +-- | Offset test vectors. This stresses the invalid char + incorrect padding +-- offset error messages +-- +offsetVectors :: forall a b proxy. Harness a b => proxy a -> TestTree +offsetVectors _ = testGroup "Offset tests" + [ testGroup "Hex - Invalid padding" + [ testCase "Invalid staggered padding" $ do + decodeHex @a "=PNMUOJ1E8======" @?= Left "invalid padding at offset: 0" + decodeHex @a "C=NMUOJ1E8======" @?= Left "invalid padding at offset: 1" + decodeHex @a "CP=MUOJ1E8======" @?= Left "invalid padding at offset: 2" + decodeHex @a "CPN=UOJ1E8======" @?= Left "invalid padding at offset: 3" + decodeHex @a "CPNM=OJ1E8======" @?= Left "invalid padding at offset: 4" + decodeHex @a "CPNMU=J1E8======" @?= Left "invalid padding at offset: 5" + decodeHex @a "CPNMUO=1E8======" @?= Left "invalid padding at offset: 6" + decodeHex @a "CPNMUOJ=E8======" @?= Left "invalid padding at offset: 7" + , testCase "Invalid character coverage" $ do + decodeHex @a "%PNMUOJ1E8======" @?= Left "invalid character at offset: 0" + decodeHex @a "C%NMUOJ1E8======" @?= Left "invalid character at offset: 1" + decodeHex @a "CP%MUOJ1E8======" @?= Left "invalid character at offset: 2" + decodeHex @a "CPN%UOJ1E8======" @?= Left "invalid character at offset: 3" + decodeHex @a "CPNM%OJ1E8======" @?= Left "invalid character at offset: 4" + decodeHex @a "CPNMU%J1E8======" @?= Left "invalid character at offset: 5" + decodeHex @a "CPNMUO%1E8======" @?= Left "invalid character at offset: 6" + decodeHex @a "CPNMUOJ%E8======" @?= Left "invalid character at offset: 7" + ] + , testGroup "Std - Invalid padding" + [ testCase "Invalid staggered padding" $ do + decode @a "=ZXW6YTBOI======" @?= Left "invalid padding at offset: 0" + decode @a "M=XW6YTBOI======" @?= Left "invalid padding at offset: 1" + decode @a "MZ=W6YTBOI======" @?= Left "invalid padding at offset: 2" + decode @a "MZX=6YTBOI======" @?= Left "invalid padding at offset: 3" + decode @a "MZXW=YTBOI======" @?= Left "invalid padding at offset: 4" + decode @a "MZXW6=TBOI======" @?= Left "invalid padding at offset: 5" + decode @a "MZXW6Y=BOI======" @?= Left "invalid padding at offset: 6" + decode @a "MZXW6YT=OI======" @?= Left "invalid padding at offset: 7" + , testCase "Invalid character coverage" $ do + decode @a "%ZXW6YTBOI======" @?= Left "invalid character at offset: 0" + decode @a "M%XW6YTBOI======" @?= Left "invalid character at offset: 1" + decode @a "MZ%W6YTBOI======" @?= Left "invalid character at offset: 2" + decode @a "MZX%6YTBOI======" @?= Left "invalid character at offset: 3" + decode @a "MZXW%YTBOI======" @?= Left "invalid character at offset: 4" + decode @a "MZXW6%TBOI======" @?= Left "invalid character at offset: 5" + decode @a "MZXW6Y%BOI======" @?= Left "invalid character at offset: 6" + decode @a "MZXW6YT%OI======" @?= Left "invalid character at offset: 7" + ] + ]