diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2013, Sam Truzjan + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Sam Truzjan nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,24 @@ +`base32-bytestring` is efficient [base32 and base32hex][rfc] codec for +bytestrings. The API is similar to [base16-bytestring][base16-pkg] and +[base64-bytestring][base64-pkg] packages. + +### Performance + +| function | MB/sec | +|:---------------:|:---------------:| +|encoding | 400 | +|decoding | 400 | +|lenient decoding | N/A | + +### Build Status [![Build Status][travis-img]][travis-log] + +### Maintainer + +You can report any issues at [Issue tracker][issues]. + +[base16-pkg]: http://hackage.haskell.org/package/base16-bytestring +[base64-pkg]: http://hackage.haskell.org/package/base64-bytestring-1.0.0.1 +[rfc]: http://tools.ietf.org/html/rfc4648 +[travis-img]: https://travis-ci.org/cobit/base32-bytestring.png +[travis-log]: https://travis-ci.org/cobit/base32-bytestring +[issues]: https://github.com/cobit/base32-bytestring/issues diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/base32-bytestring.cabal b/base32-bytestring.cabal new file mode 100644 --- /dev/null +++ b/base32-bytestring.cabal @@ -0,0 +1,72 @@ +name: base32-bytestring +version: 0.1.0.0 +license: BSD3 +license-file: LICENSE +author: Sam Truzjan +maintainer: Sam Truzjan +copyright: (c) 2013 Sam Truzjan +category: Codec, Data +build-type: Simple +cabal-version: >= 1.10 +homepage: https://github.com/cobit/base32-bytestring +bug-reports: https://github.com/cobit/base32-bytestring/issues +synopsis: Fast base32 and base32hex codec for ByteStrings +description: + base32 and base32hex codec according to RFC4648 + + . + The package API is similar to base64-bytestring. + . + [/Release notes/] + . + * /0.1.0.0:/ Initial version. + +extra-source-files: README.md + +source-repository head + type: git + location: git://github.com/cobit/base32-bytestring.git + branch: master + +source-repository this + type: git + location: git://github.com/cobit/base32-bytestring.git + branch: master + tag: v0.1.0.0 + +library + default-language: Haskell2010 + default-extensions: + hs-source-dirs: src + exposed-modules: Data.ByteString.Base32 + , Data.ByteString.Base32.Hex + other-modules: Data.ByteString.Base32.Internal + build-depends: base == 4.* + , bytestring >= 0.9 + , cpu == 0.1.* + , bits-extras == 0.1.* + ghc-options: -O2 -Wall + +test-suite spec + default-language: Haskell2010 + default-extensions: OverloadedStrings + type: exitcode-stdio-1.0 + hs-source-dirs: tests + main-is: Spec.hs + build-depends: base == 4.* + , base32-bytestring + , bytestring + , hspec + , QuickCheck + ghc-options: -Wall + +benchmark bench + type: exitcode-stdio-1.0 + default-language: Haskell2010 + hs-source-dirs: bench + main-is: Main.hs + build-depends: base == 4.* + , base32-bytestring + , bytestring + , criterion + ghc-options: -O2 -Wall -fno-warn-orphans diff --git a/bench/Main.hs b/bench/Main.hs new file mode 100644 --- /dev/null +++ b/bench/Main.hs @@ -0,0 +1,39 @@ +module Main (main) where + +import Criterion.Main +import Data.ByteString as BS +import Data.ByteString.Base32 as Base32 +import Data.ByteString.Base32.Hex as Base32Hex + +main :: IO () +main = defaultMain + [ bench "base32/encode/1M" $ nf Base32.encode + $ BS.replicate 1000000 0x8e + , bench "base32/encode/5M" $ nf Base32.encode + $ BS.replicate 5000000 0x8e + + , bench "base32/decode/regular/1M" $ nf Base32.decode + $ BS.replicate 1000000 0x41 + , bench "base32/decode/regular/5M" $ nf Base32.decode + $ BS.replicate 5000000 0x41 + +-- , bench "base32/decode/lenient/1M" $ nf Base32.decodeLenient +-- $ BS.replicate 1000000 0x41 +-- , bench "base32/decode/lenient/5M" $ nf Base32.decodeLenient +-- $ BS.replicate 5000000 0x41 + + , bench "base32hex/encode/1M" $ nf Base32Hex.encode + $ BS.replicate 1000000 0x8e + , bench "base32hex/encode/5M" $ nf Base32Hex.encode + $ BS.replicate 5000000 0x8e + + , bench "base32hex/decode/regular/1M" $ nf Base32Hex.decode + $ BS.replicate 1000000 0x41 + , bench "base32hex/decode/regular/5M" $ nf Base32Hex.decode + $ BS.replicate 5000000 0x41 + +-- , bench "base32hex/decode/lenient/1M" $ nf Base32Hex.decodeLenient +-- $ BS.replicate 1000000 0x41 +-- , bench "base32hex/decode/lenient/5M" $ nf Base32Hex.decodeLenient +-- $ BS.replicate 5000000 0x41 + ] diff --git a/src/Data/ByteString/Base32.hs b/src/Data/ByteString/Base32.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base32.hs @@ -0,0 +1,82 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : stable +-- Portability : portable +-- +-- Efficient encoding and decoding of base32 encoded bytestring +-- according to RFC 4648. +-- +-- This module recommended to be imported as +-- @import Data.ByteString.Base32 as Base32@ to avoid name clashes +-- with @Data.Binary@ or @Data.ByteString.Base64@ modules. +-- +{-# LANGUAGE BangPatterns #-} +module Data.ByteString.Base32 + ( Base32 + , encode + , decode +-- , decodeLenient + ) where + +import Data.ByteString as BS +import Data.ByteString.Internal as BS +import Data.ByteString.Base32.Internal +import Data.List as L + + +-- | Base32 encoded bytestring. +type Base32 = ByteString + +encW5 :: Word5 -> Word8 +encW5 !x + | x <= 25 = 65 + x + | otherwise = 24 + x +{-# INLINE encW5 #-} + +encTable :: EncTable +encTable = BS.pack $ L.map encW5 [0..31] + +-- | Encode a bytestring into base32 form. +encode :: ByteString -> Base32 +encode = unpack5 encTable + +decW5 :: Word8 -> Word5 +decW5 !x + | x < 50 {- c2w '2' -} = invIx + | x <= 55 {- c2w '7' -} = x - 24 {- c2w '2' - 26 -} + | x < 65 {- c2w 'A' -} = invIx + | x <= 90 {- c2w 'Z' -} = x - 65 {- c2w 'A' -} + | x < 97 {- c2w 'a' -} = invIx + | x <= 122 {- c2w 'z' -} = x - 97 {- c2w 'a' -} + | otherwise = invIx +{-# INLINE decW5 #-} + +decTable :: ByteString +decTable = BS.pack $ L.map decW5 [minBound .. maxBound] + +-- | Decode a base32 encoded bytestring. +decode :: Base32 -> ByteString +decode = pack5 decTable + +decCharLenient :: Char -> Word5 +decCharLenient x + | x < '2' = err + | x <= '7' = 26 + fromIntegral (fromEnum x) - fromIntegral (fromEnum '2') + | x < 'A' = err + | x <= 'Z' = fromIntegral (fromEnum x) - fromIntegral (fromEnum 'A') + | x < 'a' = err + | x <= 'z' = fromIntegral (fromEnum x) - fromIntegral (fromEnum 'a') + | otherwise = err + where + err = error "base32: decodeChar: out of range" + +decW5Lenient :: Word8 -> Word5 +decW5Lenient = decCharLenient . w2c +{-# INLINE decW5Lenient #-} + +-- TODO padding leniency +-- | Case-insensitive counterpart of the 'decode'. +decodeLenient :: Base32 -> ByteString +decodeLenient = id -- pack5 nullPtr decW5Lenient diff --git a/src/Data/ByteString/Base32/Hex.hs b/src/Data/ByteString/Base32/Hex.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base32/Hex.hs @@ -0,0 +1,61 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : stable +-- Portability : portable +-- +-- Efficient encoding and decoding of base32hex encoded bytestring +-- according to RFC 4648. +-- +-- This module recommended to be imported as @import +-- Data.ByteString.Base32.Hex as Base32Hex@ to avoid name clashes +-- with @Data.ByteString.Base32@. +-- +{-# LANGUAGE BangPatterns #-} +module Data.ByteString.Base32.Hex + ( Base32Hex + , encode + , decode +-- , decodeLenient + ) where + +import Data.ByteString as BS +import Data.ByteString.Base32.Internal +import Data.List as L + + +-- | Base32Hex encoded bytestring. +type Base32Hex = ByteString + +encW5 :: Word5 -> Word8 +encW5 !x + | x <= 9 = 48 {- c2w '0' -} + x + | otherwise = 55 {- c2w 'A' - 10 -} + x + +encTable :: EncTable +encTable = BS.pack $ L.map encW5 [0..31] + +-- | Encode a bytestring into base32hex form. +encode :: ByteString -> Base32Hex +encode = unpack5 encTable + +decW5 :: Word8 -> Word5 +decW5 !x + | x < 48 {- c2w '0' -} = invIx + | x <= 57 {- c2w '9' -} = x - 48 {- c2w '0' -} + | x < 65 {- c2w 'A' -} = invIx + | x <= 86 {- c2w 'V' -} = x - 55 {- c2w 'A' + 10 -} + | x < 97 {- c2w 'a' -} = invIx + | x <= 118 {- c2w 'v' -} = x - 87 {- c2w 'a' + 10 -} + | otherwise = invIx + +decTable :: DecTable +decTable = BS.pack $ L.map decW5 [minBound .. maxBound] + +-- | Decode a base32hex encoded bytestring. +decode :: Base32Hex -> ByteString +decode = pack5 decTable + +decodeLenient :: Base32Hex -> ByteString +decodeLenient = id diff --git a/src/Data/ByteString/Base32/Internal.hs b/src/Data/ByteString/Base32/Internal.hs new file mode 100644 --- /dev/null +++ b/src/Data/ByteString/Base32/Internal.hs @@ -0,0 +1,230 @@ +-- | +-- Copyright : (c) Sam Truzjan 2013 +-- License : BSD3 +-- Maintainer : pxqr.sta@gmail.com +-- Stability : stable +-- Portability : portable +-- +-- (Word5 <-> Word8) and (Word8 -> Word5) bytestring packers using +-- lookup table. +-- +{-# LANGUAGE BangPatterns #-} +module Data.ByteString.Base32.Internal + ( Word5 + , Word8 + + , EncTable + , unpack5 + + , DecTable + , pack5 + , invIx + ) where + +import Data.Bits.Extras +import Data.ByteString as BS +import Data.ByteString.Internal as BS +import Data.Word +import Foreign hiding (unsafePerformIO) +import System.IO.Unsafe (unsafePerformIO) +import System.Endian + + +{----------------------------------------------------------------------- +-- Utils +-----------------------------------------------------------------------} + +type Word5 = Word8 + +-- System.Endian.toBE32 is slower because toBE32 implemented using +-- cbits shuffle functions while toBE32' implemented used gcc +-- intrinsics +-- +toBE64' :: Word64 -> Word64 +toBE64' = if getSystemEndianness == BigEndian then id else byteSwap +{-# INLINE toBE64' #-} + +toBE32' :: Word32 -> Word32 +toBE32' = if getSystemEndianness == BigEndian then id else byteSwap +{-# INLINE toBE32' #-} + +fromBE32' :: Word32 -> Word32 +fromBE32' = toBE32' +{-# INLINE fromBE32' #-} + +-- n = 2 ^ d +padCeilN :: Int -> Int -> Int +padCeilN !n !x + | remd == 0 = x + | otherwise = (x - remd) + n + where mask = n - 1 + remd = x .&. mask + +{----------------------------------------------------------------------- +-- Encoding +-----------------------------------------------------------------------} + +unpack5Ptr :: Ptr Word8 -> ByteString -> ByteString +unpack5Ptr !tbl bs @ (PS fptr off sz) = + unsafePerformIO $ do + let unpackedSize = dstSize $ BS.length bs + BS.create unpackedSize $ \ dst -> do + withForeignPtr fptr $ \ ptr -> do + dst_end <- bigStep dst (advancePtr ptr off) sz + _ <- fillPadding dst_end (unpackedSize - (dst_end `minusPtr` dst)) + return () + where + dstSize x = padCeilN 8 (d + if m == 0 then 0 else 1) + where (d, m) = (x * 8) `quotRem` 5 + + fillPadding dst s = memset dst (c2w '=') (fromIntegral s) + + bigStep !dst !src !s + | s >= 5 = do + unpack5_40 dst src + bigStep (dst `advancePtr` 8) (src `advancePtr` 5) (s - 5) + | otherwise = smallStep dst src s 0 0 + + unpack5_40 !dst !src = do + w32he <- peek (castPtr src) :: IO Word32 + let w32 = toBE32' w32he + fill8_32 0 (w32 `unsafeShiftR` 27) + fill8_32 1 (w32 `unsafeShiftR` 22) + fill8_32 2 (w32 `unsafeShiftR` 17) + fill8_32 3 (w32 `unsafeShiftR` 12) + fill8_32 4 (w32 `unsafeShiftR` 7) + fill8_32 5 (w32 `unsafeShiftR` 2) + + w8 <- peekElemOff src 4 + fill8_32 6 ( (w32 `unsafeShiftL` 3) + .|. fromIntegral (w8 `unsafeShiftR` 5)) + fill8_32 7 (fromIntegral w8) + where + fill8_32 :: Int -> Word32 -> IO () + fill8_32 !i !w32 = do + w8 <- peekByteOff tbl (fromIntegral w32 .&. 0x1f) + poke (dst `advancePtr` i) w8 + + smallStep !dst !src !s !unused !un_cnt + | un_cnt >= 5 = do + let ix = unused `unsafeShiftR` 3 + peekByteOff tbl (fromIntegral ix) >>= poke dst + smallStep (advancePtr dst 1) + src s + (unused `unsafeShiftL` 5) + (un_cnt - 5) + + | s == 0 = do + if un_cnt == 0 + then return dst + else do + let ix = unused `unsafeShiftR` 3 + peekByteOff tbl (fromIntegral ix) >>= poke dst + return (dst `advancePtr` 1) + + | otherwise = do + w8 <- peek src + let usd_cnt = 5 - un_cnt + let bits = w8 .&. complement (bit (8 - usd_cnt) - 1) + let ix = (unused .|. bits `shiftR` un_cnt) `unsafeShiftR` 3 + peekByteOff tbl (fromIntegral ix) >>= poke dst + smallStep (advancePtr dst 1) + (advancePtr src 1) (pred s) + (w8 `shiftL` usd_cnt) (8 - usd_cnt) + +type EncTable = ByteString + +unpack5 :: EncTable -> ByteString -> ByteString +unpack5 (PS fptr off len) bs + | len /= 32 + = error $ "base32: unpack5: invalid lookup table size " ++ show len + | otherwise = + unsafePerformIO $ do + withForeignPtr fptr $ \ptr -> do + return $ unpack5Ptr (ptr `advancePtr` off) bs + +{----------------------------------------------------------------------- +-- Decoding +-----------------------------------------------------------------------} + +invIx :: Word5 +invIx = 255 + +pack5Ptr :: Ptr Word5 -> ByteString -> ByteString +pack5Ptr !tbl bs @ (PS fptr off sz) = + unsafePerformIO $ do + let packedSize = dstSize $ BS.length bs + BS.createAndTrim packedSize $ \ dst -> do + withForeignPtr fptr $ \ ptr -> do + dst_end <- bigStep dst (advancePtr ptr off) sz + return (dst_end `minusPtr` dst) + where + lookupTable :: Word8 -> Word5 + lookupTable ix + | x == invIx = error $ "base32: decode: invalid character" ++ show ix + | otherwise = x + where x = inlinePerformIO (peekByteOff tbl (fromIntegral ix)) + {-# INLINE lookupTable #-} + + dstSize x = d + if m == 0 then 0 else 1 + where (d, m) = (x * 5) `quotRem` 8 + + bigStep !dst !src !s + | s > 8 = do + pack5_40 dst src + bigStep (dst `advancePtr` 5) (src `advancePtr` 8) (s - 8) + | otherwise = smallStep dst src s (0 :: Word64) 0 + + pack5_40 !dst !src = do + w64he <- peek (castPtr src) :: IO Word64 + let w64 = toBE64' w64he + let w40 = putAsW5 (w64 `unsafeShiftR` 00) $ + putAsW5 (w64 `unsafeShiftR` 08) $ + putAsW5 (w64 `unsafeShiftR` 16) $ + putAsW5 (w64 `unsafeShiftR` 24) $ + putAsW5 (w64 `unsafeShiftR` 32) $ + putAsW5 (w64 `unsafeShiftR` 40) $ + putAsW5 (w64 `unsafeShiftR` 48) $ + putAsW5 (w64 `unsafeShiftR` 56) 0 + pokeW40 w40 + where + putAsW5 :: Word64 -> Word64 -> Word64 + {-# INLINE putAsW5 #-} + putAsW5 !w8 !acc = (acc `unsafeShiftL` 5) + .|. fromIntegral (lookupTable (fromIntegral w8)) + + pokeW40 :: Word64 -> IO () + {-# INLINE pokeW40 #-} + pokeW40 !w40 = do + poke dst (fromIntegral (w40 `unsafeShiftR` 32) :: Word8) + poke (castPtr (dst `advancePtr` 1)) + (fromBE32' (fromIntegral w40 :: Word32)) + + smallStep !dst !src !s !unused !un_cnt + | un_cnt >= 8 = do + poke dst $ fromIntegral (unused `unsafeShiftR` (un_cnt - 8)) + smallStep (dst `advancePtr` 1) src s unused (un_cnt - 8) + + | s == 0 = return dst + | otherwise = do + w8 <- peek src + if w2c w8 == '=' + then if (bit un_cnt - 1) .&. unused == 0 + then smallStep dst src 0 0 0 + else smallStep dst src 0 (unused `shiftL` (8 - un_cnt)) 8 + else smallStep dst + (src `advancePtr` 1) (pred s) + ((unused `unsafeShiftL` 5) + .|. fromIntegral (lookupTable (fromIntegral w8))) + (un_cnt + 5) + +type DecTable = ByteString + +pack5 :: DecTable -> ByteString -> ByteString +pack5 (PS fptr off len) bs + | len /= 256 + = error $ "base32: pack5: invalid lookup table size " ++ show len + | otherwise = + unsafePerformIO $ do + withForeignPtr fptr $ \ptr -> + return $ pack5Ptr (ptr `advancePtr` off) bs diff --git a/tests/Spec.hs b/tests/Spec.hs new file mode 100644 --- /dev/null +++ b/tests/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}