diff --git a/keyvaluehash.cabal b/keyvaluehash.cabal --- a/keyvaluehash.cabal +++ b/keyvaluehash.cabal @@ -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 diff --git a/src/Database/FileArray.hs b/src/Database/FileArray.hs new file mode 100644 --- /dev/null +++ b/src/Database/FileArray.hs @@ -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) diff --git a/src/Database/GrowingFile.hs b/src/Database/GrowingFile.hs new file mode 100644 --- /dev/null +++ b/src/Database/GrowingFile.hs @@ -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 diff --git a/src/Database/KeyValueHash.hs b/src/Database/KeyValueHash.hs --- a/src/Database/KeyValueHash.hs +++ b/src/Database/KeyValueHash.hs @@ -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