optimal-blocks (empty) → 0.0.1
raw patch · 9 files changed
+643/−0 lines, 9 filesdep +QuickCheckdep +basedep +bytestringsetup-changed
Dependencies added: QuickCheck, base, bytestring, bytestring-arbitrary, criterion, cryptohash, deepseq, hex, optimal-blocks, vector
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- benches/BenchAll.hs +15/−0
- optimal-blocks.cabal +71/−0
- src/Algorithm/OptimalBlocks.hs +120/−0
- src/Algorithm/OptimalBlocks/BuzzHash.hs +102/−0
- src/Algorithm/OptimalBlocks/SipHash.hs +159/−0
- src/Main.hs +130/−0
- tests/TestAll.hs +14/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Jay Groven 2014++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++ * Redistributions of source code must retain the above copyright+ notice, this list of conditions and the following disclaimer.++ * Redistributions in binary form must reproduce the above+ copyright notice, this list of conditions and the following+ disclaimer in the documentation and/or other materials provided+ with the distribution.++ * Neither the name of Jay Groven nor the names of other+ contributors may be used to endorse or promote products derived+ from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ benches/BenchAll.hs view
@@ -0,0 +1,15 @@+module Main+( main+) where++import qualified Buzz+import qualified OptimalBlocks+import qualified Data.ByteString as BS+import System.IO ( withFile, IOMode(ReadMode) )+import Criterion.Main ( defaultMain )++main :: IO ()+main = do+ bytes <- withFile "/dev/urandom" ReadMode $ (flip BS.hGet) (10 * 1024 * 1024)+ defaultMain $ (OptimalBlocks.speed bytes) ++ (Buzz.speed bytes)+
+ optimal-blocks.cabal view
@@ -0,0 +1,71 @@+-- Initial optimal-blocks.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: optimal-blocks+version: 0.0.1+synopsis: Optimal Block boundary determination for rsync-like behaviours+-- description: +homepage: https://github.com/tsuraan/optimal-blocks+license: BSD3+license-file: LICENSE+author: Jay Groven+maintainer: tsuraan@gmail.com+-- copyright: +category: Data+build-type: Simple+-- extra-source-files: +cabal-version: >=1.10++executable chunk+ main-is: Main.hs+ build-depends: base >=4.6 && <4.8+ , bytestring >=0.10 && <0.12+ , cryptohash+ , deepseq+ , hex+ , vector+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -O2 -fllvm -Wall -fprof-auto++library+ exposed-modules: Algorithm.OptimalBlocks+ , Algorithm.OptimalBlocks.SipHash+ , Algorithm.OptimalBlocks.BuzzHash+ -- other-modules: + other-extensions: BangPatterns, CPP, GeneralizedNewtypeDeriving, RecordWildCards+ build-depends: base >=4.6 && <4.8+ , bytestring >=0.10 && <0.12+ , deepseq+ , vector+ hs-source-dirs: src+ default-language: Haskell2010+ ghc-options: -O2 -fllvm -Wall -fprof-auto++benchmark benchmark-all+ type: exitcode-stdio-1.0+ hs-source-dirs: benches+ main-is: BenchAll.hs+ build-depends: base+ , bytestring+ , criterion+ , deepseq+ , optimal-blocks+ , vector+ default-language: Haskell2010+ ghc-options: -O2 -fllvm -Wall -fprof-auto++Test-Suite test-all+ type: exitcode-stdio-1.0+ hs-source-dirs: tests+ main-is: TestAll.hs+ build-depends: base+ , bytestring+ , bytestring-arbitrary+ , deepseq+ , optimal-blocks+ , QuickCheck+ , vector+ default-language: Haskell2010+ ghc-options: -O2 -fllvm -Wall -fprof-auto+
+ src/Algorithm/OptimalBlocks.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE CPP #-}+#ifdef __GLASGOW_HASKELL__+#if __GLASGOW_HASKELL__ < 708+{-# OPTIONS_GHC -fno-spec-constr #-}+#endif+#endif+module Algorithm.OptimalBlocks+( Blocks(..)+, ChunkConfig(..)+, OptimalBlock(..)+, chop+, defaultConfig+, sizedBitmask+) where++import qualified Data.Vector.Unboxed as V+import Data.ByteString ( ByteString, length, splitAt)+import Data.Word ( Word64 )+import Data.Bits ( (.&.), shiftL )+import Control.DeepSeq ( NFData(..) )++import Algorithm.OptimalBlocks.BuzzHash ( hashes )++import Prelude hiding ( length, splitAt )++-- | Alias for 'ByteString', used to indicate that this sequence of bytes ends+-- in an optimal fashion.+newtype OptimalBlock = OptimalBlock+ { fromOptimal :: ByteString+ } deriving ( Eq, Ord, Show )++-- | The result of the 'chop' function, contains the list of optimal blocks+-- that were found, and any remaining bytes that did not end optimally.+data Blocks = Blocks + { blocksOptimal :: [OptimalBlock]+ , blocksRemain :: ByteString+ } deriving ( Show )++-- | Parameters to the chop function. 'windowSize' is how many bytes wide the+-- hashing window is. 'blockSize' is the target size of each generated block.+-- Actual blocks will be larger or smaller, but on average, blocks will be+-- about 'blockSize' on reasonably high-entropy data.+data ChunkConfig = ChunkConfig+ { windowSize :: Int+ , blockSize :: Int+ } deriving ( Show )++{-| This is an alias of 'chop'' that uses a window size of 128 bytes and a+ desired block size of 256KiB.+ -}+defaultConfig :: ChunkConfig+defaultConfig = ChunkConfig 128 $ 256*kb+ where+ kb = 1024++{-| Chop up a 'ByteString' into blocks of data that are likely to occur in+ other 'ByteString's. This uses roughly the same algorithm that rsync does:+ calculate a hash of every 'windowSize'-sized sequence of bytes within the+ given 'ByteString', and then break it up where the hashes match a certain+ pattern. Specifically, this function uses BuzzHash (a rolling hash) to make+ the hash calculations fast, and the pattern it looks for is that the hash's+ binary form ends with the right number of "ones", where "right" is determined+ by the given 'blockSize'. The breaks are inserted after the matching windows+ are found.+ -}+chop :: ChunkConfig -- ^ chopping parameters+ -> ByteString -- ^ ByteString to chop+ -> Blocks+chop cfg bs+ | length bs < winSz = Blocks [] bs+ | otherwise = go+ where+ go =+ let hashed = hashes winSz bs+ locs = V.map (+winSz) $ V.findIndices (\h -> mask == (mask .&. h))+ hashed+ lens = V.zipWith (-) locs (V.cons 0 locs)+ (end, rlist, _) = V.foldl' split (bs, [], 0) lens+ in Blocks (map OptimalBlock $ reverse rlist) end++ mask :: Word64+ mask = sizedBitmask desiredSz++ -- Split is a little bit complicated. The goal here is that split will never+ -- give a chunk of data smaller than winSz. The reason for this is that we're+ -- scanning for winSz-length chunks of data whose hashes meet a pattern; if+ -- data chunks smaller than winSz are returned, they don't have well-defined+ -- winSz-sized hashes, and we don't want that.+ split :: (ByteString, [ByteString], Int)+ -> Int+ -> (ByteString, [ByteString], Int)+ split (b, ls, add) loc+ | add+loc < winSz = (b, ls, add+loc)+ | otherwise =+ let (h, t) = splitAt (add+loc) b+ in (t, h:ls, 0)++ winSz = windowSize cfg+ desiredSz = blockSize cfg++-- | Determine the bitmask that will probably give us blocks of size+-- 'desiredSz'. The idea behind this is that if, for example, we want 1MB+-- blocks, then we need a bitmask that will match one window in (1024*1024).+-- This is equivalent to saying that we want the hash's bottom 20 bits to be+-- set (a 1 in 2**20 occurrance). This function's ugly, and uses logarithms and+-- lots of type conversions, but it's only called once per 'chop'' call, so it+-- doesn't have much impact on performance.+sizedBitmask :: Int -> Word64+sizedBitmask desiredSz =+ let target = toEnum desiredSz :: Float+ bits = fromEnum $ 0.5 + logBase 2 target+ in 1 `shiftL` bits - 1++instance NFData Blocks where+ rnf (Blocks lst b) =+ b `seq` examine lst+ where+ examine [] = ()+ examine (hd:tl) = hd `seq` examine tl+
+ src/Algorithm/OptimalBlocks/BuzzHash.hs view
@@ -0,0 +1,102 @@+{-# LANGUAGE BangPatterns #-}+{- | This is a rolling hash used to calculate the hashes of fixed-length+ sequences of characters within a given ByteString. BuzzHash is nice in that it+ makes this calculation very efficient.+ -}++module Algorithm.OptimalBlocks.BuzzHash+( hashes+, Hash(..)+, init+, roll+, h+) where++import qualified Data.ByteString as BS+import qualified Data.Vector.Unboxed as VU+import Data.Vector.Unboxed ( Vector, generate, (!), empty, constructN, unsafeLast, null )+import Data.ByteString ( ByteString, pack, length )+import Data.ByteString.Unsafe ( unsafeTake, unsafeIndex )+import Data.Word ( Word8, Word64 )+import Data.Bits ( rotateL, xor )++import Algorithm.OptimalBlocks.SipHash ( hashByteString )++import Prelude hiding ( init, length, null, rem )++{-| Determine the hash of every 'len' sequence of bytes in the given+ 'ByteString'. Because this uses BuzzHash, a rolling hash, this runs in @O(n)@+ time dependent on the length of 'bs', and independent of 'len'.++ This will generate @(length bs - len + 1)@ 64-bit hashes.+ -}+hashes :: Int -- ^ How many bytes to put into each hash+ -> ByteString -- ^ The 'ByteString' to calculate hashes of.+ -> Vector Word64+hashes len bs + | length bs < len = empty+ | otherwise = constructN (length bs - len + 1) upd+ where+ upd :: Vector Word64 -> Word64+ upd v+ | null v = currentVal $ init $ unsafeTake len bs+ | otherwise =+ let prevH = {-# SCC hash_last #-} Hash len $ unsafeLast v+ old8 = unsafeIndex bs (VU.length v - 1)+ new8 = unsafeIndex bs (len + VU.length v - 1)+ in {-# SCC current_roll #-} currentVal $ roll prevH old8 new8++{-| A representation of a hash that allows rolling hashes to be easily+ calculated.+ -}+data Hash = Hash { windowLength :: !Int+ , currentVal :: !Word64+ }+ deriving ( Show )++{-| Create a 'Hash' instance using an entire 'ByteString'. This doesn't have+ any sort of length argument to do partial 'ByteString's because 'ByteString'+ supports efficient slices on its own.+ -}+init :: ByteString -> Hash+init bs =+ let hash = BS.foldl upd 0 bs+ in Hash (length bs) hash+ where+ upd :: Word64 -> Word8 -> Word64+ upd hsh w8 = (hsh `rotateL` 1) `xor` (h w8)++{-| Roll the 'Hash' to the next byte over in the 'ByteString' being hashed.+ This doesn't do any sort of checking to ensure that 'old' and 'new' are+ actually correct, so this is probably easy to mess up when using it manually.+ The expected usage is that one would initialize a hash using 'init' on the+ beginning of some 'ByteString', and then to calculate the hash of each+ sequence of bytes one would manually track the first and last byte of each+ window on the 'ByteString'. 'hashes' does this for you...+ -}+roll :: Hash -> Word8 -> Word8 -> Hash+roll hsh old new =+ let rem = {-# SCC roll_rem #-} (h old) `rotateL` (windowLength hsh)+ add = {-# SCC roll_add #-} h new+ skh = {-# SCC roll_skh #-} (currentVal hsh) `rotateL` 1+ in {-# SCC roll_hsh #-} hsh { currentVal = rem `xor` add `xor` skh }+{-# INLINE roll #-}++{-| Upgrade an 8-bit word to a 64-bit one that is very "different" from all+ the other possible 8-bit words. This library uses SipHash to do this.+ -}+h :: Word8 -> Word64+h w = let a = {-# SCC h_a #-} hs+ b = {-# SCC h_fromEnum #-} fromEnum w+ c = {-# SCC h_lookup #-} a ! b+ in c+-- h = (hs !) . fromEnum+{-# INLINE h #-}++hs :: Vector Word64+hs = generate 256 fn+ where+ fn n = hashByteString 2 4 k0 k1 $ pack [toEnum n]+ k0 = 0x4a7330fae70f52e8+ k1 = 0x919ea5953a9a1ec9+{-# NOINLINE hs #-}
+ src/Algorithm/OptimalBlocks/SipHash.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE BangPatterns, CPP, GeneralizedNewtypeDeriving, RecordWildCards #-}+{-# OPTIONS_GHC -fno-warn-name-shadowing #-}+{-- This is Bryan O'Sullivan's SipHash implementation that he wrote for+ - Data.Hashable. I'm directly copying it instead of using hashable because+ - their actual hash implementation could change, and that would cause block+ - boundaries discovered by this module to change, which would defeat the+ - entire purpose of this module.+ -}++module Algorithm.OptimalBlocks.SipHash+ (+ LE64+ , Sip+ , fromWord64+ , fullBlock+ , lastBlock+ , finalize+ , hashByteString+ ) where++#include "MachDeps.h"++import Data.Bits ((.|.), (.&.), rotateL, shiftL, xor)+import Data.Bits (unsafeShiftL)+import Data.Word (Word8, Word64)+import Foreign.ForeignPtr (withForeignPtr)+import Foreign.Ptr (Ptr, castPtr, plusPtr)+import Data.ByteString.Internal (ByteString(PS), inlinePerformIO)+import Foreign.Storable (peek)+import Numeric (showHex)++newtype LE64 = LE64 { fromLE64 :: Word64 }+ deriving (Eq)++instance Show LE64 where+ show (LE64 !v) = let s = showHex v ""+ in "0x" ++ replicate (16 - length s) '0' ++ s++data Sip = Sip {+ v0 :: {-# UNPACK #-} !Word64, v1 :: {-# UNPACK #-} !Word64+ , v2 :: {-# UNPACK #-} !Word64, v3 :: {-# UNPACK #-} !Word64+ }++fromWord64 :: Word64 -> LE64+#ifndef WORDS_BIGENDIAN+fromWord64 = LE64+#else+#error big endian support TBD+#endif++initState :: (Sip -> r) -> Word64 -> Word64 -> r+initState k k0 k1 = k (Sip s0 s1 s2 s3)+ where !s0 = (k0 `xor` 0x736f6d6570736575)+ !s1 = (k1 `xor` 0x646f72616e646f6d)+ !s2 = (k0 `xor` 0x6c7967656e657261)+ !s3 = (k1 `xor` 0x7465646279746573)++sipRound :: (Sip -> r) -> Sip -> r+sipRound k Sip{..} = k (Sip v0_c v1_d v2_c v3_d)+ where v0_a = v0 + v1+ v2_a = v2 + v3+ v1_a = v1 `rotateL` 13+ v3_a = v3 `rotateL` 16+ v1_b = v1_a `xor` v0_a+ v3_b = v3_a `xor` v2_a+ v0_b = v0_a `rotateL` 32+ v2_b = v2_a + v1_b+ v0_c = v0_b + v3_b+ v1_c = v1_b `rotateL` 17+ v3_c = v3_b `rotateL` 21+ v1_d = v1_c `xor` v2_b+ v3_d = v3_c `xor` v0_c+ v2_c = v2_b `rotateL` 32++fullBlock :: Int -> LE64 -> (Sip -> r) -> Sip -> r+fullBlock c m k st@Sip{..}+ | c == 2 = sipRound (sipRound k') st'+ | otherwise = runRounds c k' st'+ where k' st1@Sip{..} = k st1{ v0 = v0 `xor` fromLE64 m }+ st' = st{ v3 = v3 `xor` fromLE64 m }+{-# INLINE fullBlock #-}++runRounds :: Int -> (Sip -> r) -> Sip -> r+runRounds c k = go 0+ where go i st+ | i < c = sipRound (go (i+1)) st+ | otherwise = k st+{-# INLINE runRounds #-}++lastBlock :: Int -> Int -> LE64 -> (Sip -> r) -> Sip -> r+lastBlock !c !len !m k st =+#ifndef WORDS_BIGENDIAN+ fullBlock c (LE64 m') k st+#else+#error big endian support TBD+#endif+ where m' = fromLE64 m .|. ((fromIntegral len .&. 0xff) `shiftL` 56)+{-# INLINE lastBlock #-}++finalize :: Int -> (Word64 -> r) -> Sip -> r+finalize d k st@Sip{..}+ | d == 4 = sipRound (sipRound (sipRound (sipRound k'))) st'+ | otherwise = runRounds d k' st'+ where k' Sip{..} = k $! v0 `xor` v1 `xor` v2 `xor` v3+ st' = st{ v2 = v2 `xor` 0xff }+{-# INLINE finalize #-}++hashByteString :: Int -> Int -> Word64 -> Word64 -> ByteString -> Word64+hashByteString !c !d k0 k1 (PS fp off len) =+ inlinePerformIO . withForeignPtr fp $ \basePtr ->+ let ptr0 = basePtr `plusPtr` off+ scant = len .&. 7+ endBlocks = ptr0 `plusPtr` (len - scant)+ go !ptr st+ | ptr == endBlocks = readLast ptr+ | otherwise = do+ m <- peekLE64 ptr+ fullBlock c m (go (ptr `plusPtr` 8)) st+ where+ zero !m _ _ = lastBlock c len (LE64 m) (finalize d return) st+ one k m p s = do+ w <- fromIntegral `fmap` peekByte p+ k (m .|. (w `unsafeShiftL` s)) (p `plusPtr` 1) (s+8)+ readLast p =+ case scant of+ 0 -> zero 0 p (0::Int)+ 1 -> one zero 0 p 0+ 2 -> one (one zero) 0 p 0+ 3 -> one (one (one zero)) 0 p 0+ 4 -> one (one (one (one zero))) 0 p 0+ 5 -> one (one (one (one (one zero)))) 0 p 0+ 6 -> one (one (one (one (one (one zero))))) 0 p 0+ _ -> one (one (one (one (one (one (one zero)))))) 0 p 0+ in initState (go ptr0) k0 k1++peekByte :: Ptr Word8 -> IO Word8+peekByte = peek++peekLE64 :: Ptr Word8 -> IO LE64+#if defined(x86_64_HOST_ARCH) || defined(i386_HOST_ARCH)+-- platforms on which unaligned loads are legal and usually fast+peekLE64 p = LE64 `fmap` peek (castPtr p)+#else+peekLE64 p = do+ let peek8 d = fromIntegral `fmap` peekByte (p `plusPtr` d)+ b0 <- peek8 0+ b1 <- peek8 1+ b2 <- peek8 2+ b3 <- peek8 3+ b4 <- peek8 4+ b5 <- peek8 5+ b6 <- peek8 6+ b7 <- peek8 7+ let !w = (b7 `shiftL` 56) .|. (b6 `shiftL` 48) .|. (b5 `shiftL` 40) .|.+ (b4 `shiftL` 32) .|. (b3 `shiftL` 24) .|. (b2 `shiftL` 16) .|.+ (b1 `shiftL` 8) .|. b0+ return (fromWord64 w)+#endif+
+ src/Main.hs view
@@ -0,0 +1,130 @@+module Main+where++import qualified Data.ByteString.Char8 as BSC+import qualified Data.ByteString as BS+import Data.ByteString ( ByteString )+import System.Environment ( getArgs )+import System.IO ( Handle, IOMode(..), withFile, hPutStrLn )+import Data.Hex ( hex )+import Crypto.Hash.MD5 ( hash )+import Control.Monad ( forM_ )+import Data.List ( sortBy, transpose )++import Algorithm.OptimalBlocks++data Args = Args+ { argConfig :: ChunkConfig+ , argOutHtml :: Maybe String+ } deriving ( Show )++data FileResult = FR+ { frPath :: String+ , frBlocks :: [(String, Int)]+ , frRemain :: (String, Int)+ }++stdArgs :: Args+stdArgs = Args defaultConfig Nothing++parseArgs :: [String] -> (Args, [String])+parseArgs = go stdArgs []+ where+ go :: Args -> [String] -> [String] -> (Args, [String])+ go args paths [] = (args, reverse paths)+ go args paths [path] = (args, reverse $ path:paths)+ go args paths ("-w":w:rest) =+ -- note to self: learn how to use lenses+ go (args{argConfig=((argConfig args){windowSize=read w})}) paths rest+ go args paths ("-c":c:rest) =+ go (args{argConfig=((argConfig args){blockSize=read c})}) paths rest+ go args paths ("-o":o:rest) =+ go (args{argOutHtml=Just o}) paths rest+ go args paths (path:rest) =+ go args (path:paths) rest++doFiles :: Args -> [String] -> IO [FileResult]+doFiles args [] = do+ bs <- withFile "/dev/urandom" ReadMode (\h -> BS.hGet h (100*1024*1024))+ return [getResult args "/dev/urandom" bs]+doFiles args lst =+ mapM (\p -> getResult args p `fmap` BS.readFile p ) lst++getResult :: Args -> String -> ByteString -> FileResult+getResult args path bs =+ let blocks = chop (argConfig args) bs+ remain = blocksRemain blocks+ blBs = map fromOptimal $ blocksOptimal blocks+ in FR path+ [(BSC.unpack $ hex $ hash b, BS.length b) | b <- blBs]+ (BSC.unpack $ hex $ hash remain, BS.length remain)+ -- let avg = fromRational ( ( toRational $ sum [BS.length b | b <- blBs])+ -- / (toRational $ length blBs ) ) :: Float++ -- forM_ blBs $ \b -> putStrLn (" " ++ (BSC.unpack $ hex $ hash b) ++ " " ++ (show $ BS.length b))++prtText :: Args -> [FileResult] -> IO ()+prtText _ [] = return ()+prtText args (res:rest) = do+ putStrLn $ "Analyzed " ++ frPath res+ putStrLn $ "Generated " ++ show (length $ frBlocks res) ++ " optimal blocks"+ let avg = fromRational ( ( toRational $ sum [len | (_, len) <- frBlocks res])+ / ( toRational $ length $ frBlocks res) ) :: Float+ putStrLn $ "Avg block size is " ++ show avg ++ " (desired was " ++ show (blockSize $ argConfig args) ++ ")"+ forM_ (frBlocks res) $ \(h, l) -> putStrLn (" " ++ h ++ " " ++ show l)+ prtText args rest+++prtHtml :: String -> Args -> [FileResult] -> IO ()+prtHtml output args results = withFile output WriteMode go+ where+ go :: Handle -> IO ()+ go h = do+ let ordered = sortBy (\a b -> compare (length $ frBlocks b)+ (length $ frBlocks a))+ results+ let numCell = length results+ s "<html><body><table>"+ s " <tr>"+ forM_ ordered $ \res ->+ s $ " <th>" ++ frPath res ++ "</th>"+ s " </tr>"+ s " <tr>"+ forM_ ordered $ \res ->+ let avg = if null (frBlocks res)+ then 0+ else fromRational ( ( toRational $ sum [len | (_, len) <- frBlocks res])+ / ( toRational $ length $ frBlocks res) ) :: Float+ in s $ " <td>Avg Len:" ++ show avg ++ "</td>"+ s $ "<td>Expected Avg: " ++ show (blockSize $ argConfig args) ++ "</td>"+ s " </tr>"+ loop numCell $ transpose [frBlocks o | o <- ordered]+ s " <tr>"+ forM_ ordered $ \res -> writeCell (frRemain res)+ s " </tr>"+ s "</table></body></html>"+ where+ loop _ [] = return ()+ loop nc (row:rest) = do+ s " <tr>"+ forM_ row writeCell+ s " </tr>"+ loop nc rest++ writeCell :: (String, Int) -> IO ()+ writeCell (hexHash, len) = do+ let color = "color:#" ++ take 6 hexHash+ s $ " <td> <span style=\"" ++ color ++ "\">" ++ hexHash ++ "</span>"+ s $ "(" ++ show len ++ ")</td>"++ s :: String -> IO ()+ s = hPutStrLn h++main :: IO ()+main = do+ (args, paths) <- parseArgs `fmap` getArgs+ results <- doFiles args paths+ case argOutHtml args of+ Nothing -> prtText args results+ Just output -> prtHtml output args results+
+ tests/TestAll.hs view
@@ -0,0 +1,14 @@+module Main+( main+) where++import qualified Buzz+import qualified OptimalBlocks++main :: IO ()+main = do+ putStrLn "Checking BuzzHash Algorithms"+ Buzz.check+ putStrLn "Checking Optimal Block Algorithms"+ OptimalBlocks.check+