gearhash (empty) → 1.0.0
raw patch · 8 files changed
+461/−0 lines, 8 filesdep +arraydep +basedep +bv-little
Dependencies added: array, base, bv-little, bytestring, conduit, cryptonite, gearhash, mtl, template-haskell, th-lift-instances
Files
- LICENSE +29/−0
- gearhash.cabal +153/−0
- gearhash/Conduit.hs +17/−0
- gearhash/Count.hs +15/−0
- gearhash/Direct.hs +28/−0
- src/Data/Digest/GearHash.hs +52/−0
- src/Data/Digest/GearHash/Conduit.hs +64/−0
- src/Data/Digest/GearHash/Types.hs +103/−0
+ LICENSE view
@@ -0,0 +1,29 @@+BSD 3-Clause License++Copyright (c) 2020, Gregor Kleen+All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++1. Redistributions of source code must retain the above copyright notice, this+ list of conditions and the following disclaimer.++2. 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.++3. Neither the name of the copyright holder nor the names of its+ 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 HOLDER 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.
+ gearhash.cabal view
@@ -0,0 +1,153 @@+cabal-version: 1.12++-- This file has been generated from package.yaml by hpack version 0.34.7.+--+-- see: https://github.com/sol/hpack++name: gearhash+version: 1.0.0+synopsis: An implementation of Gear hash, a fast rolling hash algorithm+homepage: https://github.com/gkleen/fastcdc#readme+bug-reports: https://github.com/gkleen/fastcdc/issues+author: Gregor Kleen+maintainer: aethoago@141.li+copyright: 2022 Gregor Kleen+license: BSD3+license-file: LICENSE+build-type: Simple++source-repository head+ type: git+ location: https://github.com/gkleen/fastcdc+ subdir: gearhash++flag pedantic+ manual: True+ default: False++library+ exposed-modules:+ Data.Digest.GearHash+ Data.Digest.GearHash.Conduit+ other-modules:+ Data.Digest.GearHash.Types+ Paths_gearhash+ hs-source-dirs:+ src+ default-extensions:+ NoImplicitPrelude+ other-extensions:+ DeriveGeneric+ DeriveDataTypeable+ RecordWildCards+ TemplateHaskell+ TupleSections+ ExplicitForAll+ TypeFamilies+ BangPatterns+ ghc-options: -Wall+ build-depends:+ array >=0.5.4 && <0.6+ , base >=4.7 && <5+ , bv-little >=1.1 && <2+ , bytestring >=0.10 && <0.12+ , conduit ==1.3.*+ , cryptonite >=0.24 && <0.30+ , mtl >=2.2 && <3+ , template-haskell ==2.16.*+ , th-lift-instances >=0.1.16 && <0.2+ if flag(pedantic)+ ghc-options: -Werror+ default-language: Haskell2010++executable count+ main-is: Count.hs+ hs-source-dirs:+ gearhash+ default-extensions:+ NoImplicitPrelude+ other-extensions:+ DeriveGeneric+ DeriveDataTypeable+ RecordWildCards+ TemplateHaskell+ TupleSections+ ExplicitForAll+ TypeFamilies+ BangPatterns+ ghc-options: -Wall+ build-depends:+ array >=0.5.4 && <0.6+ , base >=4.7 && <5+ , bv-little >=1.1 && <2+ , bytestring >=0.10 && <0.12+ , conduit ==1.3.*+ , cryptonite >=0.24 && <0.30+ , mtl >=2.2 && <3+ , template-haskell ==2.16.*+ , th-lift-instances >=0.1.16 && <0.2+ if flag(pedantic)+ ghc-options: -Werror+ default-language: Haskell2010++executable gearhash+ main-is: Direct.hs+ hs-source-dirs:+ gearhash+ default-extensions:+ NoImplicitPrelude+ other-extensions:+ DeriveGeneric+ DeriveDataTypeable+ RecordWildCards+ TemplateHaskell+ TupleSections+ ExplicitForAll+ TypeFamilies+ BangPatterns+ ghc-options: -Wall+ build-depends:+ array >=0.5.4 && <0.6+ , base >=4.7 && <5+ , bv-little >=1.1 && <2+ , bytestring >=0.10 && <0.12+ , conduit ==1.3.*+ , cryptonite >=0.24 && <0.30+ , gearhash+ , mtl >=2.2 && <3+ , template-haskell ==2.16.*+ , th-lift-instances >=0.1.16 && <0.2+ if flag(pedantic)+ ghc-options: -Werror+ default-language: Haskell2010++executable gearhash-conduit+ main-is: Conduit.hs+ hs-source-dirs:+ gearhash+ default-extensions:+ NoImplicitPrelude+ other-extensions:+ DeriveGeneric+ DeriveDataTypeable+ RecordWildCards+ TemplateHaskell+ TupleSections+ ExplicitForAll+ TypeFamilies+ BangPatterns+ ghc-options: -Wall+ build-depends:+ array >=0.5.4 && <0.6+ , base >=4.7 && <5+ , bv-little >=1.1 && <2+ , bytestring >=0.10 && <0.12+ , conduit ==1.3.*+ , cryptonite >=0.24 && <0.30+ , gearhash+ , mtl >=2.2 && <3+ , template-haskell ==2.16.*+ , th-lift-instances >=0.1.16 && <0.2+ if flag(pedantic)+ ghc-options: -Werror+ default-language: Haskell2010
+ gearhash/Conduit.hs view
@@ -0,0 +1,17 @@+module Main+ ( main+ ) where++import Prelude+import Data.Digest.GearHash.Conduit+import Data.Conduit+import qualified Data.Conduit.Combinators as C+import qualified Data.ByteString.Builder as BS.Builder++import System.IO (stdout)++import qualified Data.BitVector.LittleEndian as BitVector+ ++main :: IO ()+main = runConduit $ C.stdin .| rollingHash' (BS.Builder.word64BE . BitVector.toUnsignedNumber) .| C.sinkHandleBuilder stdout
+ gearhash/Count.hs view
@@ -0,0 +1,15 @@+module Main+ ( main+ ) where++import Prelude++import Data.Conduit+import qualified Data.Conduit.Combinators as C+import qualified Data.ByteString.Builder as BS.Builder++import System.IO (stdout)+++main :: IO ()+main = runConduit $ C.enumFromTo minBound maxBound .| C.map BS.Builder.word32LE .| C.sinkHandleBuilder stdout
+ gearhash/Direct.hs view
@@ -0,0 +1,28 @@+module Main+ ( main+ ) where++import Prelude+import qualified Data.ByteString as ByteString+import qualified Data.ByteString.Builder as BS.Builder++import Data.Digest.GearHash+import System.IO (stdin, stdout)+import Control.Monad (unless)+ +import qualified Data.BitVector.LittleEndian as BitVector+ ++main :: IO ()+main = go hashInit+ where+ go hState = do+ inpBS <- ByteString.hGetSome stdin 128+ unless (ByteString.null inpBS) $ do+ let (hState', acc) = ByteString.foldl' go' (hState, mempty) inpBS+ BS.Builder.hPutBuilder stdout acc+ go hState'++ go' (hState, acc) w = out `seq` (hState', acc <> BS.Builder.word64BE out)+ where hState' = hashUpdate w hState+ out = BitVector.toUnsignedNumber $ hashFinalize hState'
+ src/Data/Digest/GearHash.hs view
@@ -0,0 +1,52 @@+{-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE BangPatterns #-}++module Data.Digest.GearHash+ ( GearHashTable+ , mkGearHashTable, gearHashTableHashLength+ , GearHashState+ , hashInit, hashInitWith, defaultGearHashTable, defaultGearHashTableFor+ , hashUpdate+ , BitVector+ , hashFinalize+ ) where++import Prelude+import Data.Array.IArray ((!))+import Data.Word+import Data.Bits (Bits(shiftL))++import Data.Digest.GearHash.Types++import Language.Haskell.TH.Syntax (Lift(liftTyped))++import Data.BitVector.LittleEndian (BitVector)+import qualified Data.BitVector.LittleEndian as BitVector+import Data.Maybe++import Numeric.Natural (Natural)+++{-# INLINE hashInitWith #-}+hashInitWith :: GearHashTable -> GearHashState+hashInitWith gearHashTable = GearHashState { gearHashCurrent = BitVector.fromNumber (fromIntegral $ unsafeGearHashTableHashLength gearHashTable) (0 :: Integer), .. }++{-# INLINE hashUpdate #-}+hashUpdate :: Word8 -> GearHashState -> GearHashState+hashUpdate byte !(hState@GearHashState{..}) = hState'+ where+ !hState' = hState { gearHashCurrent = BitVector.fromNumber (BitVector.dimension gearHashCurrent) (BitVector.toUnsignedNumber (gearHashCurrent `shiftL` 1) + BitVector.toUnsignedNumber (unGearHashTable gearHashTable ! byte) :: Natural) }++{-# INLINE hashFinalize #-}+hashFinalize :: GearHashState -> BitVector+hashFinalize = gearHashCurrent+++{-# INLINE hashInit #-}+hashInit :: GearHashState+hashInit = hashInitWith defaultGearHashTable+ +{-# NOINLINE defaultGearHashTable #-}+defaultGearHashTable :: GearHashTable+defaultGearHashTable = $$(liftTyped . fromMaybe (error "Could not generate defaultGearHashTable") $ defaultGearHashTableFor 64)
+ src/Data/Digest/GearHash/Conduit.hs view
@@ -0,0 +1,64 @@+{-# LANGUAGE ExplicitForAll #-}+{-# LANGUAGE TypeFamilies #-}++module Data.Digest.GearHash.Conduit+ ( GearHashTable+ , mkGearHashTable+ , rollingHash, rollingHashWith, defaultGearHashTable, defaultGearHashTableFor+ , rollingHash', rollingHashWith'+ , BitVector+ ) where++import Prelude+import Data.Conduit+import Data.Conduit.Combinators (chunksOfE, yieldMany)++import Data.Digest.GearHash++import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString++import Data.Monoid (Endo(..))+++rollingHashWith' :: forall m acc.+ ( Monad m+ , Monoid acc+ )+ => (BitVector -> acc)+ -> GearHashTable+ -> ConduitT ByteString acc m ()+rollingHashWith' toAcc tbl = chunksOfE 128 .| go (hashInitWith tbl)+ where+ go hState = do+ chunk' <- await+ case chunk' of+ Nothing -> return ()+ Just chunk -> do+ let (hState', acc) = ByteString.foldl' go' (hState, mempty) chunk+ yield acc+ go hState'++ go' (hState, acc) w = out `seq` (hState', acc <> toAcc out)+ where hState' = hashUpdate w hState+ out = hashFinalize hState'++rollingHash' :: forall m acc.+ ( Monad m+ , Monoid acc+ )+ => (BitVector -> acc)+ -> ConduitT ByteString acc m ()+rollingHash' = flip rollingHashWith' defaultGearHashTable+ ++rollingHashWith :: forall m.+ Monad m+ => GearHashTable+ -> ConduitT ByteString BitVector m ()+rollingHashWith tbl = rollingHashWith' (Endo . (:)) tbl .| awaitForever (yieldMany . flip appEndo [])+ +rollingHash :: forall m.+ Monad m+ => ConduitT ByteString BitVector m ()+rollingHash = rollingHashWith defaultGearHashTable
+ src/Data/Digest/GearHash/Types.hs view
@@ -0,0 +1,103 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell #-}+{-# LANGUAGE TupleSections #-}++module Data.Digest.GearHash.Types where++import Prelude+import GHC.Generics (Generic)+import Data.Typeable (Typeable)+import Data.Array (Array)+import Data.Array.IArray (array, (!))+import Data.Word+import Data.Bits+import Data.BitVector.LittleEndian (BitVector)+import Data.Ratio ((%))+import qualified Data.BitVector.LittleEndian as BitVector++import Data.ByteString (ByteString)+import qualified Data.ByteString as ByteString++import Instances.TH.Lift ()+import Language.Haskell.TH.Syntax++import Data.Maybe+import Data.Monoid (Endo(..))++import Crypto.Random+++newtype GearHashTable+ = GearHashTable { unGearHashTable :: Array Word8 BitVector }+ deriving (Eq, Ord, Generic, Typeable)++instance Show GearHashTable where+ showsPrec d (GearHashTable _) = showParen (d > 10) $ showString "GearHashTable _"++instance Lift GearHashTable where+ liftTyped tbl = [||unsafeGearHashTableFromByteString $$(liftTyped $ unsafeGearHashTableHashLength tbl) $$(liftTyped $ gearHashTableToByteString tbl)||]++data GearHashState = GearHashState+ { gearHashTable :: GearHashTable+ , gearHashCurrent :: {-# UNPACK #-} !BitVector+ } deriving (Eq, Ord, Show, Generic, Typeable)+++mkGearHashTable :: (Word8 -> BitVector) -> GearHashTable+mkGearHashTable f = GearHashTable $! array (minBound, maxBound) [(w, f w) | w <- [minBound..maxBound]]+++{-# NOINLINE defaultGearHashTableFor #-}+defaultGearHashTableFor :: Int -> Maybe GearHashTable+defaultGearHashTableFor l = gearHashTableFromByteString l . fst . randomBytesGenerate (32 * l') $ drgNewTest (fromIntegral l, 0, 0, 0, 0)+ where l' = 8 * ceiling (l % 8)+++gearHashTableHashLength :: GearHashTable -> Maybe Int+gearHashTableHashLength (GearHashTable arr) = flip appEndo Nothing $ foldMap (Endo . max . Just . finiteBitSize) arr++unsafeGearHashTableHashLength :: GearHashTable -> Int+unsafeGearHashTableHashLength = fromMaybe (error "Could not determine hash length of GearHashTable") . gearHashTableHashLength+++unsafeGearHashTableFromByteString :: Int -> ByteString -> GearHashTable+unsafeGearHashTableFromByteString l = fromMaybe (error "Could not convert GearHashTable from ByteString") . gearHashTableFromByteString l++gearHashTableFromByteString :: Int -> ByteString -> Maybe GearHashTable+gearHashTableFromByteString l _ | l <= 0 = Nothing+gearHashTableFromByteString l inpBS = fmap mkGearHashTable $ go 0 (\ix -> error $ "No GearHashTable value available for " ++ show ix) inpBS+ where+ go :: Int -> (Word8 -> BitVector) -> ByteString -> Maybe (Word8 -> BitVector)+ go ix acc bs | ix > 255+ , ByteString.null bs+ = Just acc+ | ix > 255+ = Nothing+ go ix acc bs = case ByteString.splitAt (ceiling $ l % 8) bs of+ (ws, bs')+ | ByteString.length ws == ceiling (l % 8)+ -> let res = foldr (\(s, w) wacc -> wacc .|. BitVector.fromNumber (fromIntegral l) w `shiftL` s) (BitVector.fromNumber (fromIntegral l) (0 :: Integer)) . zip [l' - 8,l' - 16..] $ ByteString.unpack ws+ acc' inp+ | inp == fromIntegral ix = res+ | otherwise = acc inp+ in go (succ ix) acc' bs'+ _other -> Nothing++ l' = 8 * ceiling (l % 8)++gearHashTableToByteString :: GearHashTable -> ByteString+gearHashTableToByteString inpTbl = fst $ ByteString.unfoldrN (32 * l') build (0, [], inpTbl)+ where+ build :: (Int, [Word8], GearHashTable) -> Maybe (Word8, (Int, [Word8], GearHashTable))+ build (ix, [], _) | ix > 255 = Nothing+ build (ix, w:ws, tbl) = Just (w, (ix, ws, tbl))+ build (ix, [], tbl) = Just (w1, (succ ix, ws, tbl))+ where+ w = unGearHashTable tbl ! fromIntegral ix+ (w1:ws) = [ BitVector.toUnsignedNumber $ w `shiftR` s+ | s <- [l' - 8,l' - 16..0]+ ]++ l' = 8 * ceiling (l % 8)+ l = unsafeGearHashTableHashLength inpTbl