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(..)
, 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)
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, free)
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.unsafe'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
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.unsafe'c'sp_env
when (envPtr == nullPtr) $
E.throwIO $ CreateEnvFailed
throwErrorIfNotZero envPtr SetKeyComparisonFailed
(S.unsafe'c'sp_set_key_comparison envPtr sp_compare_lexicographically nullPtr)
return $ Env envPtr
destroyEnv (Env cEnv) = S.unsafe'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.unsafe'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.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
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.unsafe'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.unsafe'c'sp_get cDb cKey keyLen cPtrPtr cLenPtr
if res == 0
then return Nothing
else Just <$> do
cPtr <- peek cPtrPtr
cLen <- peek cLenPtr
packCStringLen (castPtr cPtr, fromIntegral cLen) <* free cPtr
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.unsafe'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.unsafe'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.unsafe'c'sp_cursor cDb (cOrder order) cKey keyLen
delCursor (Cursor cursorPtr) =
S.unsafe'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.unsafe'c'sp_fetch cCursor
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
packCStringLen (castPtr cKey, fromIntegral keyLen)
keyAtCursor :: Cursor -> IO ByteString
keyAtCursor = atCursor S.unsafe'c'sp_key S.unsafe'c'sp_keysize
valAtCursor :: Cursor -> IO ByteString
valAtCursor = atCursor S.unsafe'c'sp_value S.unsafe'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 []