|
| 1 | +{-# LANGUAGE BangPatterns, OverloadedStrings #-} |
| 2 | + |
| 3 | +module Data.ByteString.Base64 |
| 4 | + ( |
| 5 | + encode |
| 6 | + , decode |
| 7 | + ) where |
| 8 | + |
| 9 | +import Data.Bits ((.|.), (.&.), shiftL, shiftR) |
| 10 | +import Data.ByteString.Char8 (ByteString, pack) |
| 11 | +import Data.ByteString.Internal |
| 12 | +import Data.ByteString.Unsafe |
| 13 | +import Data.Word (Word8, Word16, Word32) |
| 14 | +import Foreign.ForeignPtr (ForeignPtr, mallocForeignPtrArray, withForeignPtr) |
| 15 | +import Foreign.Ptr (Ptr, castPtr, plusPtr) |
| 16 | +import Foreign.Storable (peek, peekElemOff, poke, pokeElemOff) |
| 17 | +import System.IO.Unsafe (unsafePerformIO) |
| 18 | + |
| 19 | +peek8 :: Ptr Word8 -> IO Word8 |
| 20 | +peek8 = peek |
| 21 | + |
| 22 | +encode :: ByteString -> ByteString |
| 23 | +encode (PS sary soff slen) = unsafePerformIO $ do |
| 24 | + let dlen = (((slen + 2) `div` 3) * 4) |
| 25 | + dary <- mallocByteString dlen |
| 26 | + withForeignPtr encTable $ \ep -> |
| 27 | + withForeignPtr sary $ \sptr -> |
| 28 | + withForeignPtr dary $ \dptr -> do |
| 29 | + let pp p = (fromIntegral `fmap` peek8 p) :: IO Word32 |
| 30 | + sEnd = sptr `plusPtr` slen |
| 31 | + fill !dp !sp |
| 32 | + | sp `plusPtr` 2 >= sEnd = complete (castPtr dp) sp |
| 33 | + | otherwise = do |
| 34 | + i <- pp sp |
| 35 | + j <- pp (sp `plusPtr` 1) |
| 36 | + k <- pp (sp `plusPtr` 2) |
| 37 | + let w = (i `shiftL` 16) .|. (j `shiftL` 8) .|. k |
| 38 | + enc = peekElemOff ep . fromIntegral |
| 39 | + poke dp =<< enc (w `shiftR` 12) |
| 40 | + poke (dp `plusPtr` 2) =<< enc (w .&. 0xfff) |
| 41 | + fill (dp `plusPtr` 4) (sp `plusPtr` 3) |
| 42 | + complete dp sp |
| 43 | + | sp == sEnd = return () |
| 44 | + | otherwise = do |
| 45 | + let peekSP n f = (f . fromIntegral) `fmap` peek8 (sp `plusPtr` n) |
| 46 | + twoMore = sp `plusPtr` 2 == sEnd |
| 47 | + equals = 0x3d :: Word8 |
| 48 | + a <- peekSP 0 ((`shiftR` 2) . (.&. 0xfc)) |
| 49 | + b <- peekSP 0 ((`shiftL` 4) . (.&. 0x03)) |
| 50 | + b' <- if twoMore |
| 51 | + then peekSP 1 ((.|. b) . (`shiftR` 4) . (.&. 0xf0)) |
| 52 | + else return b |
| 53 | + poke dp (unsafeIndex alphabet a) |
| 54 | + poke (dp `plusPtr` 1) (unsafeIndex alphabet b') |
| 55 | + c <- if twoMore |
| 56 | + then peekSP 1 ((`shiftL` 2) . (.&. 0x0f)) |
| 57 | + else return equals |
| 58 | + poke (dp `plusPtr` 2) c |
| 59 | + poke (dp `plusPtr` 3) equals |
| 60 | + fill (castPtr dptr) (sptr `plusPtr` soff) |
| 61 | + return $! PS dary 0 dlen |
| 62 | + |
| 63 | +decode :: ByteString -> ByteString |
| 64 | +decode = undefined |
| 65 | + |
| 66 | +alphabet :: ByteString |
| 67 | +alphabet = "ABCDEFGHIJKLMNOPQRSTUVWXYZabcdefghijklmnopqrstuvwxyz0123456789+/" |
| 68 | +{-# NOINLINE alphabet #-} |
| 69 | + |
| 70 | +encTable :: ForeignPtr Word16 |
| 71 | +encTable = unsafePerformIO $ do |
| 72 | + fp <- mallocForeignPtrArray 4096 |
| 73 | + let ix = fromIntegral . unsafeIndex alphabet |
| 74 | + withForeignPtr fp $ \p -> |
| 75 | + sequence_ [ pokeElemOff p (j*64+k) ((ix k `shiftL` 8) .|. ix j) |
| 76 | + | j <- [0..64], k <- [0..64] ] |
| 77 | + return fp |
| 78 | +{-# NOINLINE encTable #-} |
0 commit comments