module Database.TokyoTyrant.FFI
(
open
, close
, get
, put
, putKeep
, mget
, mput
, delete
, vanish
, fwmkeys
, Connection
) where
import Control.Monad.Error
import Data.List hiding (delete)
import Foreign.C
import Foreign.ForeignPtr
import Foreign.Marshal
import Foreign.Ptr
import Foreign.Storable
import Data.ByteString.Char8 (ByteString)
import qualified Data.ByteString.Char8 as B
open :: ByteString
-> Int
-> IO (Either String Connection)
open h p = do
runErrorT (open' h p)
close :: Connection -> IO ()
close db_ = withForeignPtr (unConnection db_) $ \db -> do
tcrdbclose db >> return ()
get :: Connection
-> ByteString
-> IO (Either String (Maybe ByteString))
get db_ key = runErrorT action
where
getval :: IO (Maybe ByteString)
getval = withForeignPtr (unConnection db_) $ \db ->
alloca $ \(p_sz::Ptr CInt) ->
B.useAsCStringLen key $ \(ckey,keylen) -> do
cval <- tcrdbget db ckey (toEnum keylen) p_sz
if cval == nullPtr then return Nothing
else do
sz <- peek p_sz
rbs <- B.packCStringLen (cval, fromEnum sz)
free cval
return $ Just rbs
action :: ErrorT String IO (Maybe ByteString)
action = do
mb <- liftIO getval
case mb of
Just _ -> return mb
Nothing -> ErrorT maybeFail
maybeFail :: IO (Either String (Maybe ByteString))
maybeFail = do
withForeignPtr (unConnection db_) $ \db -> do
ecode <- tcrdbecode db >>= return . TConstant
if ecode == errNoRec then
return $ Right Nothing
else do
cerr <- tcrdberrmsg (unTConstant ecode)
peekCString cerr >>= return . Left
put :: Connection
-> ByteString
-> ByteString
-> IO (Either String ())
put (Connection db_) key value = do
B.useAsCStringLen key $ \(ckey,keylen) ->
B.useAsCStringLen value $ \(cvalue,vallen) ->
withForeignPtr db_ $ \db -> do
rval <- tcrdbput db ckey (toEnum keylen) cvalue (toEnum vallen)
checkErr db rval
putKeep :: Connection
-> ByteString
-> ByteString
-> IO (Either String ())
putKeep (Connection db_) key value = do
B.useAsCStringLen key $ \(ckey,keylen) ->
B.useAsCStringLen value $ \(cvalue,vallen) ->
withForeignPtr db_ $ \db -> do
rval <- tcrdbputkeep db ckey (toEnum keylen) cvalue (toEnum vallen)
checkErr db rval
mget :: Connection
-> [ByteString]
-> IO (Either String [(ByteString,ByteString)])
mget (Connection db_) keys = withForeignPtr db_ $ \db -> do
lst <- bsListToTCList keys
res <- B.useAsCString "getlist" $ \s -> tcrdbmisc db s 0 lst
tclistdel lst
if res == nullPtr
then checkErr' [] db 0
else do
newlst <- tclistToBSList res
return . Right $ uninterleave newlst []
where
uninterleave (a:b:xs) l = uninterleave xs ((a,b):l)
uninterleave _ l = reverse l
mput :: Connection
-> [(ByteString, ByteString)]
-> IO (Either String ())
mput (Connection db_) kvps = withForeignPtr db_ $ \db -> do
lst <- bsListToTCList $ interleave kvps
res <- B.useAsCString "putlist" $ \s -> tcrdbmisc db s 0 lst
tclistdel lst
if res == nullPtr
then checkErr db 0
else return $ Right ()
where
interleave = concatMap (\(k,v) -> [k,v])
delete :: Connection
-> ByteString
-> IO (Either String ())
delete (Connection db_) key = do
B.useAsCStringLen key $ \(ckey,keylen) ->
withForeignPtr db_ $ \db -> do
rval <- tcrdbout db ckey (toEnum keylen)
checkErr db rval
vanish :: Connection -> IO (Either String ())
vanish (Connection db_) = withForeignPtr db_ $ \db -> do
ret <- tcrdbvanish db
checkErr db ret
fwmkeys :: Connection
-> ByteString
-> Int
-> IO (Either String [ByteString])
fwmkeys (Connection db_) key limit =
B.useAsCStringLen key $ \(ckey,keylen) ->
withForeignPtr db_ $ \db -> do
lst <- tcrdbfwmkeys db ckey (toEnum keylen) (toEnum (limit))
if lst == nullPtr
then checkErr' [] db 0
else tclistToBSList lst >>= return . Right
newtype Connection = Connection { unConnection :: ForeignPtr () }
open' :: ByteString -> Int -> ErrorT String IO Connection
open' host port = do
db <- liftIO $ tcrdbnew
if db == nullPtr then throwError "couldn't allocate DB object"
else return ()
result <- liftIO $ B.useAsCString host
$ \chost -> tcrdbopen db chost (toEnum port)
db' <- liftIO $ newForeignPtr p_tcrdbdel db
ErrorT $ checkErr db result
return $ Connection db'
tclistToBSList :: TCLIST -> IO [ByteString]
tclistToBSList lst = do
n <- tclistnum lst
l <- f 0 n []
tclistdel lst
return l
where
getN i = alloca $ \(p_sz :: Ptr CInt) -> do
cstr <- tclistval lst i p_sz
if cstr == nullPtr then
return B.empty
else do
sz <- peek p_sz
B.packCStringLen (cstr, fromEnum sz)
f i n l | i >= n = return $ reverse l
| otherwise = do
bs <- getN i
f (i+1) n (bs:l)
bsListToTCList :: [ByteString] -> IO TCLIST
bsListToTCList strs = do
lst <- tclistnew2 . toEnum $ length strs
mapM_ (doOne lst) strs
return lst
where
doOne lst s =
B.useAsCStringLen s $ \(cstr,len) -> do
tclistpush lst cstr (toEnum len)
checkErr :: ConnectionPtr -> CBool -> IO (Either String ())
checkErr db res =
if res == 0
then do
ecode <- liftIO $ tcrdbecode db
cerr <- liftIO $ tcrdberrmsg ecode
str <- liftIO $ peekCString cerr
return $ Left str
else
return $ Right ()
checkErr' :: a -> ConnectionPtr -> CBool -> IO (Either String a)
checkErr' v db res =
if res == 0
then do
ecode <- liftIO $ tcrdbecode db
cerr <- liftIO $ tcrdberrmsg ecode
str <- liftIO $ peekCString cerr
return $ Left str
else
return $ Right v
type ConnectionPtr = Ptr ()
type CBool = CInt
type TCLIST = Ptr ()
newtype TConstant = TConstant { unTConstant :: CInt }
deriving (Eq, Show)
errSuccess :: TConstant
errSuccess = TConstant 0
errInvalid :: TConstant
errInvalid = TConstant 1
errNoHost :: TConstant
errNoHost = TConstant 2
errRefused :: TConstant
errRefused = TConstant 3
errSend :: TConstant
errSend = TConstant 4
errRecv :: TConstant
errRecv = TConstant 5
errKeep :: TConstant
errKeep = TConstant 6
errNoRec :: TConstant
errNoRec = TConstant 7
errMisc :: TConstant
errMisc = TConstant 9999
foreign import ccall unsafe "tcutil.h tclistdel"
tclistdel :: TCLIST -> IO ()
foreign import ccall unsafe "tcutil.h tclistnew2"
tclistnew2 :: CInt -> IO TCLIST
foreign import ccall unsafe "tcutil.h tclistpush"
tclistpush :: TCLIST -> CString -> CInt -> IO ()
foreign import ccall unsafe "tcutil.h tclistnum"
tclistnum :: TCLIST -> IO CInt
foreign import ccall unsafe "tcutil.h tclistval"
tclistval :: TCLIST -> CInt -> Ptr CInt -> IO CString
foreign import ccall unsafe "tcrdb.h tcrdberrmsg"
tcrdberrmsg :: CInt -> IO CString
foreign import ccall unsafe "tcrdb.h tcrdbnew"
tcrdbnew :: IO ConnectionPtr
foreign import ccall unsafe "tcrdb.h &tcrdbdel"
p_tcrdbdel :: FunPtr (ConnectionPtr -> IO ())
foreign import ccall unsafe "tcrdb.h tcrdbecode"
tcrdbecode :: ConnectionPtr -> IO CInt
foreign import ccall unsafe "tcrdb.h tcrdbopen"
tcrdbopen :: ConnectionPtr -> CString -> CInt -> IO CBool
foreign import ccall unsafe "tcrdb.h tcrdbclose"
tcrdbclose :: ConnectionPtr -> IO CBool
foreign import ccall unsafe "tcrdb.h tcrdbput"
tcrdbput :: ConnectionPtr -> CString -> CInt -> CString -> CInt -> IO CBool
foreign import ccall unsafe "tcrdb.h tcrdbputkeep"
tcrdbputkeep :: ConnectionPtr -> CString -> CInt -> CString -> CInt -> IO CBool
foreign import ccall unsafe "tcrdb.h tcrdbout"
tcrdbout :: ConnectionPtr -> CString -> CInt -> IO CBool
foreign import ccall unsafe "tcrdb.h tcrdbget"
tcrdbget :: ConnectionPtr -> CString -> CInt -> Ptr CInt -> IO CString
foreign import ccall unsafe "tcrdb.h tcrdbfwmkeys"
tcrdbfwmkeys :: ConnectionPtr -> CString -> CInt -> CInt -> IO TCLIST
foreign import ccall unsafe "tcrdb.h tcrdbvanish"
tcrdbvanish :: ConnectionPtr -> IO CBool
foreign import ccall unsafe "tcrdb.h tcrdbmisc"
tcrdbmisc :: ConnectionPtr -> CString -> CInt -> TCLIST -> IO TCLIST