Initial commit

13 files changed, 463 insertions, 0 deletions

diff --git a/.gitignore b/.gitignore
new file mode 100644
index 0000000..316009b
--- /dev/null
+++ b/.gitignore
@@ -0,0 +1,2 @@
+dist
+cabal-dev
diff --git a/.travis.yml b/.travis.yml
new file mode 100644
index 0000000..fd78ba7
--- /dev/null
+++ b/.travis.yml
@@ -0,0 +1,11 @@
+language: haskell
+
+notifications:
+  email:
+    - pxqr.sta@gmail.com
+
+install:
+  cabal install --enable-tests --enable-benchmark --only-dependencies
+
+script:
+  cabal configure --enable-tests --enable-benchmark && cabal build && cabal test
\ No newline at end of file
diff --git a/LICENSE b/LICENSE
new file mode 100644
index 0000000..4c30139
--- /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
index 0000000..83da005
--- /dev/null
+++ b/README.md
@@ -0,0 +1,22 @@
+`base32-bytestring` is efficient [base32][rfc] codec for bytestrings.
+The API is similar to [base64-bytestring][base64-pkg] package.
+
+### Performance
+
+| function        |      MB/sec     |
+|:---------------:|:---------------:|
+|encoding         | 400             |
+|decoding         | 400             |
+|lenient decoding | N/A             |
+
+### Build Status [![Build Status][travis-img]][travis-log]
+
+### Maintainer <pxqr.sta@gmail.com>
+
+You can report any issues at [Issue tracker][issues].
+
+[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
index 0000000..9a994af
--- /dev/null
+++ b/Setup.hs
@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain
diff --git a/TODO.org b/TODO.org
new file mode 100644
index 0000000..7b127bd
--- /dev/null
+++ b/TODO.org
@@ -0,0 +1 @@
+* TODO lazy bytestrings
diff --git a/base32-bytestring.cabal b/base32-bytestring.cabal
new file mode 100644
index 0000000..ccba67e
--- /dev/null
+++ b/base32-bytestring.cabal
@@ -0,0 +1,61 @@
+name:                base32-bytestring
+version:             0.0.0.0
+license:             BSD3
+license-file:        LICENSE
+author:              Sam Truzjan
+maintainer:          Sam Truzjan <pxqr.sta@gmail.com>
+copyright:           (c) 2013 Sam Truzjan
+category:            Codec, Data
+build-type:          Simple
+cabal-version:       >= 1.10
+synopsis: Fast base32 encoding and decoding for ByteStrings
+description:
+  Base32 encoding according to RFC4648
+  <http://tools.ietf.org/html/rfc4648>
+  This package have API similar to base64-bytestring.
+
+source-repository head
+  type:                git
+  location:            git://github.com/cobit/base32.git
+  branch:              master
+
+source-repository this
+  type:                git
+  location:            git://github.com/cobit/base32.git
+  branch:              master
+  tag:                 v0.0.0.0
+
+library
+  default-language:    Haskell2010
+  default-extensions:
+  hs-source-dirs:      src
+  exposed-modules:     Data.ByteString.Base32
+  build-depends:       base       == 4.6.*
+                     , bytestring == 0.10.*
+                     , cpu
+                     , bits-extras
+  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  >= 1.7
+                     , 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
index 0000000..5309cd9
--- /dev/null
+++ b/bench/Main.hs
@@ -0,0 +1,18 @@
+module Main (main) where
+
+import Criterion.Main
+import Data.ByteString as BS
+import Data.ByteString.Base32 as Base32
+
+
+main :: IO ()
+main = defaultMain
+  [ bench "encode/1M" $ nf encode $ BS.replicate 1000000 0x8e
+  , bench "encode/5M" $ nf encode $ BS.replicate 5000000 0x8e
+
+  , bench "decode/regular/1M" $ nf decode $ BS.replicate 1000000 0x41
+  , bench "decode/regular/5M" $ nf decode $ BS.replicate 5000000 0x41
+
+  , bench "decode/lenient/1M" $ nf decodeLenient $ BS.replicate 1000000 0x41
+  , bench "decode/lenient/5M" $ nf decodeLenient $ BS.replicate 5000000 0x41
+  ]
\ No newline at end of file
diff --git a/src/Data/ByteString/Base32.hi b/src/Data/ByteString/Base32.hi
new file mode 100644
index 0000000..ce22b69
--- /dev/null
+++ b/src/Data/ByteString/Base32.hi
diff --git a/src/Data/ByteString/Base32.hs b/src/Data/ByteString/Base32.hs
new file mode 100644
index 0000000..96bb893
--- /dev/null
+++ b/src/Data/ByteString/Base32.hs
@@ -0,0 +1,269 @@
+-- |
+--   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. <http://tools.ietf.org/html/rfc4648>
+--
+--   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
+       ( encode
+       , decode
+       , decodeLenient
+       ) 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
+-----------------------------------------------------------------------}
+
+type EncTable = Ptr Word8
+
+unpack5 :: EncTable -> ByteString -> ByteString
+unpack5 !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)
+
+encW5 :: Word5 -> Word8
+encW5 !x
+  |  x <= 25  = 65 + x
+  | otherwise = 24 + x
+{-# INLINE encW5 #-}
+
+encTable :: ForeignPtr Word8
+PS encTable _ _ = BS.pack $ fmap encW5 [0..31]
+
+-- | Encode a bytestring into base32 form.
+encode :: ByteString -> ByteString
+encode bs =
+  unsafePerformIO $ do
+    withForeignPtr encTable $ \ptr -> do
+      return $ unpack5 ptr bs
+
+{-----------------------------------------------------------------------
+-- Decoding
+-----------------------------------------------------------------------}
+
+type DecTable = Ptr Word5
+
+pack5 :: DecTable -> (Word8 -> Word5) -> ByteString -> ByteString
+pack5 !tbl !f 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 (f w8))
+                  (un_cnt + 5)
+
+invIx :: Word5
+invIx = 255
+
+decW5 :: Word8 -> Word5
+decW5 !x
+  | x <  50 {- c2w '2' -} = invIx
+  | x <= 55 {- c2w '7' -} = x - 24
+  | x <  65 {- c2w 'A' -} = invIx
+  | x <= 90 {- c2w 'Z' -} = x - 65
+  |       otherwise       = invIx
+{-# INLINE decW5 #-}
+
+decTable :: ForeignPtr Word8
+PS decTable _ _ = BS.pack $ fmap decW5 [minBound .. maxBound]
+
+-- | Decode a base32 encoded bytestring.
+decode :: ByteString -> ByteString
+decode bs =
+  unsafePerformIO $ do
+    withForeignPtr decTable $ \tbl ->
+      return $ pack5 tbl decW5 bs
+
+{-----------------------------------------------------------------------
+-- Lenient Decoding
+-----------------------------------------------------------------------}
+
+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 :: ByteString -> ByteString
+decodeLenient = id -- pack5 nullPtr decW5Lenient
\ No newline at end of file
diff --git a/src/Data/ByteString/Base32.o b/src/Data/ByteString/Base32.o
new file mode 100644
index 0000000..eadc3fe
--- /dev/null
+++ b/src/Data/ByteString/Base32.o
diff --git a/tests/Data/ByteString/Base32Spec.hs b/tests/Data/ByteString/Base32Spec.hs
new file mode 100644
index 0000000..3c646e2
--- /dev/null
+++ b/tests/Data/ByteString/Base32Spec.hs
@@ -0,0 +1,46 @@
+{-# OPTIONS -fno-warn-orphans #-}
+module Data.ByteString.Base32Spec (spec) where
+
+import Control.Applicative
+import Data.ByteString as BS
+import Data.ByteString.Internal as BS
+import Data.ByteString.Base32 as Base32
+import Test.Hspec
+import Test.QuickCheck
+
+
+instance Arbitrary ByteString where
+  arbitrary = BS.pack <$> arbitrary
+
+spec :: Spec
+spec = do
+  describe "encode" $ do
+    it "conform RFC examples" $ do
+      encode ""       `shouldBe` ""
+      encode "f"      `shouldBe` "MY======"
+      encode "fo"     `shouldBe` "MZXQ===="
+      encode "foo"    `shouldBe` "MZXW6==="
+      encode "foob"   `shouldBe` "MZXW6YQ="
+      encode "fooba"  `shouldBe` "MZXW6YTB"
+      encode "foobar" `shouldBe` "MZXW6YTBOI======"
+
+    it "size always multiple of 8 bytes" $ property $ \bs ->
+      (BS.length (encode bs) `rem` 8) `shouldBe` 0
+
+    it "padding less than" $ property $ \bs ->
+      count (c2w '=') bs `shouldSatisfy` (< 8)
+
+  describe "decode" $ do
+    it "conform RFC examples" $ do
+      decode ""                 `shouldBe` ""
+      decode "MY======"         `shouldBe` "f"
+      decode "MZXQ===="         `shouldBe` "fo"
+      decode  "MZXW6==="        `shouldBe` "foo"
+      decode "MZXW6YQ="         `shouldBe` "foob"
+      decode "MZXW6YTB"         `shouldBe` "fooba"
+      decode "MZXW6YTBOI======" `shouldBe` "foobar"
+
+    it "inverse for encode" $ property $ \bs ->
+      decode (encode bs) == bs
+
+--  describe "decodeLenient" $ do
diff --git a/tests/Spec.hs b/tests/Spec.hs
new file mode 100644
index 0000000..52ef578
--- /dev/null
+++ b/tests/Spec.hs
@@ -0,0 +1 @@
+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
\ No newline at end of file