keyvaluehash 0.2.0.0 → 0.3.0.0
raw patch · 4 files changed
+284/−78 lines, 4 filesdep +arraydep +mmapdep +storable-recordPVP ok
version bump matches the API change (PVP)
Dependencies added: array, mmap, storable-record
API changes (from Hackage documentation)
+ Database.KeyValueHash: instance Show FileRange
Files
- keyvaluehash.cabal +4/−3
- src/Database/FileArray.hs +72/−0
- src/Database/GrowingFile.hs +154/−0
- src/Database/KeyValueHash.hs +54/−75
keyvaluehash.cabal view
@@ -1,5 +1,5 @@ name: keyvaluehash-version: 0.2.0.0+version: 0.3.0.0 synopsis: Pure Haskell key/value store implementation -- description: license: BSD3@@ -14,7 +14,8 @@ library hs-Source-Dirs: src exposed-modules: Database.KeyValueHash- -- other-modules: - build-depends: base >=4.5 && <10, filepath, directory, bytestring, hashable, binary, derive+ other-modules: Database.GrowingFile, Database.FileArray+ build-depends: base >=4.5 && <10, filepath, directory, bytestring, hashable,+ binary, derive, mmap, array, storable-record ghc-options: -O2 -Wall ghc-prof-options: -Wall -auto-all -caf-all -rtsopts
+ src/Database/FileArray.hs view
@@ -0,0 +1,72 @@+{-# LANGUAGE DeriveDataTypeable, ScopedTypeVariables #-}+module Database.FileArray+ ( FileArray+ , create, open, close+ , Element(..)+ , unsafeElement -- no index checks+ ) where++import Control.Monad (when)+import Data.Bits (Bits, (.&.), complement)+import Data.Typeable (Typeable)+import Data.Word (Word64)+import Foreign.ForeignPtr (ForeignPtr, finalizeForeignPtr, withForeignPtr)+import Foreign.Ptr (plusPtr)+import Foreign.Storable (Storable)+import qualified Control.Exception as Exc+import qualified Foreign.Storable as Storable+import qualified System.IO as IO+import qualified System.IO.MMap as MMap++data FileArray a = FileArray+ { _faCount :: Word64+ , faPtr :: ForeignPtr a+ }++data Element a = Element+ { read :: IO a+ , write :: a -> IO ()+ }++alignPage :: Bits a => a -> a+alignPage x = (x + 0xFFF) .&. complement 0xFFF++sizeOf :: Storable a => a -> Word64+sizeOf = fromIntegral . Storable.sizeOf++create :: forall a. Storable a => FilePath -> Word64 -> IO (FileArray a)+create filePath count = do+ IO.withBinaryFile filePath IO.ReadWriteMode $ \handle ->+ IO.hSetFileSize handle . alignPage . fromIntegral $+ count * elemSize+ open filePath count+ where+ elemSize = sizeOf (undefined :: a)++data MMapWrongRange = MMapWrongRange deriving (Show, Typeable)+instance Exc.Exception MMapWrongRange++open :: forall a. Storable a => FilePath -> Word64 -> IO (FileArray a)+open filePath count = do+ (ptr, base, mapSize) <-+ MMap.mmapFileForeignPtr filePath MMap.ReadWrite Nothing+ when (base > 0 || fromIntegral mapSize < minFileSize) $+ Exc.throwIO MMapWrongRange+ return $ FileArray count ptr+ where+ minFileSize = count * sizeOf (undefined :: a)++close :: FileArray a -> IO ()+close = finalizeForeignPtr . faPtr++{-# INLINE elementSize #-}+elementSize :: forall a. Storable a => FileArray a -> Word64+elementSize _ = sizeOf (undefined :: a)++{-# INLINE unsafeElement #-}+{-# SPECIALIZE unsafeElement :: FileArray Word64 -> Word64 -> IO (Element Word64) #-}+unsafeElement :: Storable a => FileArray a -> Word64 -> IO (Element a)+unsafeElement fileArray ix =+ withForeignPtr (faPtr fileArray) $ \keysPtr -> do+ let ptr = keysPtr `plusPtr` fromIntegral (ix * elementSize fileArray)+ return $ Element (Storable.peek ptr) (Storable.poke ptr)
+ src/Database/GrowingFile.hs view
@@ -0,0 +1,154 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Database.GrowingFile+ ( GrowingFile+ , create, open, close+ , readRange, writeRange+ , append+ ) where++import Control.Applicative (liftA2)+import Control.Monad (when, (<=<))+import Data.IORef+import Data.Typeable (Typeable)+import Data.Word(Word64)+import Foreign (copyBytes)+import Foreign.C.Types (CChar)+import Foreign.ForeignPtr (ForeignPtr, finalizeForeignPtr, withForeignPtr)+import Foreign.Ptr (Ptr, castPtr, plusPtr)+import Foreign.Storable (Storable)+import qualified Foreign.Storable.Record as Store+import qualified Control.Exception as Exc+import qualified Data.ByteString as SBS+import qualified Foreign.Storable as Storable+import qualified System.IO as IO+import qualified System.IO.MMap as MMap++data Header = Header+ { hAllocated :: Word64+ , hUsed :: Word64+ } deriving (Show)++store :: Store.Dictionary Header+store =+ Store.run $+ liftA2 Header+ (Store.element hAllocated)+ (Store.element hUsed)++instance Storable Header where+ sizeOf = Store.sizeOf store+ alignment = Store.alignment store+ peek = Store.peek store+ poke = Store.poke store++data GrowingFile = GrowingFile+ { gfFilePath :: FilePath+ , gfPtr :: IORef (ForeignPtr CChar)+ , gfGrowthSize :: Word64+ }++sizeOf :: (Storable a, Integral b) => a -> b+sizeOf = fromIntegral . Storable.sizeOf++resizeFile :: FilePath -> Word64 -> IO ()+resizeFile filePath size =+ IO.withBinaryFile filePath IO.ReadWriteMode $ \handle ->+ IO.hSetFileSize handle (fromIntegral size)++data MMapWrongRange = MMapWrongRange deriving (Show, Typeable)+instance Exc.Exception MMapWrongRange++peekForeignPtr :: Storable b => ForeignPtr a -> IO b+peekForeignPtr fptr =+ withForeignPtr fptr $ \ptr -> Storable.peek (castPtr ptr)++pokeForeignPtr :: Storable b => ForeignPtr a -> b -> IO ()+pokeForeignPtr fptr val =+ withForeignPtr fptr $ \ptr -> Storable.poke (castPtr ptr) val++mmap :: FilePath -> IO (ForeignPtr a)+mmap filePath = do+ (fptr, base, mapSize) <-+ MMap.mmapFileForeignPtr filePath MMap.ReadWrite Nothing++ when (base > 0) $ Exc.throwIO MMapWrongRange+ header <- peekForeignPtr fptr+ when (fromIntegral mapSize < hAllocated header) $ Exc.throwIO MMapWrongRange++ return fptr++open :: FilePath -> Word64 -> IO GrowingFile+open filePath growthSize = do+ fptr <- newIORef =<< mmap filePath+ return $ GrowingFile filePath fptr growthSize++create :: FilePath -> Word64 -> IO GrowingFile+create filePath growthSize = do+ resizeFile filePath firstAllocatedSize+ fptr <- mmap filePath+ pokeForeignPtr fptr $ Header firstAllocatedSize firstUsedSize+ fptrVar <- newIORef fptr+ return $ GrowingFile filePath fptrVar growthSize+ where+ firstAllocatedSize = max growthSize firstUsedSize+ firstUsedSize = sizeOf (undefined :: Header)++readHeader :: GrowingFile -> IO Header+readHeader = peekForeignPtr <=< readIORef . gfPtr++writeHeader :: GrowingFile -> Header -> IO ()+writeHeader gfile header = do+ ptr <- readIORef (gfPtr gfile)+ pokeForeignPtr ptr header++unmap :: GrowingFile -> IO ()+unmap gfile = do+ ptr <- readIORef (gfPtr gfile)+ finalizeForeignPtr ptr++close :: GrowingFile -> IO ()+close = unmap++withPtr :: GrowingFile -> (Ptr CChar -> IO a) -> IO a+withPtr gfile f = do+ fptr <- readIORef (gfPtr gfile)+ withForeignPtr fptr f++readRange :: GrowingFile -> Word64 -> Word64 -> IO SBS.ByteString+readRange gfile start count = withPtr gfile $ \ptr ->+ SBS.packCStringLen (ptr `plusPtr` fromIntegral start, fromIntegral count)++writeRange :: GrowingFile -> Word64 -> SBS.ByteString -> IO ()+writeRange gfile start bs =+ withPtr gfile $ \ptr ->+ SBS.useAsCStringLen bs $+ \(ccharptr, len) -> copyBytes (ptr `plusPtr` fromIntegral start) ccharptr len++align :: Word64 -> Word64 -> Word64+align x boundary = x + (-x) `mod` boundary++computeSize :: GrowingFile -> Word64 -> Word64+computeSize gfile newUsed =+ align newUsed (gfGrowthSize gfile)++resize :: GrowingFile -> Header -> Word64 -> IO ()+resize gfile header newUsed =+ if newUsed > hAllocated header+ then do+ unmap gfile+ let newSize = computeSize gfile newUsed+ resizeFile (gfFilePath gfile) newSize+ writeIORef (gfPtr gfile) =<< mmap (gfFilePath gfile)+ writeHeader gfile Header { hAllocated = newSize, hUsed = newUsed }+ else+ writeHeader gfile $ header { hUsed = newUsed }++append :: GrowingFile -> SBS.ByteString -> IO Word64+append gfile bs = do+ header <- readHeader gfile+ let+ curUsed = hUsed header+ newUsed = curUsed + fromIntegral (SBS.length bs)+ resize gfile header newUsed+ writeRange gfile curUsed bs+ return curUsed
src/Database/KeyValueHash.hs view
@@ -1,4 +1,4 @@-{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveDataTypeable #-}+{-# LANGUAGE TemplateHaskell, DeriveDataTypeable #-} module Database.KeyValueHash ( Key, Value , Size, mkSize, sizeLinear@@ -16,16 +16,23 @@ import Data.Derive.Binary(makeBinary) import Data.DeriveTH(derive) import Data.Hashable (Hashable, hash)+import Data.List (intercalate) import Data.Monoid (mconcat) import Data.Typeable (Typeable) import Data.Word (Word8, Word32, Word64)+import Database.FileArray (FileArray)+import Database.GrowingFile (GrowingFile) import System.FilePath ((</>)) import qualified Control.Exception as Exc import qualified Data.ByteString as SBS import qualified Data.ByteString.Lazy as LBS+import qualified Database.FileArray as FileArray+import qualified Database.GrowingFile as GrowingFile import qualified System.Directory as Directory-import qualified System.IO as IO +valuesGrowthSize :: Word64+valuesGrowthSize = 128 * 1024+ -- of any length, but long values may be less efficiently handled type Key = SBS.ByteString type Value = SBS.ByteString@@ -61,25 +68,16 @@ stdHash :: HashFunction stdHash = mkHashFunc "Hashable" (fromIntegral . hash) -data Database = Database- { _dbPath :: FilePath -- directory container- , dbSize :: Size- , dbHashFunc :: HashFunction- , dbKeysHandle :: IO.Handle- , dbValuesHandle :: IO.Handle- }--data FileRange = FileRange- { _frOffset :: Word64- , _frSize :: Word64- }-derive makeBinary ''FileRange- type ValuePtr = Word64 -- offset in values file type KeyPtr = Word64 -- index in key file- type KeyRecord = ValuePtr +data FileRange = FileRange+ { frOffset :: Word64+ , frSize :: Word64+ } deriving (Show)+derive makeBinary ''FileRange+ data ValueHeader = ValueHeader { vhNextCollision :: ValuePtr -- if value is re-written multiple times, we can do it in-place as long as it fits@@ -89,6 +87,14 @@ } derive makeBinary ''ValueHeader +data Database = Database+ { _dbPath :: FilePath -- directory container+ , dbSize :: Size+ , dbHashFunc :: HashFunction+ , dbKeysArray :: FileArray KeyRecord+ , dbValues :: GrowingFile+ }+ atVhNextCollision :: (ValuePtr -> ValuePtr) -> ValueHeader -> ValueHeader atVhNextCollision f v = v { vhNextCollision = f (vhNextCollision v) } @@ -101,17 +107,12 @@ binaryPutSize :: Binary a => a -> Word64 binaryPutSize = fromIntegral . SBS.length . encode --- Make a fake KeyRecord because Binary doesn't have a calcSize--- operation (TODO: Use my own combinators for fixed-size records)-keyRecordSize :: Word64-keyRecordSize = binaryPutSize (0 :: KeyRecord)- valueHeaderSize :: Word64 valueHeaderSize = binaryPutSize $ ValueHeader 0 0 0 0 makeFileName :: String -> FilePath -> HashFunction -> Size -> FilePath makeFileName prefix path func size =- path </> concat [prefix, hfName func, "_", show size]+ path </> intercalate "_" [prefix, hfName func, show size] keysFileName :: FilePath -> HashFunction -> Size -> FilePath keysFileName = makeFileName "keys"@@ -130,28 +131,24 @@ createDatabase :: FilePath -> HashFunction -> Size -> IO Database createDatabase path func size = do Directory.createDirectory path- keysHandle <- mkHandle keysFileName- IO.hSetFileSize keysHandle . fromIntegral $ sizeLinear size * keyRecordSize- valuesHandle <- mkHandle valuesFileName- -- Offset 0 in the values file is used as invalid, so just write a useless 16-byte- SBS.hPut valuesHandle $ SBS.replicate 16 0- return $ Database path size func keysHandle valuesHandle+ mapM_ assertNotExists [keysFN, valuesFN]+ Database path size func+ <$> FileArray.create keysFN (sizeLinear size)+ <*> GrowingFile.create valuesFN valuesGrowthSize where- mkHandle f = do- let fileName = f path func size- assertNotExists fileName- IO.openFile fileName IO.ReadWriteMode+ keysFN = keysFileName path func size+ valuesFN = valuesFileName path func size openDatabase :: FilePath -> HashFunction -> Size -> IO Database openDatabase path func size =- Database path size func <$> mkHandle keysFileName <*> mkHandle valuesFileName- where- mkHandle f = IO.openFile (f path func size) IO.ReadWriteMode+ Database path size func+ <$> FileArray.open (keysFileName path func size) (sizeLinear size)+ <*> GrowingFile.open (valuesFileName path func size) valuesGrowthSize closeDatabase :: Database -> IO () closeDatabase db = do- IO.hClose $ dbKeysHandle db- IO.hClose $ dbValuesHandle db+ FileArray.close $ dbKeysArray db+ GrowingFile.close $ dbValues db withCreateDatabase :: FilePath -> HashFunction -> Size -> (Database -> IO a) -> IO a withCreateDatabase path func size =@@ -167,24 +164,14 @@ invalidValuePtr :: ValuePtr invalidValuePtr = 0 -keyFileOffset :: KeyPtr -> Word64-keyFileOffset = (* keyRecordSize)--keyFileRange :: KeyPtr -> FileRange-keyFileRange i = FileRange (keyFileOffset i) keyRecordSize--readFileRange :: IO.Handle -> FileRange -> IO SBS.ByteString-readFileRange handle (FileRange offset size) = do- IO.hSeek handle IO.AbsoluteSeek $ fromIntegral offset- SBS.hGet handle $ fromIntegral size+readRange :: GrowingFile -> FileRange -> IO SBS.ByteString+readRange gfile rng = GrowingFile.readRange gfile (frOffset rng) (frSize rng) -decodeFileRange :: Binary a => IO.Handle -> FileRange -> IO a-decodeFileRange handle rng = decode <$> readFileRange handle rng+writeRange :: GrowingFile -> Word64 -> SBS.ByteString -> IO ()+writeRange gfile offset bs = GrowingFile.writeRange gfile offset bs -writeFileRange :: IO.Handle -> Word64 -> SBS.ByteString -> IO ()-writeFileRange handle offset bs = do- IO.hSeek handle IO.AbsoluteSeek $ fromIntegral offset- SBS.hPut handle bs+decodeFileRange :: Binary a => GrowingFile -> FileRange -> IO a+decodeFileRange gfile rng = decode <$> readRange gfile rng strictify :: LBS.ByteString -> SBS.ByteString strictify = SBS.concat . LBS.toChunks@@ -199,14 +186,12 @@ hashValuePtrRef :: Database -> Key -> IO ValuePtrRef hashValuePtrRef db key = do- valuePtr <-- decodeFileRange (dbKeysHandle db) $ keyFileRange keyPtr+ element <- FileArray.unsafeElement (dbKeysArray db) $ hashKey db key+ valuePtr <- FileArray.read element return ValuePtrRef { vprVal = valuePtr- , vprSet = writeFileRange (dbKeysHandle db) (keyFileOffset keyPtr) . encode+ , vprSet = FileArray.write element }- where- keyPtr = hashKey db key valueKeyRange :: ValuePtr -> ValueHeader -> FileRange valueKeyRange valuePtr header =@@ -225,19 +210,17 @@ | vprVal valuePtrRef == invalidValuePtr = return Nothing | otherwise = do valueHeader <-- decodeFileRange (dbValuesHandle db)+ decodeFileRange (dbValues db) (FileRange (vprVal valuePtrRef) valueHeaderSize)- vKey <-- readFileRange (dbValuesHandle db) $- valueKeyRange (vprVal valuePtrRef) valueHeader+ vKey <- readRange (dbValues db) $ valueKeyRange (vprVal valuePtrRef) valueHeader if key == vKey then return $ Just (valuePtrRef, valueHeader) else find $ nextCollisionRef (vprVal valuePtrRef) valueHeader nextCollisionRef valuePtr valueHeader = ValuePtrRef { vprVal = vhNextCollision valueHeader , vprSet =- writeFileRange (dbValuesHandle db)- valuePtr . encode . flip (atVhNextCollision . const) valueHeader+ writeRange (dbValues db) valuePtr .+ encode . flip (atVhNextCollision . const) valueHeader } readKey :: Database -> Key -> IO (Maybe Value)@@ -246,9 +229,7 @@ case mValueRange of Nothing -> return Nothing Just (valuePtrRef, valueHeader) ->- Just <$>- readFileRange (dbValuesHandle db)- (valueDataRange (vprVal valuePtrRef) valueHeader)+ Just <$> readRange (dbValues db) (valueDataRange (vprVal valuePtrRef) valueHeader) pairLengths :: Key -> Value -> (Word32, Word32) pairLengths key value = (keyLen, valueLen)@@ -257,18 +238,15 @@ valueLen = fromIntegral $ SBS.length value appendNewValue :: Database -> ValuePtr -> Key -> Value -> IO ValuePtr-appendNewValue db nextCollision key value = do- valuePtr <- fromIntegral <$> IO.hFileSize (dbValuesHandle db)- let+appendNewValue db nextCollision key value =+ GrowingFile.append (dbValues db) $ mconcat [headerStr, key, value]+ where headerStr = encode ValueHeader { vhNextCollision = nextCollision , vhAllocSize = keyLen + valueLen , vhKeySize = keyLen , vhValueSize = valueLen }- writeFileRange (dbValuesHandle db) valuePtr $ mconcat [headerStr, key, value]- return valuePtr- where (keyLen, valueLen) = pairLengths key value writeKey :: Database -> Key -> Value -> IO ()@@ -279,7 +257,8 @@ if vhAllocSize valueHeader >= keyLen + valueLen then -- re-use existing storage: let headerStr = encode valueHeader { vhKeySize = keyLen, vhValueSize = valueLen }- in writeFileRange (dbValuesHandle db) (vprVal valuePtrRef) $ mconcat [headerStr, key, value]+ in writeRange (dbValues db) (vprVal valuePtrRef) $+ mconcat [headerStr, key, value] else -- The old value now becomes unreachable setValue valuePtrRef $ vhNextCollision valueHeader