module Data.Base32String ( Base32String
, b32String
, 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)
data Base32String =
Base32String BS.ByteString
deriving ( Show, Eq, Ord )
b32String :: BS.ByteString
-> BS.ByteString
-> Base32String
b32String table bs =
if BS.all (isValidBase32 table) bs
then Base32String bs
else error ("Not a valid base32 string: " ++ show bs)
b32String' :: BS.ByteString
-> BS.ByteString
-> Base32String
b32String' table bs =
b32String table (TE.encodeUtf8 . T.toUpper . TE.decodeUtf8 $ bs)
fromBinary :: B.Binary a
=> BS.ByteString
-> a
-> Base32String
fromBinary table = b32String table . b32Encode table . BSL.toStrict . B.encode
toBinary :: B.Binary a
=> BS.ByteString
-> Base32String
-> a
toBinary table (Base32String bs) = B.decode . BSL.fromStrict . fromMaybe (error "not a valid base32 input") $ b32Decode table bs
fromBytes :: BS.ByteString
-> BS.ByteString
-> Base32String
fromBytes table = b32String table . b32Encode table
toBytes :: BS.ByteString
-> Base32String
-> BS.ByteString
toBytes table (Base32String bs) = fromMaybe (error "not a valid base32 input") $ b32Decode table bs
toText :: Base32String -> T.Text
toText (Base32String bs) = TE.decodeUtf8 bs
fromText :: BS.ByteString
-> T.Text
-> Base32String
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
-> Integer
-> BS.ByteString
b32EncodeInt table i =
fromString $ showIntAtBase (32 :: Integer) f (fromIntegral i) ""
where
f = chr . fromIntegral . b32 table . fromIntegral
b32DecodeInt :: BS.ByteString
-> 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
-> BS.ByteString
-> BS.ByteString
b32Encode table input = BS.append l r
where
(z,b) = BS.span (== 0) input
l = BS.map (b32 table) z
r | BS.null b = BS.empty
| otherwise = b32EncodeInt table $ bsToInteger b
b32Decode :: BS.ByteString
-> 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
r | BS.null b = Just BS.empty
| otherwise = integerToBS <$> b32DecodeInt table b
bsToInteger :: BS.ByteString -> Integer
bsToInteger = foldr f 0 . reverse . BS.unpack
where
f w n = toInteger w .|. shiftL n 8
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)