haskey 0.1.0.0 → 0.1.0.1

raw patch · 6 files changed

+97/−9 lines, 6 filesdep +asyncdep +textdep ~bytestringdep ~haskey-btreenew-component:exe:haskey-examplePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: async, text

Dependency ranges changed: bytestring, haskey-btree

API changes (from Hackage documentation)

Files

• example/Main.hs +66/−0
• haskey.cabal +15/−1
• src/Database/Haskey/Alloc/Concurrent/Database.hs +2/−1
• src/Database/Haskey/Alloc/Concurrent/FreePages/Query.hs +2/−1
• src/Database/Haskey/Store/File.hs +6/−3
• src/Database/Haskey/Store/InMemory.hs +6/−3

@@ -0,0 +1,66 @@+module Main where++import Control.Concurrent.Async (async, wait)+import Control.Monad (void, replicateM)++import Data.BTree.Impure (toList, insertTree)+import Data.ByteString (ByteString)+import Data.Int (Int32)+import Data.Text.Encoding (encodeUtf8)+import qualified Data.Text as Text++import Database.Haskey.Alloc.Concurrent (ConcurrentDb,+                                         ConcurrentHandles,+                                         concurrentHandles,+                                         openConcurrentDb,+                                         createConcurrentDb,+                                         transact_,+                                         transactReadOnly,+                                         commit_)+import Database.Haskey.Store.File (FileStoreT, Files, newFileStore,+                                   runFileStoreT, defFileStoreConfig)++main :: IO ()+main = do+    store <- newFileStore+    db    <- openOrCreate store++    writers <- mapM (async . writer store db) [1..100]+    readers <- replicateM 100 $ async (reader store db)+    mapM_ wait writers+    mapM_ wait readers+    putStrLn "Done"+++writer :: Files FilePath+       -> ConcurrentDb Int32 ByteString+       -> Int32+       -> IO ()+writer store db i =+    runDatabase store $ transact_ tx db+  where+    bs = encodeUtf8 $ Text.pack (show i)++    tx tree = insertTree i bs tree >>= commit_++reader :: Files FilePath+       -> ConcurrentDb Int32 ByteString+       -> IO ()+reader files db = void $ replicateM 100 $ runDatabase files $+    transactReadOnly toList db++openOrCreate :: Files FilePath+             -> IO (ConcurrentDb Int32 ByteString)+openOrCreate store = runDatabase store $ do+    maybeDb <- openConcurrentDb handles+    case maybeDb of+        Nothing -> createConcurrentDb handles+        Just db -> return db++runDatabase :: Files FilePath+            -> FileStoreT FilePath m a+            -> m a+runDatabase files action = runFileStoreT action defFileStoreConfig files++handles :: ConcurrentHandles+handles = concurrentHandles "example-database.haskey"

@@ -1,5 +1,5 @@ name:                haskey-version:             0.1.0.0+version:             0.1.0.1 synopsis:            A transcatoinal, ACID compliant, embeddable key-value store. description:     Haskey is a transactional, ACID compliant, embeddable, scalable key-value@@ -135,6 +135,20 @@   default-language:    Haskell2010   ghc-options:         -Wall   hs-source-dirs:      tests++executable haskey-example+  hs-source-dirs:      example+  main-is:             Main.hs+  build-depends:+    base          >= 4.7 && <5,+    haskey,+    haskey-btree,+    async         >=2.1 && <3,+    bytestring    >=0.6 && <0.9 || >0.9 && <1,+    text          >=1.2 && <2++  ghc-options:         -threaded -rtsopts -with-rtsopts=-N -Wall+  default-language:    Haskell2010  source-repository head   type:     git

@@ -205,7 +205,7 @@ transactReadOnly :: (MonadIO m, MonadMask m, ConcurrentMetaStoreM m, Key key, Value val)                  => (forall n. (AllocReaderM n, MonadMask m) => Tree key val -> n a)                  -> ConcurrentDb key val -> m a-transactReadOnly act db =+transactReadOnly act db = withRLock (concurrentDbWriterLock db) $     bracket acquireMeta             releaseMeta $             \meta -> evalConcurrentT (act $ concurrentMetaTree meta)@@ -218,6 +218,7 @@     addOne (Just x) = Just $! x + 1     subOne Nothing = Nothing     subOne (Just 0) = Nothing+    subOne (Just 1) = Nothing     subOne (Just x) = Just $! x - 1      acquireMeta = liftIO . atomically $ do

@@ -180,6 +180,7 @@ checkFreePages (Unchecked v) = do     readers <- writerReaders <$> get     oldest  <- liftIO . atomically $ Map.lookupMinKey readers-    if maybe True (> fst v) oldest+    tx      <- writerTxId <$> get+    if maybe True (> fst v) oldest && fst v + 1 < tx         then return (Just v)         else return Nothing

@@ -252,7 +252,7 @@  -------------------------------------------------------------------------------- -instance (Applicative m, Monad m, MonadIO m, MonadThrow m) =>+instance (Applicative m, Monad m, MonadIO m, MonadCatch m) =>     ConcurrentMetaStoreM (FileStoreT FilePath m)   where     putConcurrentMeta fp meta = do@@ -270,8 +270,11 @@         len <- liftIO $ IO.getFileSize fh         liftIO $ IO.seek fh 0         bs <- liftIO $ readByteString fh (fromIntegral len)-        decodeM (concurrentMetaPage k v) bs >>= \case-            ConcurrentMetaPage meta -> return $ Just (coerce meta)+        handle handle' (Just <$> decodeM (concurrentMetaPage k v) bs) >>= \case+            Just (ConcurrentMetaPage meta) -> return $ Just (coerce meta)+            Nothing -> return Nothing+      where+        handle' (DecodeError _) = return Nothing  -------------------------------------------------------------------------------- 

@@ -199,7 +199,7 @@  -------------------------------------------------------------------------------- -instance (Applicative m, Monad m, MonadIO m, MonadThrow m) =>+instance (Applicative m, Monad m, MonadIO m, MonadCatch m) =>     ConcurrentMetaStoreM (MemoryStoreT FilePath m)   where     putConcurrentMeta h meta =@@ -209,8 +209,11 @@      readConcurrentMeta hnd k v = do         Just bs <- gets (M.lookup hnd >=> M.lookup 0)-        decodeM (concurrentMetaPage k v) bs >>= \case-            ConcurrentMetaPage meta -> return . Just $! coerce meta+        handle handle' (Just <$> decodeM (concurrentMetaPage k v) bs) >>= \case+            Just (ConcurrentMetaPage meta) -> return . Just $! coerce meta+            Nothing -> return Nothing+      where+        handle' (DecodeError _) = return Nothing  --------------------------------------------------------------------------------