CurryDB 0.1.0.0 → 0.1.1.0
raw patch · 7 files changed
+159/−64 lines, 7 filesdep +arraydep +hashabledep +lensdep −data-lensdep −data-lens-fddep −data-lens-templatedep ~binarydep ~lifted-base
Dependencies added: array, hashable, lens
Dependencies removed: data-lens, data-lens-fd, data-lens-template, ekg
Dependency ranges changed: binary, lifted-base
Files
- CurryDB.cabal +8/−6
- Database/Curry.hs +2/−3
- Database/Curry/Commands.hs +15/−18
- Database/Curry/HashMap.hs +101/−0
- Database/Curry/Storage.hs +11/−28
- Database/Curry/Types.hs +4/−6
- tests/hspec.hs +18/−3
CurryDB.cabal view
@@ -1,5 +1,5 @@ name: CurryDB-version: 0.1.0.0+version: 0.1.1.0 synopsis: CurryDB: In-memory Key/Value Database description: CurryDB: Simple, Persistent, Polymorphic, Transactional, In-memory Key/Value Database license: BSD3@@ -19,6 +19,7 @@ exposed-modules: Database.Curry Database.Curry.Binary Database.Curry.Commands+ Database.Curry.HashMap Database.Curry.Storage Database.Curry.Types Database.Memcached@@ -38,9 +39,7 @@ , transformers-base >=0.4 , unordered-containers >=0.2.2 , containers >=0.4- , data-lens >= 2.10- , data-lens-fd >= 2.0- , data-lens-template >= 2.1+ , lens >=3.6 , conduit >=0.5 , time , stm >=2.4@@ -59,8 +58,10 @@ , system-filepath >=0.4.7 , system-fileio >=0.3.10 , async >=2.0- , binary >=0.6.1+ , binary >=0.5 , lifted-base >=0.2+ , hashable+ , array ghc-prof-options: -auto-all @@ -79,7 +80,7 @@ , network-conduit , system-filepath , optparse-applicative- , ekg >=0.3.1+-- , ekg >=0.3.1 , CurryDB test-suite doctests@@ -100,6 +101,7 @@ , mtl , stm , conduit+ , lifted-base , CurryDB benchmark curry-bench
Database/Curry.hs view
@@ -19,19 +19,18 @@ import Control.Monad.Trans.Identity import Data.Binary import Data.Default-import qualified Data.HashMap.Strict as HMS import System.IO import System.Log.FastLogger -import Database.Curry.Binary () import Database.Curry.Commands+import qualified Database.Curry.HashMap as HM import Database.Curry.Storage import Database.Curry.Types initDBMState :: Config -> STM () -> IO (DBMState v) initDBMState conf upd = DBMState- <$> newTVarIO HMS.empty+ <$> HM.new <*> pure upd <*> mkLogger True stdout <*> pure conf
Database/Curry/Commands.hs view
@@ -5,7 +5,7 @@ insert, insertWith, delete,- Database.Curry.Commands.lookup,+ lookup, lookupDefault, keys, @@ -15,59 +15,56 @@ import Control.Applicative import Control.Concurrent.STM+import Control.Lens import Control.Monad.State.Strict import Control.Monad.Trans.Identity import qualified Data.ByteString as S import Data.Conduit import Data.Default-import qualified Data.HashMap.Strict as HMS-import Data.Lens import Data.Maybe +import qualified Database.Curry.HashMap as HM import Database.Curry.Types +import Prelude hiding (lookup)+ insert :: S.ByteString -> v -> DBMS v () insert !key !val = do- table <- access dbmTable- liftSTM $ modifyTVar' table $ HMS.insert key val+ liftSTM . HM.insert key val =<< use dbmTable update {-# INLINE insert #-} insertWith :: (v -> v -> v) -> S.ByteString -> v -> DBMS v () insertWith !f !key !val = do- htvar <- access dbmTable- liftSTM $ modifyTVar' htvar $ HMS.insertWith f key val+ liftSTM . HM.insertWith f key val =<< use dbmTable update {-# INLINE insertWith #-} delete :: S.ByteString -> DBMS v () delete !key = do- htvar <- access dbmTable- liftSTM $ modifyTVar' htvar $ HMS.delete key+ liftSTM . HM.delete key =<< use dbmTable update {-# INLINE delete #-} lookup :: S.ByteString -> DBMS v (Maybe v) lookup !key = do- htvar <- access dbmTable- liftSTM $ HMS.lookup key <$> readTVar htvar+ ht <- use dbmTable+ liftSTM $ HM.lookup key ht {-# INLINE lookup #-} lookupDefault :: Default v => S.ByteString -> DBMS v v-lookupDefault !key = do- htvar <- access dbmTable- liftSTM $ fromMaybe def . HMS.lookup key <$> readTVar htvar+lookupDefault !key = fromMaybe def <$> lookup key {-# INLINE lookupDefault #-} keys :: Monad m => DBMS v (Source (DBMT v m) S.ByteString) keys = do- htvar <- access dbmTable- ht <- liftSTM $ readTVar htvar- return $ mapM_ yield $ HMS.keys ht+ ht <- use dbmTable+ ks <- liftSTM $ HM.keys ht+ return $ mapM_ yield ks {-# INLINE keys #-} update ::DBMS v ()-update = liftSTM =<< access dbmUpdate+update = liftSTM =<< use dbmUpdate {-# INLINE update #-} transaction :: MonadIO m => DBMS v a -> DBMT v m a
+ Database/Curry/HashMap.hs view
@@ -0,0 +1,101 @@+{-# LANGUAGE OverloadedStrings #-}++module Database.Curry.HashMap (+ HashMap, Key,+ new,+ load, save,+ insert, insertWith,+ delete,+ lookup,+ keys,+ ) where++import Control.Applicative+import Control.Concurrent.STM+import qualified Control.Exception as E+import Control.Monad+import qualified Data.Array.MArray as MA+import Data.Binary+import qualified Data.ByteString as S+import qualified Data.ByteString.Lazy as L+import Data.Hashable+import qualified Data.HashMap.Strict as HMS+import Data.Maybe+import qualified Filesystem as FS+import qualified Filesystem.Path as FP+import System.IO++import Database.Curry.Binary ()++import Prelude hiding (lookup)++type Key = S.ByteString++newtype HashMap v =+ HashMap { unHM :: TArray Int (HMS.HashMap Key v) }++bucketNum :: Int+bucketNum = 32++bucketIx :: Key -> Int+bucketIx key = hash key `mod` bucketNum++new :: IO (HashMap v)+new = atomically $ do+ HashMap <$> MA.newArray (0, bucketNum - 1) HMS.empty++load :: Binary v => FP.FilePath -> HashMap v -> IO ()+load path hm = do+ vs <- decode . L.fromChunks . (\x -> [x]) <$> FS.readFile path+ _ <- E.evaluate vs -- force and raise exception when data is corrupted.+ when (length vs /= bucketNum) $+ fail "load: data corrupted"+ atomically $ do+ forM_ (zip [0..] vs) $ \(ix, v) -> do+ MA.writeArray (unHM hm) ix v++save :: Binary v => FP.FilePath -> HashMap v -> IO ()+save path hm = do+ vs <- atomically $ forM_ [0 .. bucketNum - 1] $ \ix -> MA.readArray (unHM hm) ix+ atomicWriteFile path vs++insert :: Key -> v -> HashMap v -> STM ()+insert = insertWith const+{-# INLINE insert #-}++insertWith :: (v -> v -> v) -> Key -> v -> HashMap v -> STM ()+insertWith f k v hm = do+ let bix = bucketIx k+ bkt <- MA.readArray (unHM hm) bix+ MA.writeArray (unHM hm) bix $! HMS.insertWith f k v bkt+{-# INLINE insertWith #-}++delete :: Key -> HashMap v -> STM ()+delete k hm = do+ let bix = bucketIx k+ bkt <- MA.readArray (unHM hm) bix+ MA.writeArray (unHM hm) bix $! HMS.delete k bkt+{-# INLINE delete #-}++lookup :: Key -> HashMap v -> STM (Maybe v)+lookup k hm = do+ let bix = bucketIx k+ HMS.lookup k <$> MA.readArray (unHM hm) bix+{-# INLINE lookup #-}++keys :: HashMap v -> STM [Key]+keys hm = do+ bkts <- forM [0 .. bucketNum - 1] $ \ix ->+ HMS.keys <$> MA.readArray (unHM hm) ix+ return $ concat bkts+{-# INLINE keys #-}++--++atomicWriteFile :: Binary b => FP.FilePath -> b -> IO ()+atomicWriteFile path b = do+ let tmpPath = path FP.<.> "tmp"+ FS.withFile tmpPath WriteMode $ \h ->+ L.hPut h $ encode b+ -- rename operation is atomic+ FS.rename tmpPath path
Database/Curry/Storage.hs view
@@ -10,24 +10,19 @@ loadFromFile, ) where -import Control.Applicative import Control.Concurrent (forkIO, threadDelay) import Control.Concurrent.Async import Control.Concurrent.STM import qualified Control.Exception as E+import Control.Lens import Control.Monad.Logger import Control.Monad.State.Strict import Data.Binary-import qualified Data.ByteString.Lazy as L-import Data.Lens import Data.Monoid import qualified Data.Text as T import Data.Time-import qualified Filesystem as FS-import qualified Filesystem.Path.CurrentOS as FP-import System.IO -import Database.Curry.Binary ()+import Database.Curry.HashMap as HM import Database.Curry.Types saveThread :: (Functor m, MonadIO m, Binary v)@@ -47,7 +42,7 @@ let notify (SaveByFrequency {..})= do upd <- newTVarIO 0- forkIO $ forever $ do+ _ <- forkIO $ forever $ do start <- readTVarIO timer atomically $ do cur <- readTVar timer@@ -74,13 +69,12 @@ saveToFile :: (MonadIO m, Binary v) => DBMT v m () saveToFile = do- Config {..} <- access dbmConfig+ Config {..} <- use dbmConfig case configPath of Nothing -> return ()- Just fname -> do+ Just path -> do $logInfo "save to file..."- tbl <- liftIO . readTVarIO =<< access dbmTable- err <- liftIO $ E.try $ atomicWriteFile fname tbl+ err <- liftIO . E.try . HM.save path =<< use dbmTable case err of Right _ -> return ()@@ -89,25 +83,14 @@ loadFromFile :: (MonadIO m, Binary v) => DBMT v m () loadFromFile = do- Config {..} <- access dbmConfig+ Config {..} <- use dbmConfig case configPath of Nothing -> return () Just path -> do $logInfo "load from file..."- etbl <- liftIO $ E.try $ do- v <- decode . L.fromChunks . (\x -> [x]) <$> FS.readFile path- E.evaluate v -- force and raise exception when data is corrupted.- case etbl of- Right tbl -> do- tv <- access dbmTable- liftIO $ atomically $ writeTVar tv tbl+ tbl <- use dbmTable+ res <- liftIO . E.try . HM.load path =<< use dbmTable+ case res of+ Right () -> return () Left err -> do $logInfo $ "fail to load " <> ": " <> (T.pack $ show (err :: E.SomeException))--atomicWriteFile :: Binary b => FP.FilePath -> b -> IO ()-atomicWriteFile path b = do- let tmpPath = path FP.<.> "tmp"- FS.withFile tmpPath WriteMode $ \h ->- L.hPut h $ encode b- -- rename operation is atomic- FS.rename tmpPath path
Database/Curry/Types.hs view
@@ -27,22 +27,20 @@ import Control.Applicative import Control.Concurrent.STM+import Control.Lens import Control.Monad import Control.Monad.Base import Control.Monad.Logger import Control.Monad.State.Strict import Control.Monad.Trans.Control import Control.Monad.Trans.Identity-import qualified Data.ByteString as S import Data.Conduit import Data.Default-import qualified Data.HashMap.Strict as HMS-import Data.Lens.Template import qualified Filesystem.Path.CurrentOS as FP import Language.Haskell.TH.Syntax (Loc (..)) import System.Log.FastLogger -import Database.Curry.Binary ()+import Database.Curry.HashMap type DBMT v m = DBMT_ (StateT (DBMState v) m) type DBMS v = DBMT v STM@@ -86,7 +84,7 @@ data DBMState v = DBMState- { _dbmTable :: TVar (HMS.HashMap S.ByteString v)+ { _dbmTable :: HashMap v , _dbmUpdate :: STM () , _dbmLogger :: Logger , _dbmConfig :: Config@@ -105,7 +103,7 @@ , freqUpdates :: Int } -makeLens ''DBMState+makeLenses ''DBMState instance Default Config where def = Config
tests/hspec.hs view
@@ -1,11 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} import Control.Applicative+import Control.Concurrent.Chan.Lifted+import Control.Concurrent.Lifted import Control.Monad import Control.Monad.Trans import Data.Conduit-import qualified Data.Conduit.List as CL-import Data.List (sort)+import qualified Data.Conduit.List as CL+import Data.List (sort) import Test.Hspec -- import Test.QuickCheck@@ -13,7 +15,7 @@ import Database.Curry -import Prelude hiding (lookup)+import Prelude hiding (lookup) main :: IO () main = hspec $ do@@ -107,4 +109,17 @@ liftIO $ v2 `shouldBe` Just 456 v3 <- transaction $ lookup "baz" liftIO $ v3 `shouldBe` Nothing+ return () :: IO ()++ describe "concurrent support" $ do+ it "does not race" $ do+ runDBMT def $ do+ chan <- newChan+ replicateM_ 10 $ fork $ do+ replicateM_ 10000 $ do+ transaction $ insertWith (+) "foo" (1 :: Int)+ writeChan chan ()+ replicateM_ 10 $ readChan chan+ cnt <- transaction $ lookupDefault "foo"+ liftIO $ cnt `shouldBe` 100000 return () :: IO ()