src/Lib.hs

   1 {-# LANGUAGE OverloadedStrings #-}
   2 module Lib
   3     ( fileSignatures
   4     , genInstructions
   5     , recreate
   6     ) where
   7
   8 import qualified Data.ByteString.Char8 as BS
   9 import qualified Data.ByteString.Lazy as BL
  10 import Data.Word (Word8)
  11 import qualified Crypto.Hash.SHA1 as SHA1
  12
  13 type Signature = (BS.ByteString, Int)
  14
  15 fileSignatures :: BL.ByteString -> Integer -> [Signature]
  16 fileSignatures bs blockSize = zip (map blockSig (splitBS bs blockSize)) [0..]
  17
  18 splitBS :: BL.ByteString -> Integer -> [BL.ByteString]
  19 splitBS bs blockSize | fromIntegral (BL.length bs) < blockSize = [bs]
  20 splitBS bs blockSize | otherwise =
  21                          (BL.take (fromIntegral blockSize) bs) :
  22                          splitBS (BL.drop (fromIntegral blockSize) bs) blockSize
  23
  24 blockSig :: BL.ByteString -> BS.ByteString
  25 blockSig = SHA1.hash . BL.toStrict
  26
  27 data Instruction = RChar Word8
  28                  | RBlk  Int
  29                  deriving Show
  30
  31 genInstructions :: [Signature] -> Integer -> BL.ByteString -> [Instruction]
  32 genInstructions f0sigs blockSize fnew =
  33   if (fnew == BL.empty)
  34   then []
  35   else
  36     let (blk, blks) = BL.splitAt (fromIntegral blockSize) fnew
  37         sig         = blockSig blk
  38     in
  39       case (lookup sig f0sigs) of
  40         Just (idx) -> RBlk (fromIntegral idx) : genInstructions f0sigs blockSize blks
  41         Nothing    -> RChar (BL.head blk) :
  42           genInstructions f0sigs blockSize (BL.tail (blk `mappend` blks))
  43
  44 recreate :: BL.ByteString -> Integer -> [Instruction] -> BL.ByteString
  45 recreate f0 blockSize ins =
  46   let f0blocks = splitBS f0 blockSize
  47   in
  48     go f0blocks ins
  49   where go f0blocks [] = mempty
  50         go f0blocks (inst:insts) =
  51           case inst of
  52             RBlk i  -> (f0blocks !! i) `mappend` go f0blocks insts
  53             RChar w -> (BL.singleton w) `mappend` go f0blocks insts
  54