adler32 (empty) → 0.1.0.0

raw patch · 5 files changed

+421/−0 lines, 5 filesdep +adler32dep +basedep +bytestringsetup-changed

Dependencies added: adler32, base, bytestring, hspec, zlib

Files

LICENSE +30/−0
Setup.hs +2/−0
adler32.cabal +57/−0
src/Data/Digest/Adler32.hs +232/−0
tests/tests.hs +100/−0

+ LICENSE view

@@ -0,0 +1,30 @@+Copyright (c) 2016, Marios Titas++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 Marios Titas 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

+ adler32.cabal view

@@ -0,0 +1,57 @@+name:                adler32+version:             0.1.0.0+synopsis:            An implementation of Adler-32, supporting rolling checksum operation+description:+  This package provides an implementation of the Adler-32 checksum algorithm.+  In supports a rolling checksum mode, i.e. the checksum of a sliding window+  of the input message can be computed efficiently. It also supports+  compounding, i.e. the checksum of the concatenation of two messages can be+  efficiently computed from the checksums of the two parts.+  .+  By default, the highly optimized implementation of Adler-32 from @zlib@+  will be used. This can be disabled in which case a pure haskell+  implementation will be used instead. The haskell version is 2 to 3 times+  slower on my system.+homepage:            https://github.com/redneb/hs-adler32+bug-reports:         https://github.com/redneb/hs-adler32/issues+license:             BSD3+license-file:        LICENSE+author:              Marios Titas <rednebΑΤgmxDΟΤcom>+maintainer:          Marios Titas <rednebΑΤgmxDΟΤcom>+category:            Cryptography, Hash+build-type:          Simple+cabal-version:       >=1.10++source-repository head+  type: git+  location: https://github.com/redneb/hs-adler32.git++flag zlib+  description:         Bind to @zlib@ and use the implementation of Adler-32 from there+  default:             True++library+  exposed-modules:     Data.Digest.Adler32+  -- other-modules:       +  build-depends:         base >=4.6 && <5+                       , bytestring >=0.10.2+  hs-source-dirs:      src+  default-language:    Haskell2010+  ghc-options:         -Wall+  if flag(zlib)+    cpp-options:       -DUSE_ZLIB+    if !os(windows)+      extra-libraries: z+    else+      build-depends:   zlib++test-suite test+  type:                exitcode-stdio-1.0+  hs-source-dirs:      tests+  main-is:             tests.hs+  build-depends:         base+                       , adler32+                       , hspec >=2+                       , bytestring+  default-language:    Haskell2010+  ghc-options:         -Wall

+ src/Data/Digest/Adler32.hs view

@@ -0,0 +1,232 @@+{- |+Module      : Data.Digest.Adler32++Stability   : provisional+Portability : portable++An implementation of the Adler-32 checksum algorithm. There are two ways+to use this module:++* 'adler32' and 'adler32Update' which use 'Word32' for checksums,+* 'adler32'' which uses the abstract type 'Adler32' for checksums.+Checksums can be computed incrementally by utilizing the @Monoid@+instance of 'Adler32'. This mode is slightly more low-level ('extractAdler32'+has to be used to obtain a 'Word32' for the checksum), but it supports+some additional operations such rolling check and compounding.+-}++{-# LANGUAGE CPP #-}+{-# LANGUAGE BangPatterns #-}++module Data.Digest.Adler32+    ( Adler32Src(..)+    , Adler32+    , extractAdler32+    , makeAdler32+    , adler32SlideL+    , adler32SlideR+    , adler32AppendByte+    , adler32UnAppendByte+    , adler32PrependByte+    , adler32UnPrependByte+    , adler32UnAppend+    , adler32UnPrepend+    ) where++import qualified Data.ByteString as B+import qualified Data.ByteString.Unsafe as B+import qualified Data.ByteString.Lazy as BL+import Data.Word (Word8, Word32)+import Data.Bits (unsafeShiftL, unsafeShiftR, (.|.), (.&.))+import Data.Monoid ((<>))+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (Monoid(..))+#endif++#ifdef USE_ZLIB+import qualified Foreign as F+import qualified Foreign.C as F+import qualified System.IO.Unsafe as U+#endif++-- | Types of messages for which the Adler-32 checksum can be computed.+class Adler32Src a where+    -- | Compute the Adler-32 checksum of a @ByteString@.+    adler32 :: a -> Word32+    adler32 = extractAdler32 . adler32'++    -- | Update the checksum of a message by providing a @ByteString@ to be+    -- appended to the original message.+    adler32Update :: Word32 -> a -> Word32+    -- use a length of 0, since we will extract the checksum eventually+    -- and length of the first part is not used+    adler32Update c s =+        extractAdler32 $ makeAdler32 c (0 :: Word32) <> adler32' s++    -- | Similar to 'adler32' except that an 'Adler32' is returned. If you+    -- want to compute the checksum of a message incrementally, you have+    -- to use this function in conjunction with the @Monoid@ instance of+    -- 'Adler32'.+    adler32' :: a -> Adler32++-- | An abstract representation of an Adler-32 checksum. Forcing a value of+-- this type to whnf will cause it to be evaluated completely.+data Adler32 =+    -- invariant: all 3 paramaters are <base+    Adler32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32 {-# UNPACK #-} !Word32+  deriving (Eq, Ord)++instance Show Adler32 where+    show c@(Adler32 _ _ l) =+        "makeAdler32 " ++ show (extractAdler32 c) ++ " " ++ show l++-- | Extract the actual Adler-32 checksum from a 'Adler32' object.+extractAdler32 :: Adler32 -> Word32+extractAdler32 (Adler32 a b _) = a .|. (b `unsafeShiftL` 16)++-- | @makeAdler32 c l@ will create an 'Adler32' object that corresponds to+-- a message whose checksum is @c@ and length is @l@.+makeAdler32 :: Integral a => Word32 -> a -> Adler32+makeAdler32 c l =+    Adler32 (mod0 $ c .&. 0xffff) (mod0 $ c `unsafeShiftR` 16) (fromIntegral $ l `mod` base)+{-# INLINE makeAdler32 #-}++#ifdef USE_ZLIB+foreign import ccall unsafe "adler32"+    zlib_adler32 :: F.Word32 -> F.Ptr a -> F.CUInt -> F.Word32+#endif++instance Adler32Src B.ByteString where+#ifndef USE_ZLIB+    adler32' s = loop 1 0 0 (min nmax len)+      where+        loop !a !b !i !j+            | i < j = loop a' (b + a') (i + 1) j+            | j < len = loop (mod1 a) (mod1 b) i (min (i + nmax) len)+            | otherwise = Adler32 (mod1 a) (mod1 b) (fromIntegral $ mod1 len)+          where+            a' = a + fromIntegral (B.unsafeIndex s i)+        len = B.length s+        nmax = 5552+#else+    adler32 = adler32Update 1+    {-# INLINE adler32 #-}++    adler32Update c s =+        U.unsafePerformIO $+            B.unsafeUseAsCStringLen s $ \(ptr, len) -> do+                return $ zlib_adler32 c ptr (fromIntegral len)+    {-# NOINLINE adler32Update #-}++    adler32' s = makeAdler32 (adler32 s) (B.length s)+#endif++instance Adler32Src BL.ByteString where+    adler32' = BL.foldlChunks (\c s -> c <> adler32' s) mempty++-- | 'mempty' is the checksum of the empty message and '<>' computes the+-- checksum of the concatenation of two messages. '<>' is an /O(1)/+-- operation.+instance Monoid Adler32 where+    mempty = Adler32 1 0 0+    mappend (Adler32 a1 b1 l1) (Adler32 a2 b2 l2) =+        Adler32 (mod0 $ a1m1 + a2) b (mod0 $ l1 + l2)+      where+        b = mod1 $ b1 + b2 + l2 * a1m1+        a1m1 = if a1 == 0 then base - 1 else a1 - 1++-- | /O(1)/. If @c@ is the checksum of a message that starts with the+-- byte @d1@ then @adler32SlideL d1 c d2@ is the checksum of the message+-- that is obtained by removing the first byte and appending the byte @d2@+-- at the end of the original message. It is the caller's responsibility to+-- ensure that the original message starts with the byte @d1@.+adler32SlideL :: Word8 -> Adler32 -> Word8 -> Adler32+adler32SlideL d1 c d2 =+    d1 `adler32UnPrependByte` (c `adler32AppendByte` d2)+{-# INLINE adler32SlideL #-}++-- | /O(1)/. Similar to 'adler32SlideL' except that it slides the checksum+-- window to the other direction, i.e. in @adler32SlideR d1 c d2@ the byte+-- @d2@ will be removed from the end of the original message and the byte+-- @d1@ will be prepended to its beginning. It is the caller's responsibility+-- to ensure that the original message ends with the byte @d2@.+adler32SlideR :: Word8 -> Adler32 -> Word8 -> Adler32+adler32SlideR d1 c d2 =+    (d1 `adler32PrependByte` c) `adler32UnAppendByte` d2+{-# INLINE adler32SlideR #-}++-- | /O(1)/. Given the checksum of a message, this function returns the+-- checksum of that message with a byte appended to it.+adler32AppendByte :: Adler32 -> Word8 -> Adler32+adler32AppendByte (Adler32 a b l) d =+    Adler32 a' (mod0 $ b + a') (mod0 $ l + 1)+  where+    a' = mod0 $ a + fromIntegral d++-- | /O(1)/. Given the checksum of a message, this function returns the+-- checksum of that message its last byte removed from it. The value of+-- that byte has to be provided by the caller and the behavior of the+-- function is unspecified if that value is incorrect.+adler32UnAppendByte :: Adler32 -> Word8 -> Adler32+adler32UnAppendByte (Adler32 a b l) d =+    Adler32 (modDiff a (fromIntegral d)) (modDiff b a) (modDiff l 1)++-- | /O(1)/. Given the checksum of a message, this function returns the+-- checksum of that message with a byte prepended to it.+adler32PrependByte :: Word8 -> Adler32 -> Adler32+adler32PrependByte d (Adler32 a b l) =+    Adler32 (mod0 $ a + fromIntegral d) (mod1 $ b + l' * fromIntegral d + 1) l'+  where+    l' = mod0 $ l + 1++-- | /O(1)/. Given the checksum of a message, this function returns the+-- checksum of that message its first byte removed from it. The value of+-- that byte has to be provided by the caller and the behavior of the+-- function is unspecified if that value is incorrect.+adler32UnPrependByte :: Word8 -> Adler32 -> Adler32+adler32UnPrependByte d (Adler32 a b l) =+    Adler32 (modDiff a (fromIntegral d)) (modDiff b (mod1 $ l * fromIntegral d + 1)) (modDiff l 1)++-- | /O(1)/. If @s1@ and @s2@ are two messages then @adler32UnAppend c c2@+-- returns the checksum of @s1@ where @c@ is the checksum of @s1 <> s2@ and+-- @c2@ is the checksum of @s2@.+adler32UnAppend :: Adler32 -> Adler32 -> Adler32+adler32UnAppend (Adler32 a b l) (Adler32 a2 b2 l2) =+    Adler32 a1 b1 (modDiff l l2)+  where+    b1 = modDiff b (mod1 $ b2 + l2 * a1m1)+    a1m1 = if a1 == 0 then base - 1 else a1 - 1+    a1 = mod0 $ modDiff a a2 + 1++-- | /O(1)/. If @s1@ and @s2@ are two messages then @adler32UnAppend c1 c@+-- returns the checksum of @s2@ where @c@ is the checksum of @s1 <> s2@ and+-- @c1@ is the checksum of @s1@.+adler32UnPrepend :: Adler32 -> Adler32 -> Adler32+adler32UnPrepend (Adler32 a1 b1 l1) (Adler32 a b l) =+    Adler32 (modDiff a a1m1) b2 l2+  where+    b2 = modDiff b (mod1 $ b1 + l2 * a1m1)+    a1m1 = if a1 == 0 then base - 1 else a1 - 1+    l2 = modDiff l l1++-- expects that 0 <= x < 2 * base+mod0 :: Integral a => a -> a+mod0 x+    | x < base = x+    | otherwise = x - base+{-# INLINE mod0 #-}++mod1 :: Integral a => a -> a+mod1 x = x `rem` base+{-# INLINE mod1 #-}++-- expects that 0 <= x < base, same for y+modDiff :: Integral a => a -> a -> a+modDiff x y+    | x >= y = x - y+    | otherwise = (x + base) - y+{-# INLINE modDiff #-}++base :: Num a => a+base = 65521+{-# INLINE base #-}

+ tests/tests.hs view

@@ -0,0 +1,100 @@+{-# LANGUAGE CPP #-}+{-# LANGUAGE OverloadedStrings #-}++import Test.Hspec+import qualified Data.ByteString as B+import Data.Word (Word32)+import Data.Foldable (forM_)+import Data.Monoid ((<>))+#if !MIN_VERSION_base(4,8,0)+import Data.Monoid (mempty)+#endif++import Data.Digest.Adler32++main :: IO ()+main = hspec $ do+    describe "adler32" $+        forString $ \c s ->+            adler32' s `shouldBe` c++    describe "mempty :: Adler32" $+        it "mempty is the checksum of the empty string" $+            mempty `shouldBe` makeAdler32 1 (0 :: Int)++    describe "<>" $+        forStringPair $ \c1 s1 c2 s2 ->+            (c1 <> c2) `shouldBe` adler32' (s1 <> s2)++    describe "adler32SlideL" $+        forString $ \_ s ->+            forM_ (B.unsnoc s) $ \(s', d2) ->+                forM_ (B.uncons s) $ \(d1, s'') ->+                    adler32SlideL d1 (adler32' s') d2+                        `shouldBe` adler32' s''++    describe "adler32SlideR" $+        forString $ \_ s ->+            forM_ (B.uncons s) $ \(d1, s') ->+                forM_ (B.unsnoc s) $ \(s'', d2) ->+                    adler32SlideR d1 (adler32' s') d2+                        `shouldBe` adler32' s''++    describe "adler32AppendByte" $+        forString $ \c s ->+            forM_ (B.unsnoc s) $ \(s', d) ->+                (adler32' s' `adler32AppendByte` d) `shouldBe` c++    describe "adler32UnAppendByte" $+        forString $ \c s ->+            forM_ (B.unsnoc s) $ \(s', d) ->+                (c `adler32UnAppendByte` d) `shouldBe` adler32' s'++    describe "adler32PrependByte" $+        forString $ \c s ->+            forM_ (B.uncons s) $ \(d, s') ->+                (d `adler32PrependByte` adler32' s') `shouldBe` c++    describe "adler32UnPrependByte" $+        forString $ \c s ->+            forM_ (B.uncons s) $ \(d, s') ->+                (d `adler32UnPrependByte` c) `shouldBe` adler32' s'++    describe "adler32UnAppend" $+        forStringPair $ \c1 s1 c2 s2 ->+            ((adler32' (s1 <> s2)) `adler32UnAppend` c2) `shouldBe` c1++    describe "adler32UnPrepend" $+        forStringPair $ \c1 s1 c2 s2 ->+            (c1 `adler32UnPrepend` (adler32' (s1 <> s2))) `shouldBe` c2++forStringPair+    :: (Adler32 -> B.ByteString -> Adler32 -> B.ByteString -> Expectation)+    -> SpecWith ()+forStringPair action =+    forString $ \c1 s1 ->+        forM_ testStrings $ \(_, (c2, s2)) ->+            action c1 s1 (makeAdler32 c2 (B.length s2)) s2++forString+    :: (Adler32 -> B.ByteString -> Expectation)+    -> SpecWith ()+forString action =+    forM_ testStrings $ \(n, (c, s)) ->+        it ("string " ++ show n) $+            action (makeAdler32 c (B.length s)) s++testStrings :: [(Int, (Word32, B.ByteString))]+testStrings = zip [0..] $+    [ (0x00000001, "")+    , (0x11e60398, "Wikipedia")+    , (0x045d01c1, "test")+    , (0x90860b20, "abcdefghijklmnopqrstuvwxyz")+    , (0x492f072f, "sinless in my crime")+    , (0x0bb80001, B.replicate 3000 0)+    , (0x7732635e, B.replicate 6000 37)+    , (0xe6620ec4, "\223\138p\201\248\NAK\226:\DELt\152)\241_\SYN&\188:\142\169g\192ccfD\214\246(")+    , (0x10591cf2, "?N\ESC\189Z\206a\ETX\139\165y&\173kWPV\235\164\218(\155\240\247KH\165\129\136\SI\218\160]l\176K\230\168\149\161n\135\226\198'\155\253\233\&0d;'\212\153\175`")+    , (0x4c001df4, "\255\246;\224\DLE\169\&3\200J1\155\137\188\171;qI]\GSY\215\202\247\136c\DC4N\185\128\169E\162\181pT\136O\181\GS\169\f\172o\v!\209n\150j>0\204\r\f2^\134\SO(\249$Y\180\"I\167{")+    , (0x45752d45, "Wu\186\CAN\181\174P\227<\210\155\185\202\132\132\221\153\US\193\129\EOT\171\153 zE;\153\ACK\191\227Gc\EMf*\253G\232w\178KV\178\253E\143s\239T-N\185\197\194\211\246!\243\228(\223\NAK\143A\229gh.\155\GS\ETB\149\DC2\SUB\190N-^\140f\NAK\152\SUB\219\STX\138\242\189\161\255")+    ]