diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,22 @@ +The MIT License (MIT) + +Copyright (c) 2015 Leon Mergen + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. + diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,9 @@ +haskell-base32string +================= + +[![Build Status](https://travis-ci.org/solatis/haskell-base32string.png?branch=master)](https://travis-ci.org/solatis/haskell-base32string) +[![Coverage Status](https://coveralls.io/repos/solatis/haskell-base32string/badge.svg?branch=master)](https://coveralls.io/r/solatis/haskell-base32string?branch=master) +[![MIT](http://b.repl.ca/v1/license-MIT-blue.png)](http://en.wikipedia.org/wiki/MIT_License) +[![Haskell](http://b.repl.ca/v1/language-haskell-lightgrey.png)](http://haskell.org) + +Fast and safe representation of a base-58 string diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,3 @@ +import Distribution.Simple + +main = defaultMain diff --git a/base32string.cabal b/base32string.cabal new file mode 100644 --- /dev/null +++ b/base32string.cabal @@ -0,0 +1,59 @@ +name: base32string +category: Data +version: 0.9.0 +license: MIT +license-file: LICENSE +copyright: (c) 2015 Leon Mergen +author: Leon Mergen +maintainer: leon@solatis.com +homepage: http://www.leonmergen.com/opensource.html +bug-reports: http://github.com/solatis/haskell-base32string/issues +stability: experimental +synopsis: Fast and safe representation of a Base-32 string +description: + Provides an interface for converting any object that has a 'Binary' instance + to and from a base-32 Text representation. + +build-type: Simple +data-files: LICENSE, README.md +cabal-version: >= 1.10 +tested-with: GHC == 7.6, GHC == 7.8, GHC == 7.10 + +library + hs-source-dirs: src + ghc-options: -Wall -ferror-spans + default-language: Haskell2010 + + exposed-modules: Data.Base32String + Data.Base32String.Default + + build-depends: base >= 4.3 && < 5 + , binary + , text + , bytestring + , aeson + +test-suite test-suite + type: exitcode-stdio-1.0 + ghc-options: -Wall -ferror-spans -threaded -auto-all -caf-all -fno-warn-type-defaults + default-language: Haskell2010 + hs-source-dirs: test + main-is: Main.hs + + other-modules: Data.Base32StringSpec + Spec + Main + + build-depends: base >= 4.3 && < 5 + , hspec + , text + + , bytestring + , binary + + , base32string + +source-repository head + type: git + location: git://github.com/solatis/haskell-base32string.git + branch: master diff --git a/src/Data/Base32String.hs b/src/Data/Base32String.hs new file mode 100644 --- /dev/null +++ b/src/Data/Base32String.hs @@ -0,0 +1,151 @@ +module Data.Base32String ( Base32String + , b32String + , fromBinary + , toBinary + , fromBytes + , toBytes + , toText + , fromText ) where + +import Control.Applicative (pure, (<$>)) +import Control.Monad (liftM) + +import Data.Bits (shiftL, shiftR, (.|.)) +import Data.Char (chr, ord) +import Data.List (unfoldr) + +import Data.Maybe (fromJust, fromMaybe, isJust, + listToMaybe) + +import Data.String (fromString) +import Data.Word (Word8) +import Numeric (readInt, showIntAtBase) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 +import qualified Data.ByteString.Lazy as BSL + +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +import qualified Data.Binary as B (Binary, decode, encode) + +-- | Represents a Base32 string. Guarantees that all characters it contains +-- are valid base32 characters. +data Base32String = + Base32String BS.ByteString + deriving ( Show, Eq, Ord ) + +-- | Smart constructor which validates that all the text are actually +-- base-32 characters. +b32String :: BS.ByteString -- ^ Our Base32 mapping table + -> BS.ByteString -- ^ Our Base32 string + -> Base32String +b32String table bs = + if BS.all (isValidBase32 table) bs + then Base32String bs + else error ("Not a valid base32 string: " ++ show bs) + +-- | Converts a 'B.Binary' to a 'Base32String' value +fromBinary :: B.Binary a + => BS.ByteString -- ^ Our Base32 mapping table + -> a -- ^ Input object that is convertable to binary + -> Base32String -- ^ Base32 representation of binary data +fromBinary table = b32String table . b32Encode table . BSL.toStrict . B.encode + +-- | Converts a 'Base32String' to a 'B.Binary' value +toBinary :: B.Binary a + => BS.ByteString -- ^ Base32 mapping table + -> Base32String -- ^ Base32 representation + -> a -- ^ Converted object +toBinary table (Base32String bs) = B.decode . BSL.fromStrict . fromMaybe (error "not a valid base32 input") $ b32Decode table bs + +-- | Reads a 'BS.ByteString' as raw bytes and converts to base32 representation. We +-- cannot use the instance Binary of 'BS.ByteString' because it provides +-- a leading length, which is not what we want when dealing with raw bytes. +fromBytes :: BS.ByteString -- ^ Our Base32 mapping table + -> BS.ByteString -- ^ Raw binary bytes + -> Base32String -- ^ Base32 representation of raw binary bytes +fromBytes table = b32String table . b32Encode table + +-- | Access to the raw bytes in a 'BS.ByteString' format. +toBytes :: BS.ByteString -- ^ Base32 mapping table + -> Base32String -- ^ Base32 string we wish to get binary data from + -> BS.ByteString -- ^ Raw binary representation +toBytes table (Base32String bs) = fromMaybe (error "not a valid base32 input") $ b32Decode table bs + +-- | Access to a 'T.Text' representation of the 'Base32String' +toText :: Base32String -> T.Text +toText (Base32String bs) = TE.decodeUtf8 bs + +-- | Converts a 'T.Text' representation to a 'Base32String' +fromText :: BS.ByteString -- ^ Base32 mapping table + -> T.Text -- ^ Text representation + -> Base32String -- ^ Base32 classified representation +fromText table = b32String table . TE.encodeUtf8 + +isValidBase32 :: BS.ByteString -> Word8 -> Bool +isValidBase32 table c = + c `BS.elem` table + +b32 :: BS.ByteString -> Word8 -> Word8 +b32 table i = BS.index table (fromIntegral i) + +b32' :: BS.ByteString -> Word8 -> Maybe Word8 +b32' table w = fromIntegral <$> BS.elemIndex w table + +b32EncodeInt :: BS.ByteString -- ^ Base32 mapping table + -> Integer + -> BS.ByteString +b32EncodeInt table i = + fromString $ showIntAtBase (32 :: Integer) f (fromIntegral i) "" + where + f = chr . fromIntegral . b32 table . fromIntegral + +b32DecodeInt :: BS.ByteString -- ^ Base32 mapping table + -> BS.ByteString + -> Maybe Integer +b32DecodeInt table s = case go of + Just (r,[]) -> Just r + _ -> Nothing + where + c = b32' table . fromIntegral . ord + p = isJust . c + f = fromIntegral . fromJust . c + go = listToMaybe $ readInt 32 p f (BS8.unpack s) + +b32Encode :: BS.ByteString -- ^ Base32 mapping table + -> BS.ByteString + -> BS.ByteString +b32Encode table input = BS.append l r + where + (z,b) = BS.span (== 0) input + l = BS.map (b32 table) z -- preserve leading 0's + r | BS.null b = BS.empty + | otherwise = b32EncodeInt table $ bsToInteger b + +b32Decode :: BS.ByteString -- ^ Base32 mapping table + -> BS.ByteString + -> Maybe BS.ByteString +b32Decode table input = liftM (BS.append prefix) r + where + (z,b) = BS.span (== b32 table 0) input + prefix = BS.map (fromJust . b32' table) z -- preserve leading 1's + r | BS.null b = Just BS.empty + | otherwise = integerToBS <$> b32DecodeInt table b + +-- | Decode a big endian Integer from a bytestring +bsToInteger :: BS.ByteString -> Integer +bsToInteger = foldr f 0 . reverse . BS.unpack + where + f w n = toInteger w .|. shiftL n 8 + +-- | Encode an Integer to a bytestring as big endian +integerToBS :: Integer -> BS.ByteString +integerToBS 0 = BS.pack [0] +integerToBS i + | i > 0 = BS.pack $ reverse $ unfoldr f i + | otherwise = error "integerToBS not defined for negative values" + where + f 0 = Nothing + f x = Just (fromInteger x :: Word8, x `shiftR` 8) diff --git a/src/Data/Base32String/Default.hs b/src/Data/Base32String/Default.hs new file mode 100644 --- /dev/null +++ b/src/Data/Base32String/Default.hs @@ -0,0 +1,50 @@ +module Data.Base32String.Default ( B32.Base32String + , b32String + , fromBinary + , toBinary + , fromBytes + , toBytes + , fromText + , toText ) where + +import Control.Applicative (pure) +import Data.Aeson +import qualified Data.Binary as B (Binary) +import qualified Data.ByteString as BS +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE + +import qualified Data.Base32String as B32 + +-- | Our mapping table from binary to base32, based on Rfc4648: [A-Z|2-7] +table :: BS.ByteString +table = BS.pack + $ [65..90] + ++ [50..55] + +instance FromJSON B32.Base32String where + parseJSON = withText "Base32tring" $ pure . b32String . TE.encodeUtf8 + +instance ToJSON B32.Base32String where + toJSON = String . toText + +b32String :: BS.ByteString -> B32.Base32String +b32String = B32.b32String table + +fromBinary :: B.Binary a => a -> B32.Base32String +fromBinary = B32.fromBinary table + +toBinary :: B.Binary a => B32.Base32String -> a +toBinary = B32.toBinary table + +fromBytes :: BS.ByteString -> B32.Base32String +fromBytes = B32.fromBytes table + +toBytes :: B32.Base32String -> BS.ByteString +toBytes = B32.toBytes table + +fromText :: T.Text -> B32.Base32String +fromText = B32.fromText table + +toText :: B32.Base32String -> T.Text +toText = B32.toText diff --git a/test/Data/Base32StringSpec.hs b/test/Data/Base32StringSpec.hs new file mode 100644 --- /dev/null +++ b/test/Data/Base32StringSpec.hs @@ -0,0 +1,30 @@ +module Data.Base32StringSpec where + +import Data.Base32String.Default ( b32String + , fromBytes + , toBytes ) + +import qualified Data.ByteString as BS +import qualified Data.ByteString.Char8 as BS8 + +import Test.Hspec + +spec :: Spec +spec = do + describe "when constructing a hex string" $ do + it "should accept strings that fall within a valid range" $ + b32String (BS8.pack "LPB2B3KOSMDI53DG") `shouldBe` b32String (BS8.pack "LPB2B3KOSMDI53DG") + + it "should reject strings outside the range" $ do + putStrLn (show (b32String (BS8.pack "1"))) `shouldThrow` anyErrorCall + putStrLn (show (b32String (BS8.pack "8"))) `shouldThrow` anyErrorCall + putStrLn (show (b32String (BS8.pack "@"))) `shouldThrow` anyErrorCall + putStrLn (show (b32String (BS8.pack "["))) `shouldThrow` anyErrorCall + + describe "when interpreting a hex string" $ do + it "should convert the hex string properly when interpreting as bytes" $ + toBytes (b32String (BS8.pack "AH7")) `shouldBe` BS8.pack "\0\255" + it "should convert bytes to the proper hex string" $ + fromBytes (BS8.pack "\0\255") `shouldBe` b32String (BS8.pack "AH7") + it "should be less bytes than the original" $ + BS.length (toBytes (b32String (BS8.pack "LPB2B3KOSMDI53DG"))) `shouldSatisfy` (<= BS.length (BS8.pack "LPB2B3KOSMDI53DG")) diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,8 @@ +module Main where + +import Test.Hspec.Runner +import qualified Spec + +main :: IO () +main = + hspecWith defaultConfig Spec.spec diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}