diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,26 @@ +Copyright (c) 2009, Polar Mobile (http://www.polarmobile.com/) +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. + + * Neither the name of "Polar Mobile" nor the names of its contributors may + be used to endorse or promote products derived from this software without + specific prior written permission. + +THIS SOFTWARE IS PROVIDED "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 POLAR MOBILE +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/src/Database/TokyoTyrant/FFI.hsc b/src/Database/TokyoTyrant/FFI.hsc new file mode 100644 --- /dev/null +++ b/src/Database/TokyoTyrant/FFI.hsc @@ -0,0 +1,398 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ForeignFunctionInterface #-} +{-# LANGUAGE EmptyDataDecls #-} + +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + + +------------------------------------------------------------------------------ +-- | This module provides a thin FFI binding to the libtokyotyrant C library +-- shipped with Mikio Hirabayashi's Tokyo +-- Tyrant. () +-- +-- It's intended to be imported qualified, e.g.: +-- @ +-- import qualified Database.TokyoTyrant.FFI as TT +-- @ +------------------------------------------------------------------------------ + +module Database.TokyoTyrant.FFI + ( + -- * Opening/closing connections + open + , close + + -- * Fetching/storing single values from the store + , get + , put + , putKeep + + -- * Fetching/storing multiple values from the store + , mget + , mput + + -- * Deleting keys + , delete + , vanish + + -- * Key prefix search + , fwmkeys + + -- * Types + , 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 a connection to Tokyo Tyrant. +-- +open :: ByteString -- ^ hostname + -> Int -- ^ port + -> IO (Either String Connection) +open h p = do + runErrorT (open' h p) + + + +------------------------------------------------------------------------------ +-- | Close a connection to Tokyo Tyrant +-- +close :: Connection -> IO () +close db_ = withForeignPtr (unConnection db_) $ \db -> do + tcrdbclose db >> return () + + +------------------------------------------------------------------------------ +-- | Get a value from the database +-- +get :: Connection -- ^ connection + -> ByteString -- ^ key + -> 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 + + +------------------------------------------------------------------------------ +-- | Store a value in the database (destructive, overwrites any existing +-- value) +-- +put :: Connection -- ^ connection + -> ByteString -- ^ key + -> ByteString -- ^ value + -> 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 + + +------------------------------------------------------------------------------ +-- | Store a value in the database (non-destructive, does nothing if the key +-- already exists) +-- +putKeep :: Connection -- ^ connection + -> ByteString -- ^ key + -> ByteString -- ^ value + -> 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 + + +------------------------------------------------------------------------------ +-- | Get multiple values from the database. On success, returns `Right kvps`. +-- +mget :: Connection -- ^ connection to DB + -> [ByteString] -- ^ list of keys to fetch + -> 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 + + +------------------------------------------------------------------------------ +-- | Put multiple values to the database. +-- +mput :: Connection -- ^ connection to DB + -> [(ByteString, ByteString)] -- ^ list of key-value pairs + -> 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 a value from the DB +-- +delete :: Connection -- ^ connection + -> ByteString -- ^ key + -> 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 + + +------------------------------------------------------------------------------ +-- | Delete all KVPs in the database. +vanish :: Connection -> IO (Either String ()) +vanish (Connection db_) = withForeignPtr db_ $ \db -> do + ret <- tcrdbvanish db + checkErr db ret + + +------------------------------------------------------------------------------ +-- | Search keys by prefix. Returns a list of matching keys. +-- +fwmkeys :: Connection -- ^ connection to DB + -> ByteString -- ^ key prefix + -> Int -- ^ max # of returned keys; negative numbers + -- mean "no limit" + -> 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 + + + +------------------------------------------------------------------------------ +-- | A Tokyo Tyrant connection type. Wraps the `TCRDB` type from the C +-- library. +newtype Connection = Connection { unConnection :: ForeignPtr () } + + +------------------------------------------------------------------------------ +-- utility functions +------------------------------------------------------------------------------ + +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 + + + +------------------------------------------------------------------------------ +-- Types +------------------------------------------------------------------------------ +type ConnectionPtr = Ptr () +type CBool = CInt +type TCLIST = Ptr () + +newtype TConstant = TConstant { unTConstant :: CInt } + deriving (Eq, Show) + +#include +#{enum TConstant, TConstant + , errSuccess = TTESUCCESS + , errInvalid = TTEINVALID + , errNoHost = TTENOHOST + , errRefused = TTEREFUSED + , errSend = TTESEND + , errRecv = TTERECV + , errKeep = TTEKEEP + , errNoRec = TTENOREC + , errMisc = TTEMISC } + + +------------------------------------------------------------------------------ +-- FFI: list stuff (from libtokyocabinet) +------------------------------------------------------------------------------ + +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 + + +------------------------------------------------------------------------------ +-- FFI: tyrant stuff (libtokyotyrant) +------------------------------------------------------------------------------ + +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 diff --git a/tokyotyrant-haskell.cabal b/tokyotyrant-haskell.cabal new file mode 100644 --- /dev/null +++ b/tokyotyrant-haskell.cabal @@ -0,0 +1,30 @@ +Name: tokyotyrant-haskell +Version: 1.0 +Synopsis: FFI bindings to libtokyotyrant +Description: This package provides a thin FFI binding to the libtokyotyrant + C library shipped with Mikio Hirabayashi's Tokyo + Tyrant. () +Cabal-Version: >= 1.6 +Build-Type: Simple +License: BSD3 +License-file: LICENSE +Author: Gregory Collins +Homepage: http://www.polarmobile.com/ +Copyright: (c) 2009 Polar Mobile +Category: Database +Stability: provisional + +Source-Repository head + type: git + location: git://github.com/gregorycollins/tokyotyrant-haskell.git + +Library + hs-source-dirs: src + ghc-options: -Wall -funbox-strict-fields + exposed-modules: Database.TokyoTyrant.FFI + extra-libraries: tokyocabinet, tokyotyrant + + build-depends: + base >= 4 && < 5, + bytestring, + mtl