diff --git a/Format/BinaryStore.hs b/Format/BinaryStore.hs new file mode 100644 --- /dev/null +++ b/Format/BinaryStore.hs @@ -0,0 +1,471 @@ + +{-# LANGUAGE DeriveGeneric #-} + +-- | A /Binary Store/ is a data format that stores a sequence of values +-- encoded using the binary transform. Therefore, it use is restricted +-- to binary lists, i.e. lists whose length is a power of two. +-- +-- To create a binary store from a binary list use 'createBinaryStore'. +-- This will create a 'BinaryStore' value that you can convert to a +-- lazy 'ByteString' with 'encode'. To revert the process, use 'decode' +-- and then 'readBinaryStore'. The whole process of decoding, from 'ByteString' +-- to the final 'Decoded' value is done /lazily/. This allows the user to +-- decode only a portion of the data without reading the full 'ByteString'. +-- This is useful when reading big files or when the 'ByteString' is obtained +-- via network connection. +-- +module Format.BinaryStore ( + -- * Binary Store Type + BinaryStore + -- * Encoding/Decoding + , encode, decode + -- * Creating and reading + , createBinaryStore + , createBinaryStoreDefault + , readBinaryStore + -- * Class of storable values + , BinaryStoreValue + -- * TValues + , TValue + , fromTValue + -- * Information + -- | Some functions to get information about a binary store. + , Mode (..) + , bsMode + , bsNumerator + , bsDenominator + , averageConstant + , bsDirection + , bsCompression + , bsBZip + , bsLength + , bsData + ) where + +import Control.Applicative (Applicative (..),Alternative (..), (<$>)) +import Control.Monad (when) +import Control.Arrow ((***)) + +-- Binary lists +import Data.BinaryList (BinList) +import qualified Data.BinaryList as BL +import Data.BinaryList.Serialize (Direction (..),Decoded) +import qualified Data.BinaryList.Serialize as BLS + +-- Bytestrings +import Data.ByteString.Lazy (ByteString) +import qualified Data.ByteString.Lazy as B +import qualified Data.ByteString as SB + +-- Binary +import Data.Word (Word8) +import Data.Binary (Binary (..)) +import Data.Binary.Put ( Put,runPut,putWord8,putWord64le + , putByteString,putLazyByteString ) +import Data.Binary.Get (Get,runGetOrFail,getWord8,getWord64le) +import GHC.Generics (Generic) + +-- Casting from/to Double +import Data.ReinterpretCast (doubleToWord,wordToDouble) + +-- Binary Transform +import Data.BinaryList.Algorithm.BinaryTransform + +-- BZip compression +import qualified Codec.Compression.BZip as BZ + +-- Deep evaluation +import Control.DeepSeq (NFData (..),deepseq) + +-- Utils + +-- | A custom error message for parsing errors in this module. +failGet :: String -> Get a +failGet str = fail $ "binary-store: " ++ str + +---------- +-- TValues + +data Pos = L | R deriving (Eq,Show,Generic) + +instance NFData Pos + +instance Binary Pos + +-- | A /t-value/ is either empty or filled. +-- Use 'pure' and 'empty' to build t-values. +data TValue a = Hole | Full [Pos] a deriving (Eq,Show,Generic) + +-- | Extract a value from a 'TValue', if it contains any. +fromTValue :: TValue a -> Maybe a +fromTValue (Full _ x) = Just x +fromTValue _ = Nothing + +instance NFData a => NFData (TValue a) where + rnf (Full ps x) = ps `deepseq` x `deepseq` () + rnf _ = () + +instance Binary a => Binary (TValue a) + +instance Functor TValue where + {-# INLINE fmap #-} + fmap _ Hole = Hole + fmap f (Full ps x) = Full ps (f x) + +instance Applicative TValue where + {-# INLINE pure #-} + pure = Full [] + {-# INLINE (<*>) #-} + Full ps f <*> Full ps' x = Full (ps ++ ps') (f x) + _ <*> _ = Hole + +instance Alternative TValue where + {-# INLINE empty #-} + empty = Hole + {-# INLINE (<|>) #-} + tv@(Full _ _) <|> _ = tv + _ <|> tv = tv + +{- Applicative law proofs for TValue + +* Identity + +pure id <*> v + = Full [] id <*> v + = case v of + Hole -> Hole = v ## + Full ps x = Full ([] ++ ps) (id x) = v ## + +* Composition + +pure (.) <*> u <*> v <*> w + = Full [] (.) <*> u <*> v <*> w + = (Full [] (.) <*> u) <*> v <*> w + = case u of + Hole -> Hole <*> v <*> w = Hole = u <*> (v <*> w) ## + Full ps f -> Full ([] ++ ps) (f .) <*> v <*> w + = Full ps (f .) <*> v <*> w + = case v of + Hole -> Hole = u <*> (v <*> w) ## + Full ps' g -> Full (ps ++ ps') (f . g) <*> w + = case w of + Hole -> Hole = u <*> (v <*> w) ## + Full ps'' x = Full (ps ++ ps' ++ ps'') (f (g x)) + = Full (ps ++ (ps' ++ ps'')) (f (g x)) + = Full ps f <*> Full (ps' ++ ps'') (g x) + = u <*> (v <*> w) ## + +* Homomorphism + +pure f <*> pure x + = Full [] f <*> Full [] x + = Full ([] ++ []) (f x) + = Full [] (f x) + = pure (f x) ## + +* Interchange + +u <*> pure y + = u <*> Full [] y + = case u of + Hole -> Hole = pure ($ y) <*> u ## + Full ps f -> Full (ps ++ []) (f y) + = Full ps (f y) + = Full ([] ++ ps) (($ y) f) + = Full [] ($ y) <*> Full ps f + = pure ($ y) <*> u ## + +-} + +putPosList :: [Pos] -> Put +putPosList (x:xs) = do + case x of + L -> putWord8 0 + R -> putWord8 1 + putPosList xs +putPosList [] = putWord8 2 + +getPosList :: Get [Pos] +getPosList = do + w <- getWord8 + case w of + 0 -> (L:) <$> getPosList + 1 -> (R:) <$> getPosList + 2 -> return [] + _ -> failGet $ "unexpected pos (" ++ show w ++ ")" + +-------- + +-- | Binary Store Mode. The Binary Store Mode indicates what +-- kind of data a binary store contains. +-- +-- * 'Plain': Each value is a 'Double'. +-- +-- * 'WithHoles': Each value is a 'Maybe' 'Double'. +-- +-- * 'WithHoles2': Eavh is a 'TValue' 'Double'. +-- +data Mode = Plain | WithHoles | WithHoles2 + +-- | Serialization of modes. +putMode :: Mode -> Put +putMode Plain = putWord8 0 +putMode WithHoles = putWord8 1 +putMode WithHoles2 = putWord8 2 + +-- | Deserialization of modes. +getMode :: Get Mode +getMode = do + w <- getWord8 + case w of + 0 -> return Plain + 1 -> return WithHoles + 2 -> return WithHoles2 + _ -> failGet $ "unrecognized mode (" ++ show w ++ ")" + +-- | Serialization of directions. +putDirection :: Direction -> Put +putDirection FromLeft = putWord8 0 +putDirection FromRight = putWord8 1 + +-- | Deserialization of directions. +getDirection :: Get Direction +getDirection = do + w <- getWord8 + case w of + 0 -> return FromLeft + 1 -> return FromRight + _ -> failGet $ "invalid direction (" ++ show w ++ ")" + +-- | Binary Store is a format to store data encoded using +-- the Average Binary Transform. +data BinaryStore = BinaryStore { + bsMode :: Mode -- ^ Binary Store mode. + , bsNumerator :: Word8 -- ^ Numerator of the Average Constant. + , bsDenominator :: Word8 -- ^ Denominator of the Average Constant. + , bsDirection :: Direction -- ^ Direction of encoding. + , bsCompression :: Bool -- ^ Whether zero compression is used or not. + , bsBZip :: Bool -- ^ Wheter bzip compression is used or not. + , bsLength :: Word8 -- ^ Length index of the data. + , bsData :: ByteString -- ^ Data (which might be compressed). + } + +-- | The constant used by the Average Binary Transform. +averageConstant :: BinaryStore -> Double +averageConstant bs = fromIntegral (bsNumerator bs) / fromIntegral (bsDenominator bs) + +-- | Encode a binary store as a lazy 'ByteString'. +encode :: BinaryStore -> ByteString +encode bs = runPut $ do + putMode $ bsMode bs + putWord8 $ bsNumerator bs + putWord8 $ bsDenominator bs + putDirection $ bsDirection bs + put $ bsCompression bs -- False encodes as 0. True encodes as 1. + put $ bsBZip bs + putWord8 $ bsLength bs + putLazyByteString $ bsData bs + +-- | Decode a lazy 'ByteString' as a binary store. The header of the +-- binary store is read strictly, while the body evaluation is delayed. +-- It returns a 'String' if the header is malformed. The 'String' contains +-- an error description. +decode :: ByteString -> Either String BinaryStore +decode bs = case runGetOrFail getHeader bs of + Left (_,off,err) -> Left $ err ++ ", after " ++ show off ++ " bytes" + Right (b,_,(m,n,d,dr,c,bz,l)) -> Right $ BinaryStore m n d dr c bz l b + +-- | Binary Store Header parser. +getHeader :: Get (Mode,Word8,Word8,Direction,Bool,Bool,Word8) +getHeader = do + m <- getMode + n <- getWord8 + d <- getWord8 + when (d == 0) $ failGet "denominator is zero" + when (d < n) $ failGet "denominator is smaller than numerator" + dr <- getDirection + c <- get + bz <- get + l <- getWord8 + return (m,n,d,dr,c,bz,l) + +{- Compression algorithm + +A simple compression algorithm for bytestrings. If desired, data can be +compressed further using any common algorithm. This algorithm emphasizes +the compression of blocks formed exclusively by zeroes. This is how it +works: + +Any sequence of zero bytes is replaced by two bytes. The first byte is +zero. The second byte is the length of the sequence of zeroes. Note that +a byte can only contain a number from 0 to 255. Therefore, the maximum +compression we can get is 255 bytes to 2 bytes. Also note that if a zero +byte is alone, then the compression will be 1 byte to 2 bytes. + +-} + +-- | Stream zero compression. +putCompressed :: ByteString -> Put +putCompressed = go 0 . B.unpack + where + go z (w:ws) = + case w of + 0 -> case z of + 255 -> do putWord8 0 + putWord8 255 + go 1 ws + _ -> go (z+1) ws + _ -> case z of + 0 -> do putWord8 w + go z ws + _ -> do putWord8 0 + putWord8 z + putWord8 w + go 0 ws + go z [] = + case z of + 0 -> return () + _ -> do putWord8 0 + putWord8 z + +-- | Zero compression of lazy 'ByteString'. +compress :: ByteString -> ByteString +compress = runPut . putCompressed + +-- | Zero decompression of lazy 'ByteString'. +decompress :: ByteString -> ByteString +decompress = runPut . go False . B.unpack + where + go b (w:ws) = + if b then do putByteString $ SB.replicate (fromIntegral w) 0 + go False ws + else case w of + 0 -> go True ws + _ -> do putWord8 w + go False ws + go _ _ = return () + +---------------------------------- +-- Conversion from/to binary lists + +-- | This is the class of values that can be stored in a 'BinaryStore'. +-- This is a closed class, so the user is not allowed to add new instances. +class BinaryStoreValue a where + putValue :: a -> Put + getValue :: Get a + modeValue :: a -> Mode + averageBijection :: Double -> Bijection (a,a) (a,a) + +instance BinaryStoreValue Double where + putValue = putWord64le . doubleToWord + getValue = wordToDouble <$> getWord64le + modeValue _ = Plain + averageBijection p = Bijection f f' + where + q = 1 - p + d = p ^ (2 :: Int) + q ^ (2 :: Int) + f (x,y) = ( q*x + p*y , q*y - p*x ) + f' (x,y) = ( (q*x - p*y)/d , (q*y + p*x)/d ) + +instance BinaryStoreValue a => BinaryStoreValue (Maybe a) where + putValue (Just x) = putWord8 1 >> putValue x + putValue Nothing = putWord8 0 + getValue = do + b <- getWord8 + case b of + 0 -> return Nothing + 1 -> Just <$> getValue + _ -> fail "getValue (Maybe): invalid encoding" + modeValue _ = WithHoles + averageBijection p = Bijection f f' + where + b = averageBijection p + f (Just x, Just y) = Just *** Just $ direct b (x,y) + f v = v + f' (Just x, Just y) = Just *** Just $ inverse b (x,y) + f' v = v + +instance BinaryStoreValue a => BinaryStoreValue (TValue a) where + putValue Hole = putWord8 0 + putValue (Full ps x) = putWord8 1 >> putPosList ps >> putValue x + getValue = do + b <- getWord8 + case b of + 0 -> return Hole + 1 -> Full <$> getPosList <*> getValue + _ -> fail "getValue (TValue): invalid encoding" + modeValue _ = WithHoles2 + averageBijection p = Bijection f f' + where + b = averageBijection p + f (Hole,Hole) = (Hole,Hole) + f (Hole,Full ps x) = (Full (R:ps) x, Hole) + f (Full ps x, Hole) = (Full (L:ps) x, Hole) + f (Full ps x, Full ps' y) = + Full ps *** Full ps' $ direct b (x,y) + + f' (Hole,Hole) = (Hole,Hole) + f' (Full ps x, Hole) = + case ps of + L : t -> (Full t x, Hole) + R : t -> (Hole, Full t x) + _ -> error "Full: empty list" + f' (Full ps x, Full ps' y) = + Full ps *** Full ps' $ inverse b (x,y) + f' (Hole, Full _ _) = error "f inverse: right full" + +{-# INLINE fromRight #-} + +-- | Deconstructor of 'Right'. Throws an error when given a 'Left' value. +fromRight :: Either a b -> b +fromRight e = + case e of + Right x -> x + _ -> error "fromRight: Left value" + +{-# INLINE createBinaryStoreDefault #-} + +-- | Create a binary store from a binary list, using 'createBinaryStore' with default arguments. +-- In spite of seeming partial (since 'createBinaryStore' returns an 'Either' value), this +-- function is total. +createBinaryStoreDefault :: BinaryStoreValue a => BinList a -> BinaryStore +createBinaryStoreDefault = fromRight . createBinaryStore FromLeft 1 2 True True + +-- | Create a binary store from a binary list, using some configurations. +-- The denominator of the average constant must be greater or equal to +-- its numerator and, of course, different from zero. +createBinaryStore :: BinaryStoreValue a + => Direction -- ^ Direction of encoding + -> Word8 -- ^ Average constant numerator + -> Word8 -- ^ Average constant denominator + -> Bool -- ^ Whether to use zero compression or not + -> Bool -- ^ Whether to use bzip compression or not + -> BinList a -- ^ Input list + -> Either String BinaryStore +createBinaryStore dr n d c bz xs = + if d == 0 + then Left "denominator is zero" + else if d < n + then Left "denominator is smaller than numerator" + else Right $ BinaryStore (modeValue $ BL.head xs) n d dr c bz (BL.lengthExponent xs) $ + let p = fromIntegral n / fromIntegral d + trans = (if dr == FromLeft + then leftBinaryTransform + else rightBinaryTransform) $ averageBijection p + comp = if c then compress else id + comp2 = if bz then BZ.compress else id + in comp2 . comp $ BLS.encData $ BLS.encodeBinList putValue dr $ direct trans xs + +-- | Read a binary store and build a 'Decoded' value. The 'Decoded' value is a list of partial results of +-- increasing size (1, 2, 4, 8, etc) that ends in either a decoding error or a final result. These partial +-- results are generated lazily from the binary store data. +readBinaryStore :: BinaryStoreValue a => BinaryStore -> Decoded a +readBinaryStore bs = + let decomp = if bsCompression bs then decompress else id + decomp2 = if bsBZip bs then BZ.decompress else id + encd = BLS.EncodedBinList (bsDirection bs) (bsLength bs) $ decomp . decomp2 $ bsData bs + p = averageConstant bs + detrans = (if bsDirection bs == FromLeft + then leftInverseBinaryTransformDec + else rightInverseBinaryTransformDec) $ averageBijection p + in detrans $ BLS.decData $ BLS.decodeBinList getValue encd diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2014, Daniel Díaz + +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 Daniel Díaz 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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/binary-store.cabal b/binary-store.cabal new file mode 100644 --- /dev/null +++ b/binary-store.cabal @@ -0,0 +1,38 @@ +name: binary-store +version: 0.1.0.1 +synopsis: Format to store data using the binary transform. +description: ... +license: BSD3 +license-file: LICENSE +author: Daniel Díaz +maintainer: daniel.casanueva@plowtech.net +category: Data +build-type: Simple +cabal-version: >=1.10 + +library + exposed-modules: Format.BinaryStore + build-depends: base == 4.* + , binary-list >= 1.0.0.0 + , bytestring >= 0.10 + , binary >= 0.7 + , reinterpret-cast + , binary-transform + -- requires libbz2-dev + , bzlib + , deepseq + default-language: Haskell2010 + ghc-options: -O2 -Wall + +test-suite binary-store-tests + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + build-depends: base == 4.* + , tasty + , tasty-quickcheck + , QuickCheck + , binary-list + , binary-store + ghc-options: -Wall -fno-warn-orphans diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,89 @@ + +import Data.BinaryList (BinList,Exponent) +import qualified Data.BinaryList as BL +import Data.BinaryList.Serialize (Direction (..), fromDecoded) +import Format.BinaryStore + +import Test.Tasty +import qualified Test.Tasty.QuickCheck as QC +import Test.QuickCheck + +import Control.Applicative (pure,empty,(<$>)) +import qualified Data.Foldable as F + +instance Arbitrary a => Arbitrary (BinList a) where + arbitrary = do + l <- choose (0,12 :: Exponent) + BL.replicateA l arbitrary + +instance Arbitrary Direction where + arbitrary = elements [FromLeft,FromRight] + +instance Arbitrary a => Arbitrary (TValue a) where + arbitrary = oneof [pure empty, pure <$> arbitrary] + +-- Approximately equal class + +class Approx a where + (~=) :: a -> a -> Bool + +instance Approx Double where + x ~= y = abs (x - y) <= 0.00001 + +instance Approx a => Approx (BinList a) where + xs ~= ys = F.and $ BL.zipWith (~=) xs ys + +instance Approx a => Approx (Either e a) where + Right x ~= Right y = x ~= y + Left _ ~= Left _ = True + _ ~= _ = False + +instance Approx a => Approx (Maybe a) where + Just x ~= Just y = x ~= y + Nothing ~= Nothing = True + _ ~= _ = False + +instance Approx a => Approx (TValue a) where + tv ~= tv' = fromTValue tv ~= fromTValue tv' + +-- + +main :: IO () +main = defaultMain $ testGroup "binary-store" + [ testGroup "Double" + [ QC.testProperty "read/create" + $ \xs dr c bz -> forAll (choose (1,255)) + $ \d -> forAll (choose (0,d)) + $ \n -> ( createBinaryStore dr n d c bz xs >>= fromDecoded . readBinaryStore ) + ~= Right (xs :: BinList Double) + , QC.testProperty "read/decode/encode/create" + $ \xs dr c bz -> forAll (choose (1,255)) + $ \d -> forAll (choose (0,d)) + $ \n -> ( createBinaryStore dr n d c bz xs >>= decode . encode >>= fromDecoded . readBinaryStore ) + ~= Right (xs :: BinList Double) + ] + , testGroup "Maybe Double" + [ QC.testProperty "read/create" + $ \xs dr c bz -> forAll (choose (1,255)) + $ \d -> forAll (choose (0,d)) + $ \n -> ( createBinaryStore dr n d c bz xs >>= fromDecoded . readBinaryStore ) + ~= Right (xs :: BinList (Maybe Double)) + , QC.testProperty "read/decode/encode/create" + $ \xs dr c bz -> forAll (choose (1,255)) + $ \d -> forAll (choose (0,d)) + $ \n -> ( createBinaryStore dr n d c bz xs >>= decode . encode >>= fromDecoded . readBinaryStore ) + ~= Right (xs :: BinList (Maybe Double)) + ] + , testGroup "TValue Double" + [ QC.testProperty "read/create" + $ \xs dr c bz -> forAll (choose (1,255)) + $ \d -> forAll (choose (0,d)) + $ \n -> ( createBinaryStore dr n d c bz xs >>= fromDecoded . readBinaryStore ) + ~= Right (xs :: BinList (TValue Double)) + , QC.testProperty "read/decode/encode/create" + $ \xs dr c bz -> forAll (choose (1,255)) + $ \d -> forAll (choose (0,d)) + $ \n -> ( createBinaryStore dr n d c bz xs >>= decode . encode >>= fromDecoded . readBinaryStore ) + ~= Right (xs :: BinList (TValue Double)) + ] + ]