sophia 0.1.1 → 0.1.2
raw patch · 4 files changed
+85/−27 lines, 4 filesdep +binarydep +criteriondep ~bindings-sophiadep ~bytestring
Dependencies added: binary, criterion
Dependency ranges changed: bindings-sophia, bytestring
Files
- Bench.hs +34/−0
- Database/Sophia.hs +16/−16
- Test.hs +5/−1
- sophia.cabal +30/−10
+ Bench.hs view
@@ -0,0 +1,34 @@+import Control.Exception (catch, SomeException(..))+import Control.Monad (forM_)+import Criterion.Main (bench, defaultMain)+import Data.Binary.Put (runPut, putWord32le)+import Data.Word (Word32)+import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as BSL+import qualified Database.Sophia as S+import qualified System.Directory as Dir++bsWord :: Word32 -> BS.ByteString+bsWord = BS.concat . BSL.toChunks . runPut . putWord32le++ignoreExceptions :: IO () -> IO ()+ignoreExceptions act = act `catch` \(SomeException _) -> return ()++dbAccess :: IO ()+dbAccess = do+ ignoreExceptions $ Dir.removeDirectoryRecursive "/tmp/sophia-test-db"++ S.withEnv $ \env -> do+ S.openDir env S.ReadWrite S.AllowCreation "/tmp/sophia-test-db"+ S.withDb env $ \db -> do+ let many = forM_ [1..10000]+ many $ \i -> S.setValue db (bsWord i) (bsWord (i*2))+ many $ \i -> S.hasValue db (bsWord i)+ many $ \i -> S.getValue db (bsWord i)+ many $ \i -> S.delValue db (bsWord i)++main :: IO ()+main =+ defaultMain+ [ bench "DB access" dbAccess+ ]
Database/Sophia.hs view
@@ -47,7 +47,7 @@ throwErrorIf h isErr mkErr action = do res <- action if isErr res- then E.throwIO . mkErr =<< peekCString =<< S.c'sp_error h+ then E.throwIO . mkErr =<< peekCString =<< S.unsafe'c'sp_error h else return res throwErrorIfNeg ::@@ -79,13 +79,13 @@ withEnv = E.bracket mkEnv destroyEnv where mkEnv = do- envPtr <- S.c'sp_env+ envPtr <- S.unsafe'c'sp_env when (envPtr == nullPtr) $ E.throwIO $ CreateEnvFailed throwErrorIfNotZero envPtr SetKeyComparisonFailed- (S.c'sp_set_key_comparison envPtr sp_compare_lexicographically nullPtr)+ (S.unsafe'c'sp_set_key_comparison envPtr sp_compare_lexicographically nullPtr) return $ Env envPtr- destroyEnv (Env cEnv) = S.c'sp_destroy cEnv+ destroyEnv (Env cEnv) = S.unsafe'c'sp_destroy cEnv data IOMode = ReadOnly | ReadWrite data AllowCreation = AllowCreation | DisallowCreation@@ -104,7 +104,7 @@ openDir :: Env -> IOMode -> AllowCreation -> FilePath -> IO () openDir (Env cEnv) ioMode allowCreation path = withCString path $ \cPath ->- throwErrorIfNotZero cEnv OpenDirFailed $ S.c'sp_dir cEnv flags cPath+ throwErrorIfNotZero cEnv OpenDirFailed $ S.unsafe'c'sp_dir cEnv flags cPath where flags = ioModeFlags ioMode .|. allowCreationFlags allowCreation @@ -115,8 +115,8 @@ withDb (Env cEnv) = E.bracket mkDb destroyDb where- destroyDb (Db cDb) = S.c'sp_destroy cDb- mkDb = Db <$> throwErrorIfNull cEnv OpenDbFailed (S.c'sp_open cEnv)+ destroyDb (Db cDb) = S.unsafe'c'sp_destroy cDb+ mkDb = Db <$> throwErrorIfNull cEnv OpenDbFailed (S.unsafe'c'sp_open cEnv) data HasValueFailed = HasValueFailed String deriving (Show, Typeable) instance E.Exception HasValueFailed@@ -132,7 +132,7 @@ do res <- throwErrorIfNeg cDb HasValueFailed $- S.c'sp_get cDb cKey keyLen nullPtr nullPtr+ S.unsafe'c'sp_get cDb cKey keyLen nullPtr nullPtr return $ res /= 0 data GetValueFailed = GetValueFailed String deriving (Show, Typeable)@@ -146,7 +146,7 @@ do res <- throwErrorIfNeg cDb GetValueFailed $- S.c'sp_get cDb cKey keyLen cPtrPtr cLenPtr+ S.unsafe'c'sp_get cDb cKey keyLen cPtrPtr cLenPtr if res == 0 then return Nothing else Just <$> do@@ -162,7 +162,7 @@ withByteString key $ \(cKey, keyLen) -> withByteString val $ \(cVal, valLen) -> throwErrorIfNotZero cDb SetValueFailed $- S.c'sp_set cDb cKey keyLen cVal valLen+ S.unsafe'c'sp_set cDb cKey keyLen cVal valLen data DelValueFailed = DelValueFailed String deriving (Show, Typeable) instance E.Exception DelValueFailed@@ -171,7 +171,7 @@ delValue (Db cDb) key = withByteString key $ \(cKey, keyLen) -> throwErrorIfNotZero cDb DelValueFailed $- S.c'sp_delete cDb cKey keyLen+ S.unsafe'c'sp_delete cDb cKey keyLen data Order = GT | GTE | LT | LTE @@ -191,9 +191,9 @@ mkCursor = fmap Cursor . throwErrorIfNull cDb CreateCursorFailed $- S.c'sp_cursor cDb (cOrder order) cKey keyLen+ S.unsafe'c'sp_cursor cDb (cOrder order) cKey keyLen delCursor (Cursor cursorPtr) =- S.c'sp_destroy cursorPtr+ S.unsafe'c'sp_destroy cursorPtr in E.bracket mkCursor delCursor act data FetchCursorFailed = FetchCursorFailed deriving (Show, Typeable)@@ -201,7 +201,7 @@ fetchCursor :: Cursor -> IO Bool fetchCursor (Cursor cCursor) = do- res <- S.c'sp_fetch cCursor+ res <- S.unsafe'c'sp_fetch cCursor -- Docs say fetch can't fail, and it doesn't fill error str, but -- it does return -1 in some cases (without err str) when (res < 0) $ E.throwIO FetchCursorFailed@@ -225,10 +225,10 @@ packCStringLen (castPtr cKey, fromIntegral keyLen) keyAtCursor :: Cursor -> IO ByteString-keyAtCursor = atCursor S.c'sp_key S.c'sp_keysize+keyAtCursor = atCursor S.unsafe'c'sp_key S.unsafe'c'sp_keysize valAtCursor :: Cursor -> IO ByteString-valAtCursor = atCursor S.c'sp_value S.c'sp_valuesize+valAtCursor = atCursor S.unsafe'c'sp_value S.unsafe'c'sp_valuesize fetchCursorAll :: Cursor -> IO [(ByteString, ByteString)] fetchCursorAll cursor = do
Test.hs view
@@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-}+import Control.Exception (catch, SomeException(..)) import Test.Tasty.HUnit ((@?=)) import qualified Database.Sophia as S import qualified System.Directory as Dir@@ -8,11 +9,14 @@ main :: IO () main = T.defaultMain tests +ignoreExceptions :: IO () -> IO ()+ignoreExceptions act = act `catch` \(SomeException _) -> return ()+ tests :: T.TestTree tests = T.testGroup "Unit tests" [ TUnit.testCase "Create DB, call some APIs" $ do- Dir.removeDirectoryRecursive "/tmp/sophia-test-db"+ ignoreExceptions $ Dir.removeDirectoryRecursive "/tmp/sophia-test-db" putStrLn "Phase 1" S.withEnv $ \env -> do
sophia.cabal view
@@ -1,5 +1,5 @@ name: sophia-version: 0.1.1+version: 0.1.2 category: Database author: Eyal Lotem <eyal.lotem+hackage@gmail.com>@@ -36,7 +36,7 @@ build-depends: base < 5,- bindings-sophia == 0.1.*,+ bindings-sophia >= 0.2, bytestring >= 0.9 include-dirs:@@ -49,7 +49,7 @@ -------------------------------------------------------------------------------- -test-suite main+test-suite main-test-suite default-language: Haskell2010 ghc-options: -Wall -O2@@ -60,13 +60,33 @@ main-is: Test.hs build-depends:- base < 5,- sophia,- bindings-sophia,- tasty == 0.3.*,- tasty-hunit == 0.2.*,- directory,- bytestring+ base < 5+ , sophia+ , bindings-sophia+ , tasty == 0.3.*+ , tasty-hunit == 0.2.*+ , directory+ , bytestring++--------------------------------------------------------------------------------++benchmark main-bench+ default-language: Haskell2010++ ghc-options: -Wall -O2+ if impl(ghc >= 6.8)+ ghc-options: -fwarn-tabs++ type: exitcode-stdio-1.0+ main-is: Bench.hs+ build-depends:+ base < 5+ , sophia+ , bindings-sophia+ , directory+ , bytestring >= 0.9+ , binary >= 0.5+ , criterion >= 0.8 --------------------------------------------------------------------------------