packages feed

sophia (empty) → 0.1

raw patch · 8 files changed

+433/−0 lines, 8 filesdep +basedep +bindings-sophiadep +bytestringsetup-changed

Dependencies added: base, bindings-sophia, bytestring, directory, sophia, tasty, tasty-hunit

Files

+ Database/Sophia.hs view
@@ -0,0 +1,242 @@+{-# LANGUAGE DeriveDataTypeable #-}+module Database.Sophia+  ( withEnv+    , CreateEnvFailed(..), SetKeyComparisonFailed(..)+    , Env++  , IOMode(..), AllowCreation(..)+  , openDir , OpenDirFailed(..)+  , withDb  , OpenDbFailed(..)+    , Db+  , hasValue, HasValueFailed(..)+  , getValue, GetValueFailed(..)+  , setValue, SetValueFailed(..)+  , delValue, DelValueFailed(..)++  , Order(..)+  , withCursor+    , CreateCursorFailed(..)+    , Cursor++  , fetchCursor, FetchCursorFailed(..)+  , keyAtCursor, valAtCursor, AtCursorFailed(..)++  -- Convenience wrapper:+  , fetchCursorAll+  ) where++import Prelude hiding (Ordering(..))++import Control.Applicative (Applicative(..), (<$>))+import Control.Monad (void, when)+import Data.Bits ((.|.))+import Data.ByteString (ByteString, packCStringLen)+import Data.ByteString.Unsafe (unsafeUseAsCStringLen, unsafePackMallocCStringLen)+import Data.Typeable (Typeable)+import Database.Sophia.Types+import Foreign.C.String (withCString, peekCString)+import Foreign.C.Types (CInt, CUInt, CSize(..), CChar)+import Foreign.Marshal.Alloc (alloca)+import Foreign.Ptr (Ptr, FunPtr, nullPtr, castPtr)+import Foreign.Storable (peek)+import qualified Bindings.Sophia as S+import qualified Control.Exception as E++throwErrorIf ::+  E.Exception exc => S.Handle -> (a -> Bool) -> (String -> exc) -> IO a -> IO a+throwErrorIf h isErr mkErr action = do+  res <- action+  if isErr res+    then E.throwIO . mkErr =<< peekCString =<< S.c'sp_error h+    else return res++throwErrorIfNeg ::+  E.Exception exc =>+  S.Handle -> (String -> exc) -> IO CInt -> IO CInt+throwErrorIfNeg h mkErr act = throwErrorIf h (< 0) mkErr act++throwErrorIfNotZero ::+  E.Exception exc =>+  S.Handle -> (String -> exc) -> IO CInt -> IO ()+throwErrorIfNotZero h mkErr act = void $ throwErrorIf h (/= 0) mkErr act++throwErrorIfNull ::+  E.Exception exc =>+  S.Handle -> (String -> exc) -> IO (Ptr a) -> IO (Ptr a)+throwErrorIfNull h mkErr = throwErrorIf h (nullPtr ==) mkErr++-- Likely indicates a memory allocation failure:+data CreateEnvFailed = CreateEnvFailed deriving (Show, Typeable)+instance E.Exception CreateEnvFailed++data SetKeyComparisonFailed = SetKeyComparisonFailed String deriving (Show, Typeable)+instance E.Exception SetKeyComparisonFailed++foreign import ccall "lexical_cmp.h &sp_compare_lexicographically"+   sp_compare_lexicographically :: FunPtr (Ptr CChar -> CSize -> Ptr CChar -> CSize -> Ptr () -> IO CInt)++withEnv :: (Env -> IO a) -> IO a+withEnv = E.bracket mkEnv destroyEnv+  where+    mkEnv = do+      envPtr <- S.c'sp_env+      when (envPtr == nullPtr) $+        E.throwIO $ CreateEnvFailed+      throwErrorIfNotZero envPtr SetKeyComparisonFailed+        (S.c'sp_set_key_comparison envPtr sp_compare_lexicographically nullPtr)+      return $ Env envPtr+    destroyEnv (Env cEnv) = S.c'sp_destroy cEnv++data IOMode = ReadOnly | ReadWrite+data AllowCreation = AllowCreation | DisallowCreation++ioModeFlags :: IOMode -> S.Flags+ioModeFlags ReadOnly = S.c'SPO_RDONLY+ioModeFlags ReadWrite = S.c'SPO_RDWR++allowCreationFlags :: AllowCreation -> S.Flags+allowCreationFlags AllowCreation = S.c'SPO_CREAT+allowCreationFlags DisallowCreation = 0++data OpenDirFailed = OpenDirFailed String deriving (Show, Typeable)+instance E.Exception OpenDirFailed++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+  where+    flags = ioModeFlags ioMode .|. allowCreationFlags allowCreation++data OpenDbFailed = OpenDbFailed String deriving (Show, Typeable)+instance E.Exception OpenDbFailed++withDb :: Env -> (Db -> IO a) -> IO a+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)++data HasValueFailed = HasValueFailed String deriving (Show, Typeable)+instance E.Exception HasValueFailed++withByteString :: ByteString -> ((S.Key, CSize) -> IO a) -> IO a+withByteString bs f =+  unsafeUseAsCStringLen bs $ \(cKey, keyLen) ->+  f (castPtr cKey, fromIntegral keyLen)++hasValue :: Db -> ByteString -> IO Bool+hasValue (Db cDb) key =+  withByteString key $ \(cKey, keyLen) ->+  do+    res <-+      throwErrorIfNeg cDb HasValueFailed $+      S.c'sp_get cDb cKey keyLen nullPtr nullPtr+    return $ res /= 0++data GetValueFailed = GetValueFailed String deriving (Show, Typeable)+instance E.Exception GetValueFailed++getValue :: Db -> ByteString -> IO (Maybe ByteString)+getValue (Db cDb) key =+  withByteString key $ \(cKey, keyLen) ->+  alloca $ \cPtrPtr ->+  alloca $ \cLenPtr ->+  do+    res <-+      throwErrorIfNeg cDb GetValueFailed $+      S.c'sp_get cDb cKey  keyLen cPtrPtr cLenPtr+    if res == 0+      then return Nothing+      else Just <$> do+        cPtr <- peek cPtrPtr+        cLen <- peek cLenPtr+        unsafePackMallocCStringLen (castPtr cPtr, fromIntegral cLen)++data SetValueFailed = SetValueFailed String deriving (Show, Typeable)+instance E.Exception SetValueFailed++setValue :: Db -> ByteString -> ByteString -> IO ()+setValue (Db cDb) key val =+  withByteString key $ \(cKey, keyLen) ->+  withByteString val $ \(cVal, valLen) ->+  throwErrorIfNotZero cDb SetValueFailed $+  S.c'sp_set cDb cKey keyLen cVal valLen++data DelValueFailed = DelValueFailed String deriving (Show, Typeable)+instance E.Exception DelValueFailed++delValue :: Db -> ByteString -> IO ()+delValue (Db cDb) key =+  withByteString key $ \(cKey, keyLen) ->+  throwErrorIfNotZero cDb DelValueFailed $+  S.c'sp_delete cDb cKey keyLen++data Order = GT | GTE | LT | LTE++data CreateCursorFailed = CreateCursorFailed String deriving (Show, Typeable)+instance E.Exception CreateCursorFailed++cOrder :: Order -> CUInt+cOrder GT  = S.c'SPGT+cOrder LT  = S.c'SPLT+cOrder GTE = S.c'SPGTE+cOrder LTE = S.c'SPLTE++withCursor :: Db -> Order -> ByteString -> (Cursor -> IO a) -> IO a+withCursor (Db cDb) order key act =+  withByteString key $ \(cKey, keyLen) ->+  let+    mkCursor =+      fmap Cursor .+      throwErrorIfNull cDb CreateCursorFailed $+      S.c'sp_cursor cDb (cOrder order) cKey keyLen+    delCursor (Cursor cursorPtr) =+      S.c'sp_destroy cursorPtr+  in E.bracket mkCursor delCursor act++data FetchCursorFailed = FetchCursorFailed deriving (Show, Typeable)+instance E.Exception FetchCursorFailed++fetchCursor :: Cursor -> IO Bool+fetchCursor (Cursor cCursor) = do+  res <- S.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+  return (res /= 0)++data AtCursorFailed = AtCursorFailed deriving (Show, Typeable)+instance E.Exception AtCursorFailed++atCursor ::+  (S.Cursor -> IO (Ptr ())) ->+  (S.Cursor -> IO CSize) ->+  Cursor -> IO ByteString+atCursor cGetStr cGetLen (Cursor cCursor) = do+  cKey <- cGetStr cCursor+  keyLen <- cGetLen cCursor+  when (nullPtr == cKey  ) $ E.throwIO AtCursorFailed+  when (0       == keyLen) $ E.throwIO AtCursorFailed+  -- Must use O(N) copy here? Not sure what the memory semantics of+  -- sp_cursor/sp_fetch/sp_key/sp_destroy are, so for now the answer+  -- is STAY SAFE:+  packCStringLen (castPtr cKey, fromIntegral keyLen)++keyAtCursor :: Cursor -> IO ByteString+keyAtCursor = atCursor S.c'sp_key S.c'sp_keysize++valAtCursor :: Cursor -> IO ByteString+valAtCursor = atCursor S.c'sp_value S.c'sp_valuesize++fetchCursorAll :: Cursor -> IO [(ByteString, ByteString)]+fetchCursorAll cursor = do+  more <- fetchCursor cursor+  if more+    then do+      pair <- (,) <$> keyAtCursor cursor <*> valAtCursor cursor+      rest <- fetchCursorAll cursor+      return $ pair : rest+    else+      return []
+ Database/Sophia/Types.hs view
@@ -0,0 +1,7 @@+module Database.Sophia.Types where++import qualified Bindings.Sophia as S++newtype Db = Db { unDb :: S.Db }+newtype Env = Env { unEnv :: S.Env }+newtype Cursor = Cursor { unCursor :: S.Cursor }
+ LICENSE view
@@ -0,0 +1,26 @@+Copyright Eyal Lotem <eyal.lotem+hackage@gmail.com> 2009-2013++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.++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.
+ Setup.hs view
@@ -0,0 +1,6 @@+module Main (main) where++import Distribution.Simple (defaultMain)++main :: IO ()+main = defaultMain
+ Test.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE OverloadedStrings #-}+import Test.Tasty.HUnit ((@?=))+import qualified Database.Sophia as S+import qualified System.Directory as Dir+import qualified Test.Tasty as T+import qualified Test.Tasty.HUnit as TUnit++main :: IO ()+main = T.defaultMain tests++tests :: T.TestTree+tests =+  T.testGroup "Unit tests"+  [ TUnit.testCase "Create DB, call some APIs" $ do+      Dir.removeDirectoryRecursive "/tmp/sophia-test-db"++      putStrLn "Phase 1"+      S.withEnv $ \env -> do+        S.openDir env S.ReadWrite S.AllowCreation "/tmp/sophia-test-db"+        S.withDb env $ \db -> do+          TUnit.assertBool "Key must not exist" . not =<< S.hasValue db "Key"+          do+            res <- S.getValue db "Key"+            res @?= Nothing++          putStrLn "Phase 2"+          S.setValue db "Key" "Val"+          TUnit.assertBool "Key2 must not exist" . not =<< S.hasValue db "Key2"+          TUnit.assertBool "Key must exist" =<< S.hasValue db "Key"+          do+            res <- S.getValue db "Key"+            res @?= Just "Val"++          putStrLn "Phase 3"+          S.setValue db "A" "foo"+          S.setValue db "Z" "bar"++          S.withCursor db S.GTE "A" $ \cursor -> do+            res <- S.fetchCursorAll cursor+            res @?=+              [ ("A", "foo")+              , ("Key", "Val")+              , ("Z", "bar")+              ]++          putStrLn "Phase 4"+          putStrLn "Deleting \"Key\""+          S.delValue db "Key"+          putStrLn "Done deleting"+          TUnit.assertBool "Key must not exist" . not =<< S.hasValue db "Key"++          putStrLn "Done!"+  ]
+ cbits/lexical_cmp.c view
@@ -0,0 +1,15 @@+#include "lexical_cmp.h"+#include <string.h>++#define MIN(x, y)  ((x) < (y) ? (x) : (y))++int sp_compare_lexicographically(+    char *a, size_t asz, char *b, size_t bsz, void *arg)+{+    register int rc = memcmp(a, b, MIN(asz, bsz));+    if(0 == rc) {+        if(asz == bsz) return 0;+        return asz > bsz ? 1 : -1;+    }+    return (rc > 0 ? 1 : -1);+}
+ cbits/lexical_cmp.h view
@@ -0,0 +1,9 @@+#ifndef __lexical_cmp_h_+#define __lexical_cmp_h_++#include <sys/types.h>          /* size_t */++int sp_compare_lexicographically(+    char *a, size_t asz, char *b, size_t bsz, void *arg);++#endif
+ sophia.cabal view
@@ -0,0 +1,75 @@+name:         sophia+version:      0.1+category:     Database++author:       Eyal Lotem <eyal.lotem+hackage@gmail.com>+maintainer:   Eyal Lotem <eyal.lotem+hackage@gmail.com>++license:      BSD3+license-file: LICENSE++synopsis:     Bindings to Sophia library+description:+  Bindings to <http://sphia.org/ sophia>, an open source, modern, fast+  key/value store.++cabal-version: >= 1.10+build-type:    Simple++extra-source-files:+  cbits/lexical_cmp.h++--------------------------------------------------------------------------------++library+  default-language: Haskell2010++  ghc-options: -Wall -O2+  if impl(ghc >= 6.8)+    ghc-options: -fwarn-tabs++  exposed-modules:+    Database.Sophia++  other-modules:+    Database.Sophia.Types++  build-depends:+    base             < 5,+    bindings-sophia == 0.1.*,+    bytestring      >= 0.10.2++  include-dirs:+    cbits++  c-sources:+    cbits/lexical_cmp.c++  cc-options: -g -Wall -O2++--------------------------------------------------------------------------------++test-suite main+  default-language: Haskell2010++  ghc-options: -Wall -O2+  if impl(ghc >= 6.8)+    ghc-options: -fwarn-tabs++  type: exitcode-stdio-1.0++  main-is: Test.hs+  build-depends:+    base             < 5,+    sophia          == 0.1.*,+    bindings-sophia == 0.1.*,+    tasty           == 0.3.*,+    tasty-hunit     == 0.2.*,+    directory       >= 1.2,+    bytestring      >= 0.10.2++--------------------------------------------------------------------------------++source-repository head+  type:     git+  location: https://github.com/Peaker/hssophia.git