diff options
Diffstat (limited to 'base64/base64.hs')
| -rw-r--r-- | base64/base64.hs | 190 |
1 files changed, 65 insertions, 125 deletions
diff --git a/base64/base64.hs b/base64/base64.hs index cd84c48..91348fb 100644 --- a/base64/base64.hs +++ b/base64/base64.hs @@ -1,127 +1,67 @@ -{-# LANGUAGE BangPatterns #-} -{-# LANGUAGE ViewPatterns #-} -import Data.Maybe (fromJust,isJust) -import Data.List.Split (chunksOf) -import Data.Tuple (swap) -import Data.Tuple.Extra (first,second,dupe) -import System.Environment (getArgs) +import qualified Data.ByteString.Internal as BI import qualified Data.ByteString.Lazy as BL -import qualified Data.ByteString as B -import qualified Data.Map.Strict as M -import Data.Char -import Data.Maybe -import Data.Word -import Data.Array -import Data.Bits ---import Data.ByteString.Base64.Lazy as B64 -import Data.ByteString.Base64 as B64 -import GHC.Int -import Control.Parallel -import Control.Parallel.Strategies - +import qualified Data.ByteString as BS +import Data.Word (Word8, Word32) +import Data.Array.Unboxed(UArray,array) +import Data.Array.Base(unsafeAt) +import Data.Bits(shiftL,shiftR,(.&.)) +import Foreign.Ptr (plusPtr) +import Foreign.Storable (peek, poke) +import Foreign.ForeignPtr (withForeignPtr) +import System.IO.Unsafe (unsafePerformIO) + +-- |Perform base64 encoding of data from standard input main :: IO() -main = BL.getContents >>= mapM_ BL.putStr . parMap rdeepseq (chunkBL 3 (fromNum 6 4.toNum 8)) . chunkB 100000 - -table64 :: Array Int Word8 -table64 = array (0,63) $ zip [0..] $ map (fromIntegral.ord) $ - ['A'..'Z']++['a'..'z']++['0'..'9']++['+','/'] - -toNum :: Int->BL.ByteString->Int -toNum s = BL.foldl' f 0 where f a v = a `shiftL` s + fromIntegral v - -fromNum :: Int->Int->Int->BL.ByteString -fromNum s l x = BL.pack $ map f (reverse [0..l-1]) - where f v = table64 ! (x `shiftR` (v*s) .&. (2^s-1)) - -chunkBL :: Int64->(BL.ByteString->BL.ByteString)->BL.ByteString->BL.ByteString -chunkBL n f b | BL.null b = b - | otherwise = let l = f . BL.take n $ b - r = chunkBL n f . BL.drop n $ b - in BL.append l r - -chunkB :: Int64->BL.ByteString->[BL.ByteString] -chunkB n b | BL.null b = [] - | otherwise = let l = BL.take n $ b - r = chunkB n . BL.drop n $ b - in l:r -{- - let arr=reverse $ BL.foldr f (0,0:[]) b - in arr --BL.unfoldr uf (0,snd arr) - where uf (_,[]) = Nothing - uf (3,x:xs) = Just (table64 ! x,(0,xs)) - uf (c,x:xs) = Just (table64 ! (x.&.63),(c+1,x `shiftR` 6:xs)) - f :: (Int,[Int]) -> Word8 -> (Int,[Int]) - f (_,[]) v = (0,[]) - f (2,x:xs) v = (0,0:(x `shiftL` 8) + fromIntegral v:xs) - f (c,x:xs) v = (c+1,(x `shiftL` 8) + fromIntegral v:xs) - - -- BL.unfoldr uf . (,)3 . snd . BL.foldl' f (0,0:[]) - -- -} -{- --} - - ---main = B.getContents >>= B.putStr . B64.encode --- Example Usage: echo "hello world" | ./base64 | ./base64 -d - --- TODO --- cleanup/simplify --- unit testing (cross check with cli base64, different lengths) --- flag for line widht / check flags / filename on command-line --- (see man base64) --- compare performance . named map? array? - --- arg<-getArgs -{- -enc64 x = B.reverse $ B.unfoldr unf $ (4, (B.foldl' (\a b->a `shiftL` 8 + fromIntegral b) (0::Int) x)) -unf (c,v) = if c==0 then Nothing else let r = v .&. 63 in Just (table64 ! r,(c-1,v`shiftR` 6)) - if length arg == 0 - then putStr . (++"\n") . encode64 . map fromIntegral . B.unpack $ dat - else B.putStr. B.pack . map fromIntegral . decode64 . C.unpack $ dat --} - ---t1 = BL.getContents >>= BL.putStr . BL.fromChunks . map (B.map f) . BL.toChunks - - - ---enc=B.map (\x->table64 ! (x `shiftR` 4)) - - - --- -- reChunkIn :: Int -> [B.ByteString] -> [B.ByteString] --- -- reChunkIn !n = go --- -- where --- -- go [] = [] --- -- go (y : ys) = case B.length y `divMod` n of --- -- (_, 0) -> y : go ys --- -- (d, _) -> case B.splitAt (d * n) y of --- -- (prefix, suffix) -> prefix : fixup suffix ys --- -- fixup acc [] = [acc] --- -- fixup acc (z : zs) = case B.splitAt (n - B.length acc) z of --- -- (prefix, suffix) -> --- -- let acc' = acc `B.append` prefix --- -- in if B.length acc' == n --- -- then let zs' = if B.null suffix --- -- then zs --- -- else suffix : zs --- -- in acc' : go zs' --- -- else -- suffix must be null --- -- fixup acc' zs --- ---dec64 k = M.lookup k mp where mp = M.fromList $ map swap table64 - -{- -encode64 :: [Int] -> [Char] -encode64 = map (fromJust.enc64.flip mod 64) -- concat . map (pad . first enc . second length . dupe) . chunksOf 3 - where enc = map (fromJust . enc64) . sumC - sumC = map fst . reverse . take 4 . drop 1 .iterate to64 . (,) 0 . sum . map (uncurry (*)) . zip mult - mult = map (256^) [2,1,0] - to64 (r,v) = let r' = v `mod` 64 in (r',(v-r')`div`64) - pad (v,l) =take 4 $ take (1+l) v ++ "===" - -decode64 :: [Char]->[Int] -decode64 = map fst . concat . map (rem . first (reverse . take 3 . drop 1 . iterate to256 . (,) 0 . dec. map (fromJust) . filter (isJust) . map dec64).second (length.filter(=='=')). dupe) . chunksOf 4 . filter (/='\n') - where dec = sum . map (uncurry (*)) . zip (map (64^) [3,2..]) - to256 (r,v) = let r' = v `mod` 256 in (r',(v-r')`div`256) - rem (v,l) = take (3-l) v --} +main = BL.getContents>>=BL.putStr.BL.fromChunks.map encode64.reChunk.BL.toChunks + +-- |Base64 index table +tab64 :: UArray Word32 Word8 +tab64 = array (0,63) $ zip [0..] $ map (BI.c2w) $ + ['A'..'Z']++['a'..'z']++['0'..'9']++['+','/'] + +-- |Encodes 3 octets into 4 sextets +enc64 :: (Word8,Word8,Word8)->(Word8,Word8,Word8,Word8) +enc64 (b1,b2,b3) = (t 3,t 2,t 1,t 0) + where t x = tab64 `unsafeAt` (n `shiftR` (x*6) .&. 63) + f b n = fromIntegral b `shiftL` n + n = f b1 16 + f b2 8 + f b3 0 + +-- |Transforms list of ByteStrings to a new list of ByteStrings with +-- lengths guaranteed to be multiples of 3 (excepting the last one) +-- Assumes that all input ByteStrings (excepting the last one) have +-- at least a length of 3. +reChunk :: [BS.ByteString] -> [BS.ByteString] +reChunk (y:[]) = [y] +reChunk (y:z:zs) = let c = BS.length y `mod` 3 + in BS.append y (BS.take 3 z):(reChunk $ (BS.drop 3 z):zs) + +-- |Wraps Base64 enode in encode64io in unsafePerformIO to use in +-- pure code, Use this only if you trust my 'encode64io' code is free +-- of side effects and indepedent of the environment. Good Luck! +encode64 :: BS.ByteString -> BS.ByteString +encode64 = unsafePerformIO . encode64io + +-- |Base64 encode a strict ByteString using foreign pointers within the +-- IO monad. +encode64io :: BS.ByteString -> IO BS.ByteString +encode64io (BI.PS ptr offs len) = do + bs <- BI.mallocByteString ln + withForeignPtr ptr $ \fp -> do + withForeignPtr bs $ \fbs -> do + let end = fp `plusPtr` (len+offs) + in go (fp`plusPtr`offs) fbs end bs + where ln=((len + 2) `div` 3) * 4 + go fp fbs end bs + | fp >= end = return $ BI.fromForeignPtr bs 0 ln + | fp `plusPtr`1 == end = cnv 1 + | fp `plusPtr`2 == end = cnv 2 + | otherwise = cnv 3 + where pok nn n v = if n>1 && nn<n + then poke (fbs`plusPtr`n) (61::Word8) + else poke (fbs`plusPtr`n) v + pek nn n = if nn<n then return 0 else peek (fp`plusPtr`n) + cnv :: Int -> IO BS.ByteString + cnv n = pek n 0>>= \b1->pek n 1>>= \b2->pek n 2>>= \b3-> + let (e1,e2,e3,e4) = enc64(b1,b2,b3) in + pok n 0 e1>>pok n 1 e2>>pok n 2 e3>>pok n 3 e4 >> + go (fp `plusPtr` 3) (fbs`plusPtr`4) end bs |