diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright (c) 2012, Eyal Lotem + +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 Eyal Lotem 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/keyvaluehash.cabal b/keyvaluehash.cabal new file mode 100644 --- /dev/null +++ b/keyvaluehash.cabal @@ -0,0 +1,20 @@ +name: keyvaluehash +version: 0.1.0.0 +synopsis: Pure Haskell key/value store implementation +-- description: +license: BSD3 +license-file: LICENSE +author: Eyal Lotem +maintainer: eyal.lotem@gmail.com +-- copyright: +category: Database +build-type: Simple +cabal-version: >=1.8 + +library + hs-Source-Dirs: src + exposed-modules: Database.KeyValueHash + -- other-modules: + build-depends: base >=4.5 && <10, filepath, directory, bytestring, hashable, binary, derive + ghc-options: -O2 -Wall + ghc-prof-options: -Wall -auto-all -caf-all -rtsopts diff --git a/src/Database/KeyValueHash.hs b/src/Database/KeyValueHash.hs new file mode 100644 --- /dev/null +++ b/src/Database/KeyValueHash.hs @@ -0,0 +1,272 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving, TemplateHaskell, DeriveDataTypeable #-} +module Database.KeyValueHash + ( Key, Value + , Size, mkSize, sizeLinear + , HashFunction, stdHash, mkHashFunc + , Database, createDatabase, openDatabase + , readKey, writeKey, deleteKey + ) where + +import Control.Applicative ((<$>), (<*>)) +import Control.Monad (when) +import Data.Binary (Binary(..)) +import Data.Binary.Get (runGet) +import Data.Binary.Put (runPut) +import Data.Derive.Binary(makeBinary) +import Data.DeriveTH(derive) +import Data.Hashable (Hashable, hash) +import Data.Monoid (mconcat) +import Data.Typeable (Typeable) +import Data.Word (Word8, Word32, Word64) +import System.FilePath (()) +import qualified Control.Exception as Exc +import qualified Data.ByteString as SBS +import qualified Data.ByteString.Lazy as LBS +import qualified System.Directory as Directory +import qualified System.IO as IO + +-- of any length, but long values may be less efficiently handled +type Key = SBS.ByteString +type Value = SBS.ByteString + +newtype Size = Size { + sizeLog :: Word8 + } + +sizeLinear :: Size -> Word64 +sizeLinear = (2^) . sizeLog + +instance Show Size where + show (Size x) = "sz" ++ show x + +mkSize :: Word64 -> Size +mkSize = Size . (ceiling :: Double -> Word8) . logBase 2 . fromIntegral + +data HashFunction = HashFunction + { hfHash :: Key -> Size -> Word64 + , hfName :: String + } + +-- Must not use 0-value because it is used as an invalid value ptr +cap :: Word64 -> Size -> Word64 +cap val size = val `mod` (sizeLinear size) + +mkHashFunc :: String -> (Key -> Word64) -> HashFunction +mkHashFunc name f = HashFunction + { hfName = name + , hfHash = cap . f + } + +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 ValueHeader = ValueHeader + { vhNextCollision :: ValuePtr + , vhKeySize :: Word32 + , vhValueSize :: Word32 + } +derive makeBinary ''ValueHeader + +atVhNextCollision :: (ValuePtr -> ValuePtr) -> ValueHeader -> ValueHeader +atVhNextCollision f v = v { vhNextCollision = f (vhNextCollision v) } + +encode :: Binary a => a -> SBS.ByteString +encode = strictify . runPut . put + +decode :: Binary a => SBS.ByteString -> a +decode = runGet get . lazify + +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 + +makeFileName :: String -> FilePath -> HashFunction -> Size -> FilePath +makeFileName prefix path func size = + path concat [prefix, hfName func, "_", show size] + +keysFileName :: FilePath -> HashFunction -> Size -> FilePath +keysFileName = makeFileName "keys" + +valuesFileName :: FilePath -> HashFunction -> Size -> FilePath +valuesFileName = makeFileName "values" + +data FileAlreadyExists = FileAlreadyExists String deriving (Show, Typeable) +instance Exc.Exception FileAlreadyExists +assertNotExists :: FilePath -> IO () +assertNotExists fileName = do + de <- Directory.doesDirectoryExist fileName + fe <- Directory.doesFileExist fileName + when (de || fe) $ Exc.throwIO (FileAlreadyExists fileName) + +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 + where + mkHandle f = do + let fileName = f path func size + assertNotExists fileName + IO.openFile fileName IO.ReadWriteMode + +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 + +hashKey :: Database -> Key -> KeyPtr +hashKey db key = hfHash (dbHashFunc db) key (dbSize db) + +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 + +decodeFileRange :: Binary a => IO.Handle -> FileRange -> IO a +decodeFileRange handle rng = decode <$> readFileRange handle rng + +writeFileRange :: IO.Handle -> Word64 -> SBS.ByteString -> IO () +writeFileRange handle offset bs = do + IO.hSeek handle IO.AbsoluteSeek $ fromIntegral offset + SBS.hPut handle bs + +strictify :: LBS.ByteString -> SBS.ByteString +strictify = SBS.concat . LBS.toChunks + +lazify :: SBS.ByteString -> LBS.ByteString +lazify = LBS.fromChunks . (: []) + +data ValuePtrRef = ValuePtrRef + { vprVal :: ValuePtr + , vprSet :: ValuePtr -> IO () + } + +hashValuePtrRef :: Database -> Key -> IO ValuePtrRef +hashValuePtrRef db key = do + valuePtr <- + decodeFileRange (dbKeysHandle db) $ keyFileRange keyPtr + return ValuePtrRef + { vprVal = valuePtr + , vprSet = writeFileRange (dbKeysHandle db) (keyFileOffset keyPtr) . encode + } + where + keyPtr = hashKey db key + +valueKeyRange :: ValuePtr -> ValueHeader -> FileRange +valueKeyRange valuePtr header = + FileRange (valuePtr + valueHeaderSize) . fromIntegral $ vhKeySize header + +valueDataRange :: ValuePtr -> ValueHeader -> FileRange +valueDataRange valuePtr header = + FileRange (valuePtr + valueHeaderSize + fromIntegral (vhKeySize header)) . fromIntegral $ + vhValueSize header + +findKey :: Database -> Key -> IO (Maybe (ValuePtrRef, ValueHeader)) +findKey db key = + find =<< hashValuePtrRef db key + where + find valuePtrRef + | vprVal valuePtrRef == invalidValuePtr = return Nothing + | otherwise = do + valueHeader <- + decodeFileRange (dbValuesHandle db) + (FileRange (vprVal valuePtrRef) valueHeaderSize) + vKey <- + readFileRange (dbValuesHandle 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 + } + +readKey :: Database -> Key -> IO (Maybe Value) +readKey db key = do + mValueRange <- findKey db key + case mValueRange of + Nothing -> return Nothing + Just (valuePtrRef, valueHeader) -> + Just <$> + readFileRange (dbValuesHandle db) + (valueDataRange (vprVal valuePtrRef) valueHeader) + +appendNewValue :: Database -> ValuePtr -> Key -> Value -> IO ValuePtr +appendNewValue db nextCollision key val = do + valuePtr <- fromIntegral <$> IO.hFileSize (dbValuesHandle db) + let + headerStr = encode ValueHeader + { vhKeySize = fromIntegral $ SBS.length key + , vhValueSize = fromIntegral $ SBS.length val + , vhNextCollision = nextCollision + } + writeFileRange (dbValuesHandle db) valuePtr $ mconcat [headerStr, key, val] + return valuePtr + +writeKey :: Database -> Key -> Value -> IO () +writeKey db key value = do + mResult <- findKey db key + case mResult of + Just (valuePtrRef, valueHeader) -> + -- The old value now becomes unreachable + setValue valuePtrRef $ vhNextCollision valueHeader + Nothing -> do + hashAnchor <- hashValuePtrRef db key + setValue hashAnchor $ vprVal hashAnchor + where + setValue ref nextCollision = + vprSet ref =<< appendNewValue db nextCollision key value + +deleteKey :: Database -> Key -> IO () +deleteKey db key = do + mResult <- findKey db key + case mResult of + Just (valuePtrRef, valueHeader) -> + -- The old value now becomes unreachable + vprSet valuePtrRef $ vhNextCollision valueHeader + Nothing -> + -- TODO: Throw exception? + return ()