packages feed

tokyotyrant-haskell (empty) → 1.0

raw patch · 4 files changed

+456/−0 lines, 4 filesdep +basedep +bytestringdep +mtlsetup-changed

Dependencies added: base, bytestring, mtl

Files

+ LICENSE view
@@ -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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ src/Database/TokyoTyrant/FFI.hsc view
@@ -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. (<http://tokyocabinet.sourceforge.net/tyrantdoc/>)+--+--   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 <tcrdb.h>+#{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
+ tokyotyrant-haskell.cabal view
@@ -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. (<http://tokyocabinet.sourceforge.net/tyrantdoc/>)+Cabal-Version:  >= 1.6+Build-Type:     Simple+License:        BSD3+License-file:   LICENSE+Author:         Gregory Collins <gregory.collins@polarmobile.com>+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