diff --git a/Database/TokyoCabinet.hs b/Database/TokyoCabinet.hs new file mode 100644 --- /dev/null +++ b/Database/TokyoCabinet.hs @@ -0,0 +1,367 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +module Database.TokyoCabinet + ( + -- $doc + TCM + , runTCM + , OpenMode(..) + , TCDB(..) + , H.HDB + , F.FDB + , BDB + -- * Error Code + , E.ECODE(..) + , E.errmsg + ) where + +import Control.Monad.Trans (MonadIO) + +import Database.TokyoCabinet.Storable +import Database.TokyoCabinet.FDB.Key (ID, toID) +import qualified Database.TokyoCabinet.HDB as H +import qualified Database.TokyoCabinet.FDB as F +import qualified Database.TokyoCabinet.BDB as B +import qualified Database.TokyoCabinet.BDB.Cursor as C +import qualified Database.TokyoCabinet.Error as E + +import Data.Int + +-- $doc +-- Basic Usage (sample code) +-- +-- @ +-- import Database.TokyoCabinet +-- import Data.ByteString.Char8 +-- @ +-- +-- @ +-- putsample :: String -> [(ByteString, ByteString)] -> TCM Bool +-- putsample file kv = +-- do tc <- new :: TCM HDB -- alternatively you can use BDB or FDB +-- open tc file [OWRITER, OCREAT] +-- mapM (uncurry $ put tc) kv +-- close tc +-- @ +-- +-- @ +-- getsample :: String -> ByteString -> TCM (Maybe ByteString) +-- getsample file key = +-- do tc <- new :: TCM HDB -- alternatively you can use BDB or FDB +-- open tc file [OREADER] +-- val <- get tc key +-- close tc +-- return val +-- @ +-- +-- @ +-- main = runTCM (do putsample \"foo.tch\" [(pack \"foo\", pack \"bar\")] +-- getsample \"foo.tch\" (pack \"foo\")) >>= +-- maybe (return ()) (putStrLn . show) +-- @ +-- + +-- | Tokyo Cabinet related computation. Wrap of IO. +newtype TCM a = + TCM { -- | Unwrap TCM. + runTCM :: IO a + } deriving (Monad, MonadIO) + +-- | Represent open mode for `open' function. +data OpenMode = OREADER | + OWRITER | + OCREAT | + OTRUNC | + ONOLCK | + OLCKNB + deriving (Eq, Ord, Show) + +-- | Type class that abstract Tokyo Cabinet database. +class TCDB a where + -- | Create a database object. + new :: TCM a + + -- | Free object resource forcibly. + delete :: a -> TCM () + + -- | Open a database file. + open :: a -- ^ database object + -> String -- ^ path to database file + -> [OpenMode] -- ^ open mode + -> TCM Bool -- ^ if successful, the return value is True + + -- | Close the database file. If successful, the return value is True + close :: a -> TCM Bool + + -- | Store a record. + put :: (Storable k, Storable v) => + a -- ^ database object + -> k -- ^ key + -> v -- ^ value + -> TCM Bool -- ^ if successful, the return value is True + + -- | Store a new recoed. If a record with the same key exists + -- in the database, this function has no effect. + putkeep :: (Storable k, Storable v) => + a -- ^ database object + -> k -- ^ key + -> v -- ^ value + -> TCM Bool -- ^ if successful, the return value is True + + -- | Concatenate a value at the end of the existing record. + putcat :: (Storable k, Storable v) => + a -- ^ database object + -> k -- ^ key + -> v -- ^ value + -> TCM Bool -- ^ if successful, the return value is True + + -- | Retrieve a record. + get :: (Storable k, Storable v) => + a -- ^ database object + -> k -- ^ key + -> TCM (Maybe v) -- ^ If successful, the return value is the + -- value of the corresponding record wrapped + -- by `Just', else, Nothing is returned. + + -- | Remove a record. + out :: (Storable k) => + a -- ^ database object + -> k -- ^ key + -> TCM Bool -- ^ if successful, the return value is True + + -- | Get the size of the value of a record. + vsiz :: (Storable k) => + a -- ^ database object + -> k -- ^ key + -> TCM (Maybe Int) -- ^ If successful, the return value + -- is the size of the value of the + -- corresponding record wrapped by + -- `Just', else, it is Nothing. + + -- | Initialize the iterator. If successful, the return value is True. + iterinit :: a -> TCM Bool + + -- | Get the next key of the iterator. If successful, the return + -- value is the next key wrapped by `Just', else, it is Nothing. + iternext :: (Storable v) => a -> TCM (Maybe v) + + -- | Get forward matching keys. + fwmkeys :: (Storable k, Storable v) => + a -- ^ database object + -> k -- ^ search string + -> Int -- ^ the maximum number of keys to be fetched + -> TCM [v] -- ^ result keys + + -- | Add an integer to a record. + addint :: (Storable k) => + a -- ^ database object + -> k -- ^ key + -> Int -- ^ the addtional value + -> TCM (Maybe Int) -- ^ If the corresponding record + -- exists, the value is treated as an + -- integer and is added to. If no + -- record corresponds, a new record + -- of the additional value is stored. + + -- | Add a real number to a record. + adddouble :: (Storable k) => + a -- ^ database object + -> k -- ^ key + -> Double -- ^ the additional value + -> TCM (Maybe Double) -- ^ If the corresponding record + -- exists, the value is treated as + -- a real number and is added + -- to. If no record corresponds, a + -- new record of the additional + -- value is stored. + + -- | Synchronize updated contents with the file and the device. + -- If successful, the return value is True. + sync :: a -> TCM Bool + + -- | Remove all records. If successful, the return value is True. + vanish :: a -> TCM Bool + + -- | Copy the database file. + copy :: a -- ^ database object + -> String -- ^ path of the destination file + -> TCM Bool -- ^ If successful, the return value is True. + + -- | Get the path of the database file. + path :: a -> TCM (Maybe String) + + -- | Get the number of records. + rnum :: a -> TCM Int64 + + -- | Get the size of the database file. + size :: a -> TCM Int64 + + -- | Get the last happened error code. + ecode :: a -> TCM E.ECODE + + -- | Get the default extension for specified database object. + defaultExtension :: a -> String + +openModeToHOpenMode :: OpenMode -> H.OpenMode +openModeToHOpenMode OREADER = H.OREADER +openModeToHOpenMode OWRITER = H.OWRITER +openModeToHOpenMode OCREAT = H.OCREAT +openModeToHOpenMode OTRUNC = H.OTRUNC +openModeToHOpenMode ONOLCK = H.ONOLCK +openModeToHOpenMode OLCKNB = H.OLCKNB + +lift :: (a -> IO b) -> a -> TCM b +lift = (TCM .) + +lift2 :: (a -> b -> IO c) -> a -> b -> TCM c +lift2 f x y = TCM $ f x y + +lift3 :: (a -> b -> c -> IO d) -> a -> b -> c -> TCM d +lift3 f x y z = TCM $ f x y z + +instance TCDB H.HDB where + new = TCM H.new + delete = lift H.delete + open tc name mode = TCM $ H.open tc name (map openModeToHOpenMode mode) + close = lift H.close + put = lift3 H.put + putkeep = lift3 H.putkeep + putcat = lift3 H.putcat + get = lift2 H.get + out = lift2 H.out + vsiz = lift2 H.vsiz + iterinit = lift H.iterinit + iternext = lift H.iternext + fwmkeys = lift3 H.fwmkeys + addint = lift3 H.addint + adddouble = lift3 H.adddouble + sync = lift H.sync + vanish = lift H.vanish + copy = lift2 H.copy + path = lift H.path + rnum = lift H.rnum + size = lift H.fsiz + ecode = lift H.ecode + defaultExtension = const ".tch" + +openModeToBOpenMode :: OpenMode -> B.OpenMode +openModeToBOpenMode OREADER = B.OREADER +openModeToBOpenMode OWRITER = B.OWRITER +openModeToBOpenMode OCREAT = B.OCREAT +openModeToBOpenMode OTRUNC = B.OTRUNC +openModeToBOpenMode ONOLCK = B.ONOLCK +openModeToBOpenMode OLCKNB = B.OLCKNB + +data BDB = BDB { unTCBDB :: B.BDB + , unTCBDBCUR :: C.BDBCUR } + +liftB :: (B.BDB -> IO a) -> BDB -> TCM a +liftB f x = TCM $ f (unTCBDB x) + +liftB2 :: (B.BDB -> a -> IO b) -> BDB -> a -> TCM b +liftB2 f x y = TCM $ f (unTCBDB x) y + +liftB3 :: (B.BDB -> a -> b -> IO c) -> BDB -> a -> b -> TCM c +liftB3 f x y z = TCM $ f (unTCBDB x) y z + +instance TCDB BDB where + new = TCM $ do bdb <- B.new + cur <- C.new bdb + return $ BDB bdb cur + delete = liftB B.delete + open tc name mode = TCM $ B.open (unTCBDB tc) name + (map openModeToBOpenMode mode) + close = liftB B.close + put = liftB3 B.put + putkeep = liftB3 B.putkeep + putcat = liftB3 B.putcat + get = liftB2 B.get + out = liftB2 B.out + vsiz = liftB2 B.vsiz + iterinit bdb = TCM $ C.first (unTCBDBCUR bdb) + iternext bdb = TCM $ do k <- C.key (unTCBDBCUR bdb) + C.next (unTCBDBCUR bdb) + return k + fwmkeys = liftB3 B.fwmkeys + addint = liftB3 B.addint + adddouble = liftB3 B.adddouble + sync = liftB B.sync + vanish = liftB B.vanish + copy = liftB2 B.copy + path = liftB B.path + rnum = liftB B.rnum + size = liftB B.fsiz + ecode = liftB B.ecode + defaultExtension = const ".tcb" + +instance TCDB B.BDB where + new = TCM B.new + delete = lift B.delete + open tc name mode = TCM $ B.open tc name (map openModeToBOpenMode mode) + close = lift B.close + put = lift3 B.put + putkeep = lift3 B.putkeep + putcat = lift3 B.putcat + get = lift2 B.get + out = lift2 B.out + vsiz = lift2 B.vsiz + iterinit = undefined + iternext = undefined + fwmkeys = lift3 B.fwmkeys + addint = lift3 B.addint + adddouble = lift3 B.adddouble + sync = lift B.sync + vanish = lift B.vanish + copy = lift2 B.copy + path = lift B.path + rnum = lift B.rnum + size = lift B.fsiz + ecode = lift B.ecode + defaultExtension = const ".tcb" + +openModeToFOpenMode :: OpenMode -> F.OpenMode +openModeToFOpenMode OREADER = F.OREADER +openModeToFOpenMode OWRITER = F.OWRITER +openModeToFOpenMode OCREAT = F.OCREAT +openModeToFOpenMode OTRUNC = F.OTRUNC +openModeToFOpenMode ONOLCK = F.ONOLCK +openModeToFOpenMode OLCKNB = F.OLCKNB + +storableToKey :: (Storable a) => a -> ID +storableToKey = toID . toInt64 + +liftF2 :: (Storable b) => (a -> ID -> IO c) -> a -> b -> TCM c +liftF2 f x y = TCM $ f x (storableToKey y) + +liftF3 :: (Storable b) => (a -> ID -> c -> IO d) -> a -> b -> c -> TCM d +liftF3 f x y z = TCM $ f x (storableToKey y) z + +keyToStorable :: (Storable a) => String -> a +keyToStorable = fromString + +instance TCDB F.FDB where + new = TCM F.new + delete = lift F.delete + open tc name mode = TCM $ F.open tc name (map openModeToFOpenMode mode) + close = lift F.close + put = liftF3 F.put + putkeep = liftF3 F.putkeep + putcat = liftF3 F.putcat + get = liftF2 F.get + out = liftF2 F.out + vsiz = liftF2 F.vsiz + iterinit = lift F.iterinit + iternext tc = TCM $ do key <- F.iternext tc + case key of + Nothing -> return Nothing + Just x -> return $ Just (keyToStorable x) + fwmkeys = lift3 F.fwmkeys + addint = liftF3 F.addint + adddouble = liftF3 F.adddouble + sync = lift F.sync + vanish = lift F.vanish + copy = lift2 F.copy + path = lift F.path + rnum = lift F.rnum + size = lift F.fsiz + ecode = lift F.ecode + defaultExtension = const ".tcf" diff --git a/Database/TokyoCabinet/BDB.hs b/Database/TokyoCabinet/BDB.hs new file mode 100644 --- /dev/null +++ b/Database/TokyoCabinet/BDB.hs @@ -0,0 +1,319 @@ +-- | Interface to B+ tree based DBM. See also, +-- for details +module Database.TokyoCabinet.BDB + ( + -- $doc + -- * Constructors + BDB + , ECODE(..) + , OpenMode(..) + , TuningOption(..) + -- * Basic API (tokyocabinet.idl compliant) + , new + , delete + , ecode + , errmsg + , tune + , setcache + , setxmsiz + , open + , close + , put + , putkeep + , putcat + , putdup + , putlist + , out + , outlist + , get + , getlist + , vnum + , vsiz + , range + , fwmkeys + , addint + , adddouble + , sync + , optimize + , vanish + , copy + , tranbegin + , trancommit + , tranabort + , path + , rnum + , fsiz + ) where + +import Data.Int + +import Foreign.Ptr +import Foreign.ForeignPtr + +import Database.TokyoCabinet.Error +import Database.TokyoCabinet.BDB.C +import Database.TokyoCabinet.Internal +import qualified Database.TokyoCabinet.Storable as S + +-- $doc +-- Example +-- +-- @ +-- import Control.Monad +-- import Database.TokyoCabinet.BDB +-- import qualified Database.TokyoCabinet.BDB.Cursor as C +-- @ +-- +-- @ +-- main :: IO () +-- main = +-- do bdb <- new +-- -- open the database +-- open bdb \"casket.tcb\" [OWRITER, OCREAT] >>= err bdb +-- -- store records +-- puts bdb [ (\"foo\", \"hop\"), (\"bar\", \"step\"), (\"baz\", \"jump\") ] >>= +-- err bdb . (all id) +-- -- retrieve records +-- get bdb \"foo\" >>= maybe (error \"something goes wrong\") putStrLn +-- -- traverse records +-- cur <- C.new bdb +-- C.first cur >>= err bdb +-- iter cur >>= putStrLn . show +-- -- close the database +-- close bdb >>= err bdb +-- where +-- puts :: BDB -> [(String, String)] -> IO [Bool] +-- puts bdb = mapM (uncurry $ put bdb) +-- @ +-- +-- @ +-- err :: BDB -> Bool -> IO () +-- err bdb = flip unless $ ecode bdb >>= error . show +-- @ +-- +-- @ +-- iter :: C.BDBCUR -> IO [(String, String)] +-- iter cur = do +-- [key, value] <- sequence [C.key cur, C.val cur] +-- case (key, value) of +-- (Just k, Just v) -> C.next cur >> iter cur >>= return . ((k,v):) +-- _ -> return [] +-- @ +-- + +-- | Create a B+ tree database object. +new :: IO BDB +new = BDB `fmap` (c_tcbdbnew >>= newForeignPtr tcbdbFinalizer) + +-- | Free BDB resource forcibly. +-- BDB is kept by ForeignPtr, so Haskell runtime GC cleans up memory for +-- almost situation. Most always, you don't need to call this. +-- After call this, you must not touch BDB object. Its behavior is undefined. +delete :: BDB -> IO () +delete bdb = finalizeForeignPtr (unTCBDB bdb) + +-- | Return the last happened error code. +ecode :: BDB -> IO ECODE +ecode bdb = cintToError `fmap` withForeignPtr (unTCBDB bdb) c_tcbdbecode + +-- | Set the tuning parameters. +tune :: BDB -- ^ BDB object + -> Int32 -- ^ the number of members in each leaf page. + -> Int32 -- ^ the number of members in each non-leaf page. + -> Int64 -- ^ the number of elements of the bucket array. + -> Int8 -- ^ the size of record alignment by power of 2. + -> Int8 -- ^ the maximum number of elements of the free block + -- pool by power of 2. + -> [TuningOption] -- ^ tuning options + -> IO Bool -- ^ if successful, the return value is True. +tune bdb lmemb nmemb bnum apow fpow opts = + withForeignPtr (unTCBDB bdb) $ \bdb' -> + c_tcbdbtune bdb' lmemb nmemb bnum apow fpow (combineTuningOption opts) + +-- | Set the caching parameters. +setcache :: BDB -- ^ BDB object + -> Int32 -- ^ the maximum number of leaf nodes to be cached. + -> Int32 -- ^ the maximum number of non-leaf nodes to be cached. + -> IO Bool -- ^ if successful, the return value is True. +setcache bdb lcnum ncnum = + withForeignPtr (unTCBDB bdb) $ \bdb' -> c_tcbdbsetcache bdb' lcnum ncnum + +-- | Set the size of extra mapped memory. +setxmsiz :: BDB -> Int64 -> IO Bool +setxmsiz bdb xmsiz = + withForeignPtr (unTCBDB bdb) $ \bdb' -> c_tcbdbsetxmsiz bdb' xmsiz + +-- | Open BDB database file. +open :: BDB -> String -> [OpenMode] -> IO Bool +open = openHelper c_tcbdbopen unTCBDB combineOpenMode + +-- | Close the database file. +close :: BDB -> IO Bool +close bdb = withForeignPtr (unTCBDB bdb) c_tcbdbclose + +-- | Stora a record (key-value pair) on BDB. Key and value type must +-- be instance of Storable class. Usually, we can use `String', +-- `ByteString' for key, `String', `ByteString', `Int', `Double' for +-- value. +put :: (S.Storable k, S.Storable v) => BDB -> k -> v -> IO Bool +put = putHelper c_tcbdbput unTCBDB + +-- | Store a new record. If a record with the same key exists in the +-- database, this function has no effect. +putkeep :: (S.Storable k, S.Storable v) => BDB -> k -> v -> IO Bool +putkeep = putHelper c_tcbdbputkeep unTCBDB + +-- | Concatenate a value at the end of the existing record. +putcat :: (S.Storable k, S.Storable v) => BDB -> k -> v -> IO Bool +putcat = putHelper c_tcbdbputcat unTCBDB + +-- | Store a record with allowing duplication of keys. +putdup :: (S.Storable k, S.Storable v) => BDB -> k -> v -> IO Bool +putdup = putHelper c_tcbdbputdup unTCBDB + +-- | Store records with allowing duplication of keys. +putlist :: (S.Storable k, S.Storable v) => BDB -> k -> [v] -> IO Bool +putlist bdb key vals = do + and `fmap` mapM (putdup bdb key) vals + +-- | Delete a record. If the key of duplicated records is specified, +-- the first one is deleted. +out :: (S.Storable k) => BDB -> k -> IO Bool +out = outHelper c_tcbdbout unTCBDB + +-- | Delete records. If the key of duplicated records is specified, +-- all of them are deleted. +outlist :: (S.Storable k) => BDB -> k -> IO Bool +outlist = outHelper c_tcbdbout3 unTCBDB + +-- | Return the value of record. If the key of duplicated records is +-- specified, the first one is returned. +get :: (S.Storable k, S.Storable v) => BDB -> k -> IO (Maybe v) +get = getHelper c_tcbdbget unTCBDB + +-- | Retrieve records. +getlist :: (S.Storable k, S.Storable v) => BDB -> k -> IO [v] +getlist bdb key = + withForeignPtr (unTCBDB bdb) $ \bdb' -> + S.withPtrLen key $ \(kbuf, ksize) -> do + ptr <- c_tcbdbget4 bdb' kbuf ksize + if ptr == nullPtr + then return [] + else peekTCListAndFree ptr + +-- | Return the number of records corresponding to a key. +vnum :: (S.Storable k) => BDB -> k -> IO (Maybe Int) +vnum bdb key = + withForeignPtr (unTCBDB bdb) $ \bdb' -> + S.withPtrLen key $ \(kbuf, ksize) -> do + res <- c_tcbdbvnum bdb' kbuf ksize + return $ if res == 0 + then Nothing + else Just $ fromIntegral res + +-- | Return the size of the value of a record. If the key of duplicated +-- records is specified, the first one is selected. +vsiz :: (S.Storable k) => BDB -> k -> IO (Maybe Int) +vsiz = vsizHelper c_tcbdbvsiz unTCBDB + +-- | Return list of keys in the specified range. +range :: (S.Storable k) => + BDB -- ^ BDB object + -> Maybe k -- ^ the key of the beginning border. If it is + -- Nothing, the first record in the database is + -- specified. + -> Bool -- ^ whether the beginning border is inclusive or not. + -> Maybe k -- ^ the key of the ending border. If it is Nothing, + -- the last record is specified. + -> Bool -- ^ whether the ending border is inclusive or not. + -> Int -- ^ the maximum number of keys to be fetched. If it + -- is negative value, no limit is specified. + -> IO [k] -- ^ keys in the specified range. +range bdb bkey binc ekey einc maxn = + withForeignPtr (unTCBDB bdb) $ \bdb' -> + withPtrLen' bkey $ \(bkbuf, bksiz) -> + withPtrLen' ekey $ \(ekbuf, eksiz) -> + c_tcbdbrange bdb' bkbuf bksiz binc ekbuf eksiz einc + (fromIntegral maxn) >>= peekTCListAndFree + where + withPtrLen' (Just key) action = S.withPtrLen key action + withPtrLen' Nothing action = action (nullPtr, 0) + +-- | Return list of forward matched keys. +fwmkeys :: (S.Storable k1, S.Storable k2) => + BDB -- ^ BDB object + -> k1 -- ^ search string + -> Int -- ^ the maximum number of keys to be fetched. If it + -- is negative value, no limit is specified. + -> IO [k2] -- ^ keys matches specified string (in forward matching). +fwmkeys = fwmHelper c_tcbdbfwmkeys unTCBDB + +-- | Increment the corresponding value. (The value specified by a key +-- is treated as integer.) +addint :: (S.Storable k) => + BDB -- ^ BDB object. + -> k -- ^ Key. + -> Int -- ^ Amount of increment. + -> IO (Maybe Int) -- ^ If successful, a new value is returned. +addint = addHelper c_tcbdbaddint unTCBDB fromIntegral fromIntegral (== cINT_MIN) + +-- | Increment the corresponding value. (The value specified by a key +-- is treated as double.) +adddouble :: (S.Storable k) => + BDB -- ^ BDB object. + -> k -- ^ Key. + -> Double -- ^ Amount of increment. + -> IO (Maybe Double) -- ^ If successful, a new value is returned. +adddouble = addHelper c_tcbdbadddouble unTCBDB realToFrac realToFrac isNaN + +-- | Synchronize updated contents of a database object with the file +-- and the device. +sync :: BDB -> IO Bool +sync bdb = withForeignPtr (unTCBDB bdb) c_tcbdbsync + +-- | Optimize the file of a B+ tree database object. +optimize :: BDB + -> Int32 -- ^ the number of members in each leaf page. + -> Int32 -- ^ the number of members in each non-leaf page. + -> Int64 -- ^ the number of elements of the bucket array. + -> Int8 -- ^ the size of record alignment by power of 2. + -> Int8 -- ^ the maximum number of elements of the free block + -- pool by power of 2. + -> [TuningOption] -- ^ tuning options + -> IO Bool -- ^ if successful, the return value is True. +optimize bdb lmemb nmemb bnum apow fpow opts = + withForeignPtr (unTCBDB bdb) $ \bdb' -> + c_tcbdboptimize bdb' lmemb nmemb bnum apow fpow + (combineTuningOption opts) + +-- | Delete all records. +vanish :: BDB -> IO Bool +vanish bdb = withForeignPtr (unTCBDB bdb) c_tcbdbvanish + +-- | Copy the database file. +copy :: BDB -> String -> IO Bool +copy = copyHelper c_tcbdbcopy unTCBDB + +-- | Begin the transaction. +tranbegin :: BDB -> IO Bool +tranbegin bdb = withForeignPtr (unTCBDB bdb) c_tcbdbtranbegin + +-- | Commit the transaction. +trancommit :: BDB -> IO Bool +trancommit bdb = withForeignPtr (unTCBDB bdb) c_tcbdbtrancommit + +-- | Abort the transaction. +tranabort :: BDB -> IO Bool +tranabort bdb = withForeignPtr (unTCBDB bdb) c_tcbdbtranabort + +-- | Return the file path of currentry opened database. +path :: BDB -> IO (Maybe String) +path = pathHelper c_tcbdbpath unTCBDB + +-- | Return the number of records in the database. +rnum :: BDB -> IO Int64 +rnum bdb = withForeignPtr (unTCBDB bdb) c_tcbdbrnum + +-- | Return the size of the database file. +fsiz :: BDB -> IO Int64 +fsiz bdb = withForeignPtr (unTCBDB bdb) c_tcbdbfsiz diff --git a/Database/TokyoCabinet/BDB/C.hsc b/Database/TokyoCabinet/BDB/C.hsc new file mode 100644 --- /dev/null +++ b/Database/TokyoCabinet/BDB/C.hsc @@ -0,0 +1,211 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +module Database.TokyoCabinet.BDB.C where + +#include + +import Foreign.Ptr +import Foreign.ForeignPtr + +import Foreign.C.Types +import Foreign.C.String + +import Data.Int +import Data.Word +import Data.Bits + +import Database.TokyoCabinet.List.C (LIST) + +data BDB = BDB { unTCBDB :: !(ForeignPtr BDB') } + +data OpenMode = + OREADER | + OWRITER | + OCREAT | + OTRUNC | + ONOLCK | + OLCKNB | + OTSYNC + deriving (Eq, Ord, Show) + +openModeToCInt :: OpenMode -> CInt +openModeToCInt OREADER = #const BDBOREADER +openModeToCInt OWRITER = #const BDBOWRITER +openModeToCInt OCREAT = #const BDBOCREAT +openModeToCInt OTRUNC = #const BDBOTRUNC +openModeToCInt ONOLCK = #const BDBONOLCK +openModeToCInt OLCKNB = #const BDBOLCKNB +openModeToCInt OTSYNC = #const BDBOTSYNC + +combineOpenMode :: [OpenMode] -> CInt +combineOpenMode = foldr ((.|.) . openModeToCInt) 0 + +data TuningOption = + TLARGE | + TDEFLATE | + TBZIP | + TTCBS | + TEXCODEC + deriving (Eq, Ord, Show) + +tuningOptionToWord8 :: TuningOption -> Word8 +tuningOptionToWord8 TLARGE = #const BDBTLARGE +tuningOptionToWord8 TDEFLATE = #const BDBTDEFLATE +tuningOptionToWord8 TBZIP = #const BDBTBZIP +tuningOptionToWord8 TTCBS = #const BDBTTCBS +tuningOptionToWord8 TEXCODEC = #const BDBTEXCODEC + +combineTuningOption :: [TuningOption] -> Word8 +combineTuningOption = foldr ((.|.) . tuningOptionToWord8) 0 + +type TCCMP = Ptr CChar -> CInt -> Ptr CChar -> CInt -> Ptr Word8 -> CInt + +data BDB' + +foreign import ccall safe "tcbdbnew" + c_tcbdbnew :: IO (Ptr BDB') + +foreign import ccall safe "tcbdbdel" + c_tcbdbdel :: Ptr BDB' -> IO () + +foreign import ccall safe "&tcbdbdel" + tcbdbFinalizer :: FunPtr (Ptr BDB' -> IO ()) + +foreign import ccall safe "tcbdbecode" + c_tcbdbecode :: Ptr BDB' -> IO CInt + +foreign import ccall safe "tcbdbsetmutex" + c_tcbdbsetmutex :: Ptr BDB' -> IO Bool + +foreign import ccall safe "tcbdbsetcmpfunc" + c_tcbdbsetcmpfunc :: Ptr BDB' -> FunPtr TCCMP -> IO Bool + +foreign import ccall safe "tcbdbtune" + c_tcbdbtune :: + Ptr BDB' -> Int32 -> Int32 -> Int64 -> Int8 -> Int8 -> Word8 -> IO Bool + +foreign import ccall safe "tcbdbsetcache" + c_tcbdbsetcache :: Ptr BDB' -> Int32 -> Int32 -> IO Bool + +foreign import ccall safe "tcbdbsetxmsiz" + c_tcbdbsetxmsiz :: Ptr BDB' -> Int64 -> IO Bool + +foreign import ccall safe "tcbdbopen" + c_tcbdbopen :: Ptr BDB' -> CString -> CInt -> IO Bool + +foreign import ccall safe "tcbdbclose" + c_tcbdbclose :: Ptr BDB' -> IO Bool + +foreign import ccall safe "tcbdbput" + c_tcbdbput :: Ptr BDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tcbdbput2" + c_tcbdbput2 :: Ptr BDB' -> CString -> CString -> IO Bool + +foreign import ccall safe "tcbdbputkeep" + c_tcbdbputkeep :: + Ptr BDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tcbdbputkeep2" + c_tcbdbputkeep2 :: Ptr BDB' -> CString -> CString -> IO Bool + +foreign import ccall safe "tcbdbputcat" + c_tcbdbputcat :: + Ptr BDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tcbdbputcat2" + c_tcbdbputcat2 :: Ptr BDB' -> CString -> CString -> IO Bool + +foreign import ccall safe "tcbdbputdup" + c_tcbdbputdup :: + Ptr BDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tcbdbputdup2" + c_tcbdbputdup2 :: Ptr BDB' -> CString -> CString -> IO Bool + +foreign import ccall safe "tcbdbputdup3" + c_tcbdbputdup3 :: Ptr BDB' -> Ptr Word8 -> CInt -> Ptr LIST -> IO Bool + +foreign import ccall safe "tcbdbout" + c_tcbdbout :: Ptr BDB' -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tcbdbout2" + c_tcbdbout2 :: Ptr BDB' -> CString -> IO Bool + +foreign import ccall safe "tcbdbout3" + c_tcbdbout3 :: Ptr BDB' -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tcbdbget" + c_tcbdbget :: Ptr BDB' -> Ptr Word8 -> CInt -> Ptr CInt -> IO (Ptr Word8) + +foreign import ccall safe "tcbdbget2" + c_tcbdbget2 :: Ptr BDB' -> CString -> IO CString + +foreign import ccall safe "tcbdbget3" + c_tcbdbget3 :: Ptr BDB' -> Ptr Word8 -> CInt -> Ptr CInt -> IO (Ptr Word8) + +foreign import ccall safe "tcbdbget4" + c_tcbdbget4 :: Ptr BDB' -> Ptr Word8 -> CInt -> IO (Ptr LIST) + +foreign import ccall safe "tcbdbvnum" + c_tcbdbvnum :: Ptr BDB' -> Ptr Word8 -> CInt -> IO CInt + +foreign import ccall safe "tcbdbvnum2" + c_tcbdbvnum2 :: Ptr BDB' -> CString -> IO CInt + +foreign import ccall safe "tcbdbvsiz" + c_tcbdbvsiz :: Ptr BDB' -> Ptr Word8 -> CInt -> IO CInt + +foreign import ccall safe "tcbdbvsiz2" + c_tcbdbvsiz2 :: Ptr BDB' -> CString -> IO CInt + +foreign import ccall safe "tcbdbrange" + c_tcbdbrange :: + Ptr BDB' -> Ptr Word8 -> CInt -> Bool + -> Ptr Word8 -> CInt -> Bool -> CInt -> IO (Ptr LIST) + +foreign import ccall safe "tcbdbrange2" + c_tcbdbrange2 :: + Ptr BDB' -> CString -> Bool -> CString -> Bool -> CInt -> IO (Ptr LIST) + +foreign import ccall safe "tcbdbfwmkeys" + c_tcbdbfwmkeys :: Ptr BDB' -> Ptr Word8 -> CInt -> CInt -> IO (Ptr LIST) + +foreign import ccall safe "tcbdbfwmkeys2" + c_tcbdbfwmkeys2 :: Ptr BDB' -> CString -> CInt -> IO (Ptr LIST) + +foreign import ccall safe "tcbdbaddint" + c_tcbdbaddint :: Ptr BDB' -> Ptr Word8 -> CInt -> CInt -> IO CInt + +foreign import ccall safe "tcbdbadddouble" + c_tcbdbadddouble :: Ptr BDB' -> Ptr Word8 -> CInt -> CDouble -> IO CDouble + +foreign import ccall safe "tcbdbsync" + c_tcbdbsync :: Ptr BDB' -> IO Bool + +foreign import ccall safe "tcbdboptimize" + c_tcbdboptimize :: + Ptr BDB' -> Int32 -> Int32 -> Int64 -> Int8 -> Int8 -> Word8 -> IO Bool + +foreign import ccall safe "tcbdbvanish" + c_tcbdbvanish :: Ptr BDB' -> IO Bool + +foreign import ccall safe "tcbdbcopy" + c_tcbdbcopy :: Ptr BDB' -> CString -> IO Bool + +foreign import ccall safe "tcbdbtranbegin" + c_tcbdbtranbegin :: Ptr BDB' -> IO Bool + +foreign import ccall safe "tcbdbtrancommit" + c_tcbdbtrancommit :: Ptr BDB' -> IO Bool + +foreign import ccall safe "tcbdbtranabort" + c_tcbdbtranabort :: Ptr BDB' -> IO Bool + +foreign import ccall safe "tcbdbpath" + c_tcbdbpath :: Ptr BDB' -> IO CString + +foreign import ccall safe "tcbdbrnum" + c_tcbdbrnum :: Ptr BDB' -> IO Int64 + +foreign import ccall safe "tcbdbfsiz" + c_tcbdbfsiz :: Ptr BDB' -> IO Int64 diff --git a/Database/TokyoCabinet/BDB/Cursor.hs b/Database/TokyoCabinet/BDB/Cursor.hs new file mode 100644 --- /dev/null +++ b/Database/TokyoCabinet/BDB/Cursor.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +module Database.TokyoCabinet.BDB.Cursor + ( + CursorPutMode(..) + , new + , delete + , first + , last + , jump + , prev + , next + , put + , out + , key + , val + , BDBCUR + ) where + +import Prelude hiding (last) + +import Database.TokyoCabinet.BDB.C +import Database.TokyoCabinet.BDB.Cursor.C +import qualified Database.TokyoCabinet.Storable as S + +import Foreign.ForeignPtr + +import Foreign.Marshal (alloca) +import Foreign.Storable (peek) +import Foreign.Marshal.Utils (maybePeek) + +data BDBCUR = BDBCUR !(ForeignPtr CUR) BDB + +unTCBDBCUR :: BDBCUR -> ForeignPtr CUR +unTCBDBCUR (BDBCUR cur _) = cur + +new :: BDB -> IO BDBCUR +new bdb = + withForeignPtr (unTCBDB bdb) $ \bdb' -> do + cur <- c_tcbdbcurnew bdb' + flip BDBCUR bdb `fmap` newForeignPtr tcbdbcurFinalizer cur + +delete :: BDBCUR -> IO () +delete cur = finalizeForeignPtr (unTCBDBCUR cur) + +first :: BDBCUR -> IO Bool +first cur = withForeignPtr (unTCBDBCUR cur) c_tcbdbcurfirst + +last :: BDBCUR -> IO Bool +last cur = withForeignPtr (unTCBDBCUR cur) c_tcbdbcurlast + +jump :: (S.Storable k) => BDBCUR -> k -> IO Bool +jump cur k = + withForeignPtr (unTCBDBCUR cur) $ \cur' -> + S.withPtrLen k $ \(kbuf, ksiz) -> + c_tcbdbcurjump cur' kbuf ksiz + +prev :: BDBCUR -> IO Bool +prev cur = withForeignPtr (unTCBDBCUR cur) c_tcbdbcurprev + +next :: BDBCUR -> IO Bool +next cur = withForeignPtr (unTCBDBCUR cur) c_tcbdbcurnext + +put :: (S.Storable v) => BDBCUR -> v -> CursorPutMode -> IO Bool +put cur v mode = + withForeignPtr (unTCBDBCUR cur) $ \cur' -> + S.withPtrLen v $ \(vbuf, vsiz) -> + c_tcbdbcurput cur' vbuf vsiz (cpToCInt mode) + +out :: BDBCUR -> IO Bool +out cur = withForeignPtr (unTCBDBCUR cur) c_tcbdbcurout + +key :: (S.Storable k) => BDBCUR -> IO (Maybe k) +key cur = + withForeignPtr (unTCBDBCUR cur) $ \cur' -> + alloca $ \sizbuf -> do + vbuf <- c_tcbdbcurkey cur' sizbuf + vsiz <- fromIntegral `fmap` peek sizbuf + flip maybePeek vbuf $ \vbuf' -> S.peekPtrLen (vbuf', vsiz) + +val :: (S.Storable v) => BDBCUR -> IO (Maybe v) +val cur = + withForeignPtr (unTCBDBCUR cur) $ \cur' -> + alloca $ \sizbuf -> do + vbuf <- c_tcbdbcurval cur' sizbuf + vsiz <- fromIntegral `fmap` peek sizbuf + flip maybePeek vbuf $ \vbuf' -> S.peekPtrLen (vbuf', vsiz) diff --git a/Database/TokyoCabinet/BDB/Cursor/C.hsc b/Database/TokyoCabinet/BDB/Cursor/C.hsc new file mode 100644 --- /dev/null +++ b/Database/TokyoCabinet/BDB/Cursor/C.hsc @@ -0,0 +1,79 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +module Database.TokyoCabinet.BDB.Cursor.C where + +import Database.TokyoCabinet.BDB.C + +import Foreign.Ptr + +import Foreign.C.Types +import Foreign.C.String + +import Data.Word + +#include + +data CursorPutMode = CPCURRENT | + CPBEFORE | + CPAFTER + deriving (Eq, Ord, Show) + +cpToCInt :: CursorPutMode -> CInt +cpToCInt CPCURRENT = #const BDBCPCURRENT +cpToCInt CPBEFORE = #const BDBCPBEFORE +cpToCInt CPAFTER = #const BDBCPAFTER + +data CUR + +foreign import ccall safe "tcbdbcurnew" + c_tcbdbcurnew :: Ptr BDB' -> IO (Ptr CUR) + +foreign import ccall safe "tcbdbcurdel" + c_tcbdbcurdel :: Ptr CUR -> IO () + +foreign import ccall safe "&tcbdbcurdel" + tcbdbcurFinalizer :: FunPtr (Ptr CUR -> IO ()) + +foreign import ccall safe "tcbdbcurfirst" + c_tcbdbcurfirst :: Ptr CUR -> IO Bool + +foreign import ccall safe "tcbdbcurlast" + c_tcbdbcurlast :: Ptr CUR -> IO Bool + +foreign import ccall safe "tcbdbcurjump" + c_tcbdbcurjump :: Ptr CUR -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tcbdbcurjump2" + c_tcbdbcurjump2 :: Ptr CUR -> CString -> IO Bool + +foreign import ccall safe "tcbdbcurprev" + c_tcbdbcurprev :: Ptr CUR -> IO Bool + +foreign import ccall safe "tcbdbcurnext" + c_tcbdbcurnext :: Ptr CUR -> IO Bool + +foreign import ccall safe "tcbdbcurput" + c_tcbdbcurput :: Ptr CUR -> Ptr Word8 -> CInt -> CInt -> IO Bool + +foreign import ccall safe "tcbdbcurput2" + c_tcbdbcurput2 :: Ptr CUR -> CString -> CInt -> IO Bool + +foreign import ccall safe "tcbdbcurout" + c_tcbdbcurout :: Ptr CUR -> IO Bool + +foreign import ccall safe "tcbdbcurkey" + c_tcbdbcurkey :: Ptr CUR -> Ptr CInt -> IO (Ptr Word8) + +foreign import ccall safe "tcbdbcurkey2" + c_tcbdbcurkey2 :: Ptr CUR -> IO CString + +foreign import ccall safe "tcbdbcurkey3" + c_tcbdbcurkey3 :: Ptr CUR -> Ptr CInt -> IO (Ptr Word8) + +foreign import ccall safe "tcbdbcurval" + c_tcbdbcurval :: Ptr CUR -> Ptr CInt -> IO (Ptr Word8) + +foreign import ccall safe "tcbdbcurval2" + c_tcbdbcurval2 :: Ptr CUR -> IO CString + +foreign import ccall safe "tcbdbcurval3" + c_tcbdbcurval3 :: Ptr CUR -> Ptr CInt -> IO (Ptr Word8) diff --git a/Database/TokyoCabinet/Error.hsc b/Database/TokyoCabinet/Error.hsc new file mode 100644 --- /dev/null +++ b/Database/TokyoCabinet/Error.hsc @@ -0,0 +1,112 @@ +{-# LANGUAGE CPP, ForeignFunctionInterface #-} +module Database.TokyoCabinet.Error + ( + -- * Error code + ECODE(..) + -- * Utility function + , errmsg + , cintToError + , errorToCInt + -- * Other constants + , cINT_MIN + ) where + +import Foreign +import Foreign.C.Types +import Foreign.C.String + +#include + +-- | Represents error +data ECODE = + ESUCCESS | -- ^ success + ETHREAD | -- ^ threading error + EINVALID | -- ^ invalid operation + ENOFILE | -- ^ file not found + ENOPERM | -- ^ no permission + EMETA | -- ^ invalid meta data + ERHEAD | -- ^ invalid record header + EOPEN | -- ^ open error + ECLOSE | -- ^ close error + ETRUNC | -- ^ trunc error + ESYNC | -- ^ sync error + ESTAT | -- ^ stat error + ESEEK | -- ^ seek error + EREAD | -- ^ read error + EWRITE | -- ^ write error + EMMAP | -- ^ mmap error + ELOCK | -- ^ lock error + EUNLINK | -- ^ unlink error + ERENAME | -- ^ rename error + EMKDIR | -- ^ mkdir error + ERMDIR | -- ^ rmdir error + EKEEP | -- ^ existing record + ENOREC | -- ^ no record found + EMISC -- ^ miscellaneous error + deriving (Eq, Ord) + +instance Show ECODE where + show e = errmsg e ++ " (code:" ++ show (errorToCInt e) ++ ")" + +errorToCInt :: ECODE -> CInt +errorToCInt ESUCCESS = #const TCESUCCESS +errorToCInt ETHREAD = #const TCETHREAD +errorToCInt EINVALID = #const TCEINVALID +errorToCInt ENOFILE = #const TCENOFILE +errorToCInt ENOPERM = #const TCENOPERM +errorToCInt EMETA = #const TCEMETA +errorToCInt ERHEAD = #const TCERHEAD +errorToCInt EOPEN = #const TCEOPEN +errorToCInt ECLOSE = #const TCECLOSE +errorToCInt ETRUNC = #const TCETRUNC +errorToCInt ESYNC = #const TCESYNC +errorToCInt ESTAT = #const TCESTAT +errorToCInt ESEEK = #const TCESEEK +errorToCInt EREAD = #const TCEREAD +errorToCInt EWRITE = #const TCEWRITE +errorToCInt EMMAP = #const TCEMMAP +errorToCInt ELOCK = #const TCELOCK +errorToCInt EUNLINK = #const TCEUNLINK +errorToCInt ERENAME = #const TCERENAME +errorToCInt EMKDIR = #const TCEMKDIR +errorToCInt ERMDIR = #const TCERMDIR +errorToCInt EKEEP = #const TCEKEEP +errorToCInt ENOREC = #const TCENOREC +errorToCInt EMISC = #const TCEMISC + +cintToError :: CInt -> ECODE +cintToError #{const TCESUCCESS} = ESUCCESS +cintToError #{const TCETHREAD} = ETHREAD +cintToError #{const TCEINVALID} = EINVALID +cintToError #{const TCENOFILE} = ENOFILE +cintToError #{const TCENOPERM} = ENOPERM +cintToError #{const TCEMETA} = EMETA +cintToError #{const TCERHEAD} = ERHEAD +cintToError #{const TCEOPEN} = EOPEN +cintToError #{const TCECLOSE} = ECLOSE +cintToError #{const TCETRUNC} = ETRUNC +cintToError #{const TCESYNC} = ESYNC +cintToError #{const TCESTAT} = ESTAT +cintToError #{const TCESEEK} = ESEEK +cintToError #{const TCEREAD} = EREAD +cintToError #{const TCEWRITE} = EWRITE +cintToError #{const TCEMMAP} = EMMAP +cintToError #{const TCELOCK} = ELOCK +cintToError #{const TCEUNLINK} = EUNLINK +cintToError #{const TCERENAME} = ERENAME +cintToError #{const TCEMKDIR} = EMKDIR +cintToError #{const TCERMDIR} = ERMDIR +cintToError #{const TCEKEEP} = EKEEP +cintToError #{const TCENOREC} = ENOREC +cintToError #{const TCEMISC} = EMISC +cintToError _ = error "unknown error code" + +cINT_MIN :: CInt +cINT_MIN = #const INT_MIN + +-- | Convert error code to message string. +errmsg :: ECODE -> String +errmsg = unsafePerformIO . peekCString . c_tcerrmsg . errorToCInt + +foreign import ccall "tcerrmsg" + c_tcerrmsg :: CInt -> CString diff --git a/Database/TokyoCabinet/FDB.hs b/Database/TokyoCabinet/FDB.hs new file mode 100644 --- /dev/null +++ b/Database/TokyoCabinet/FDB.hs @@ -0,0 +1,266 @@ +-- | Interface to Fixed-length DBM. See also, +-- for details +module Database.TokyoCabinet.FDB + ( + -- $doc + -- * Constructors + FDB + , ECODE(..) + , OpenMode(..) + , ID(..) + -- * Basic API (tokyocabinet.idl compliant) + , new + , delete + , ecode + , errmsg + , tune + , open + , close + , put + , putkeep + , putcat + , out + , get + , vsiz + , iterinit + , iternext + , range + , fwmkeys + , addint + , adddouble + , sync + , optimize + , vanish + , copy + , path + , rnum + , fsiz + ) where + +import Database.TokyoCabinet.Error +import Database.TokyoCabinet.FDB.C +import Database.TokyoCabinet.FDB.Key +import Database.TokyoCabinet.Internal +import qualified Database.TokyoCabinet.Storable as S + +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.C.Types +import Foreign.Storable (peek) +import Foreign.Marshal (alloca, free) +import Foreign.Marshal.Array (peekArray) +import Foreign.Marshal.Utils (maybePeek) + +import Data.Int +import Data.Word + +import Control.Exception + +-- $doc +-- Example +-- +-- @ +-- import Control.Monad +-- import Database.TokyoCabinet.FDB +-- @ +-- +-- @ +-- main = do fdb <- new +-- -- open the database +-- open fdb \"casket.tcf\" [OWRITER, OCREAT] >>= err fdb +-- -- store records +-- puts fdb [(1, \"one\"), (12, \"twelve\"), (144, \"one forty four\")] >>= +-- err fdb . (all id) +-- -- retrieve records +-- get fdb (1 :: Int) >>= maybe (error \"something goes wrong\") putStrLn +-- -- close the database +-- close fdb >>= err fdb +-- where +-- puts :: FDB -> [(Int, String)] -> IO [Bool] +-- puts fdb = mapM (uncurry $ put fdb) +-- @ +-- +-- @ +-- err :: FDB -> Bool -> IO () +-- err fdb = flip unless $ ecode fdb >>= error . show +-- @ +-- + + +data FDB = FDB { unTCFDB :: !(ForeignPtr FDB') } + +-- | Create a Fixed-length database object. +new :: IO FDB +new = FDB `fmap` (c_tcfdbnew >>= newForeignPtr tcfdbFinalizer) + +-- | Free FDB resource forcibly. +-- FDB is kept by ForeignPtr, so Haskell runtime GC cleans up memory for +-- almost situation. Most always, you don't need to call this. +-- After call this, you must not touch FDB object. Its behavior is undefined. +delete :: FDB -> IO () +delete fdb = finalizeForeignPtr $ unTCFDB fdb + +-- | Return the last happened error code. +ecode :: FDB -> IO ECODE +ecode fdb = + withForeignPtr (unTCFDB fdb) $ \fdb' -> + cintToError `fmap` c_tcfdbecode fdb' + +-- | Set the tuning parameters. +tune :: FDB -- ^ FDB object. + -> Int32 -- ^ the width of the value of each record. + -> Int64 -- ^ the limit size of the database file. + -> IO Bool -- ^ if successful, the return value is True. +tune fdb width limsiz = + withForeignPtr (unTCFDB fdb) $ \fdb' -> c_tcfdbtune fdb' width limsiz + +-- | Open FDB database file. +open :: FDB -> String -> [OpenMode] -> IO Bool +open = openHelper c_tcfdbopen unTCFDB combineOpenMode + +-- | Close the database file. +close :: FDB -> IO Bool +close fdb = withForeignPtr (unTCFDB fdb) c_tcfdbclose + +type FunPut' = Ptr FDB' -> Int64 -> Ptr Word8 -> CInt -> IO Bool +putHelper' :: (Key k, S.Storable v) => FunPut' -> FDB -> k -> v -> IO Bool +putHelper' func fdb key val = + withForeignPtr (unTCFDB fdb) $ \fdb' -> + S.withPtrLen val $ \(vbuf, vsize) -> do + key' <- keyToInt key + func fdb' key' vbuf vsize + +-- | Stora a record (key-value pair) on FDB. Key type must be +-- instance of Key class. Value type must be instance of Storable. +put :: (Key k, S.Storable v) => FDB -> k -> v -> IO Bool +put = putHelper' c_tcfdbput + +-- | Store a new record. If a record with the same key exists in the +-- database, this function has no effect. +putkeep :: (Key k, S.Storable v) => FDB -> k -> v -> IO Bool +putkeep = putHelper' c_tcfdbputkeep + +-- | Concatenate a value at the end of the existing record. +putcat :: (Key k, S.Storable v) => FDB -> k -> v -> IO Bool +putcat = putHelper' c_tcfdbputcat + +-- | Delete a record. +out :: (Key k) => FDB -> k -> IO Bool +out fdb key = + withForeignPtr (unTCFDB fdb) $ \fdb' -> + c_tcfdbout fdb' =<< keyToInt key + +-- | Return the value of record. +get :: (Key k, S.Storable v) => FDB -> k -> IO (Maybe v) +get fdb key = + withForeignPtr (unTCFDB fdb) $ \fdb' -> + alloca $ \sizbuf -> do + key' <- keyToInt key + vbuf <- c_tcfdbget fdb' key' sizbuf + vsize <- peek sizbuf + flip maybePeek vbuf $ \vbuf' -> S.peekPtrLen (vbuf', vsize) + +-- | Return the byte size of value in a record. +vsiz :: (Key k) => FDB -> k -> IO (Maybe Int) +vsiz fdb key = + withForeignPtr (unTCFDB fdb) $ \fdb' -> do + vsize <- c_tcfdbvsiz fdb' =<< keyToInt key + return $ if vsize == (-1) + then Nothing + else Just (fromIntegral vsize) + +-- | Initialize the iterator of a FDB object. +iterinit :: FDB -> IO Bool +iterinit fdb = withForeignPtr (unTCFDB fdb) c_tcfdbiterinit + +-- | Return the next key of the iterator of a FDB object. +iternext :: (Key k) => FDB -> IO (Maybe k) +iternext fdb = + withForeignPtr (unTCFDB fdb) $ \fdb' -> do + i <- c_tcfdbiternext fdb' + return $ if i == 0 + then Nothing + else Just (fromID $ ID i) + +-- | Return list of keys in the specified range. +range :: (Key k1, Key k2) => + FDB -- ^ FDB object + -> k1 -- ^ the lower limit of the range. + -> k1 -- ^ the upper limit of the range. + -> Int -- ^ the maximum number of keys to be fetched. + -> IO [k2] -- ^ keys in the specified range. +range fdb lower upper maxn = + withForeignPtr (unTCFDB fdb) $ \fdb' -> + alloca $ \sizbuf -> do + [l, u] <- mapM keyToInt [lower, upper] + rp <- c_tcfdbrange fdb' l u (fromIntegral maxn) sizbuf + size <- fromIntegral `fmap` peek sizbuf + keys <- peekArray size rp + free rp + return $ map (fromID . ID) keys + +-- | Return list of forward matched keys. +fwmkeys :: (S.Storable k1, S.Storable k2) => FDB -> k1 -> Int -> IO [k2] +fwmkeys fdb k maxn = map S.fromString `fmap` fwmkeys' fdb k maxn + where fwmkeys' = fwmHelper c_tcfdbrange4 unTCFDB + +-- | Increment the corresponding value. (The value specified by a key +-- is treated as integer.) +addint :: (Key k) => FDB -> k -> Int -> IO (Maybe Int) +addint fdb key num = + withForeignPtr (unTCFDB fdb) $ \fdb' -> do + key' <- keyToInt key + sumval <- c_tcfdbaddint fdb' key' (fromIntegral num) + return $ if sumval == cINT_MIN + then Nothing + else Just $ fromIntegral sumval + +-- | Increment the corresponding value. (The value specified by a key +-- is treated as double.) +adddouble :: (Key k) => FDB -> k -> Double -> IO (Maybe Double) +adddouble fdb key num = + withForeignPtr (unTCFDB fdb) $ \fdb' -> do + key' <- keyToInt key + sumval <- c_tcfdbadddouble fdb' key' (realToFrac num) + return $ if isNaN sumval + then Nothing + else Just $ realToFrac sumval + +-- | Synchronize updated contents of a database object with the file +-- and the device. +sync :: FDB -> IO Bool +sync fdb = withForeignPtr (unTCFDB fdb) c_tcfdbsync + +-- | Optimize the file of a Hash database object. +optimize :: FDB -> Int32 -> Int64 -> IO Bool +optimize fdb width limsiz = + withForeignPtr (unTCFDB fdb) $ \fdb' -> c_tcfdboptimize fdb' width limsiz + +-- | Delete all records. +vanish :: FDB -> IO Bool +vanish fdb = withForeignPtr (unTCFDB fdb) c_tcfdbvanish + +-- | Copy the database file. +copy :: FDB -> String -> IO Bool +copy = copyHelper c_tcfdbcopy unTCFDB + +-- | Return the file path of currentry opened database. +path :: FDB -> IO (Maybe String) +path = pathHelper c_tcfdbpath unTCFDB + +-- | Return the number of records in the database. +rnum :: FDB -> IO Int64 +rnum fdb = withForeignPtr (unTCFDB fdb) c_tcfdbrnum + +-- | Return the size of the database file. +fsiz :: FDB -> IO Int64 +fsiz fdb = withForeignPtr (unTCFDB fdb) c_tcfdbfsiz + +keyToInt :: (Key k) => k -> IO Int64 +keyToInt i = catchJust selector (evaluate (unID . toID $ i)) handler + where + selector :: ErrorCall -> Maybe () + selector e = if show e == "Prelude.read: no parse" + then Just () + else Nothing + handler _ = error "Database.TokyoCabinet.FDB: invalid key" diff --git a/Database/TokyoCabinet/FDB/C.hsc b/Database/TokyoCabinet/FDB/C.hsc new file mode 100644 --- /dev/null +++ b/Database/TokyoCabinet/FDB/C.hsc @@ -0,0 +1,199 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +module Database.TokyoCabinet.FDB.C where + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.String + +import Data.Int +import Data.Word +import Data.Bits + +import Database.TokyoCabinet.List.C (LIST) + +#include + +data OpenMode = + OREADER | + OWRITER | + OCREAT | + OTRUNC | + ONOLCK | + OLCKNB + deriving (Eq, Ord, Show) + +openModeToCInt :: OpenMode -> CInt +openModeToCInt OREADER = #const FDBOREADER +openModeToCInt OWRITER = #const FDBOWRITER +openModeToCInt OCREAT = #const FDBOCREAT +openModeToCInt OTRUNC = #const FDBOTRUNC +openModeToCInt ONOLCK = #const FDBONOLCK +openModeToCInt OLCKNB = #const FDBOLCKNB + +combineOpenMode :: [OpenMode] -> CInt +combineOpenMode = foldr ((.|.) . openModeToCInt) 0 + +data ID = + IDMIN | + IDPREV | + IDMAX | + IDNEXT | + ID Int64 + deriving (Eq, Ord) + +instance Show ID where + show IDMIN = "min" + show IDPREV = "prev" + show IDMAX = "max" + show IDNEXT = "next" + show (ID i) = show i + +unID :: ID -> Int64 +unID IDMIN = #const FDBIDMIN +unID IDPREV = #const FDBIDPREV +unID IDMAX = #const FDBIDMAX +unID IDNEXT = #const FDBIDNEXT +unID (ID int) = int + +data FDB' + +foreign import ccall safe "tcfdberrmsg" + c_tcfdberrmsg :: CInt -> CString + +foreign import ccall safe "tcfdbnew" + c_tcfdbnew :: IO (Ptr FDB') + +foreign import ccall safe "tcfdbdel" + c_tcfdbdel :: Ptr FDB' -> IO () + +foreign import ccall safe "&tcfdbdel" + tcfdbFinalizer :: FunPtr (Ptr FDB' -> IO ()) + +foreign import ccall safe "tcfdbecode" + c_tcfdbecode :: Ptr FDB' -> IO CInt + +foreign import ccall safe "tcfdbsetmutex" + c_tcfdbsetmutex :: Ptr FDB' -> IO Bool + +foreign import ccall safe "tcfdbtune" + c_tcfdbtune :: Ptr FDB' -> Int32 -> Int64 -> IO Bool + +foreign import ccall safe "tcfdbopen" + c_tcfdbopen :: Ptr FDB' -> CString -> CInt -> IO Bool + +foreign import ccall safe "tcfdbclose" + c_tcfdbclose :: Ptr FDB' -> IO Bool + +foreign import ccall safe "tcfdbput" + c_tcfdbput :: Ptr FDB' -> Int64 -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tcfdbput2" + c_tcfdbput2 :: Ptr FDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tcfdbput3" + c_tcfdbput3 :: Ptr FDB' -> CString -> CString -> IO Bool + +foreign import ccall safe "tcfdbputkeep" + c_tcfdbputkeep :: Ptr FDB' -> Int64 -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tcfdbputkeep2" + c_tcfdbputkeep2 :: + Ptr FDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tcfdbputkeep3" + c_tcfdbputkeep3 :: Ptr FDB' -> CString -> CString -> IO Bool + +foreign import ccall safe "tcfdbputcat" + c_tcfdbputcat :: Ptr FDB' -> Int64 -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tcfdbputcat2" + c_tcfdbputcat2 :: Ptr FDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tcfdbputcat3" + c_tcfdbputcat3 :: Ptr FDB' -> CString -> CString -> IO Bool + +foreign import ccall safe "tcfdbout" + c_tcfdbout :: Ptr FDB' -> Int64 -> IO Bool + +foreign import ccall safe "tcfdbout2" + c_tcfdbout2 :: Ptr FDB' -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tcfdbout3" + c_tcfdbout3 :: Ptr FDB' -> CString -> IO Bool + +foreign import ccall safe "tcfdbget" + c_tcfdbget :: Ptr FDB' -> Int64 -> Ptr CInt -> IO (Ptr Word8) + +foreign import ccall safe "tcfdbget2" + c_tcfdbget2 :: Ptr FDB' -> Ptr Word8 -> CInt -> Ptr CInt -> IO (Ptr Word8) + +foreign import ccall safe "tcfdbget3" + c_tcfdbget3 :: Ptr FDB' -> CString -> IO CString + +foreign import ccall safe "tcfdbget4" + c_tcfdbget4 :: Ptr FDB' -> Int64 -> Ptr Word8 -> CInt -> IO CInt + +foreign import ccall safe "tcfdbvsiz" + c_tcfdbvsiz :: Ptr FDB' -> Int64 -> IO CInt + +foreign import ccall safe "tcfdbvsiz2" + c_tcfdbvsiz2 :: Ptr FDB' -> Ptr Word8 -> CInt -> IO CInt + +foreign import ccall safe "tcfdbvsiz3" + c_tcfdbvsiz3 :: Ptr FDB' -> CString -> IO CInt + +foreign import ccall safe "tcfdbiterinit" + c_tcfdbiterinit :: Ptr FDB' -> IO Bool + +foreign import ccall safe "tcfdbiternext" + c_tcfdbiternext :: Ptr FDB' -> IO Int64 + +foreign import ccall safe "tcfdbiternext2" + c_tcfdbiternext2 :: Ptr FDB' -> Ptr CInt -> IO (Ptr Word8) + +foreign import ccall safe "tcfdbiternext3" + c_tcfdbiternext3 :: Ptr FDB' -> IO CString + +foreign import ccall safe "tcfdbrange" + c_tcfdbrange :: + Ptr FDB' -> Int64 -> Int64 -> CInt -> Ptr CInt -> IO (Ptr Int64) + +foreign import ccall safe "tcfdbrange2" + c_tcfdbrange2 :: + Ptr FDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> CInt -> IO (Ptr LIST) + +foreign import ccall safe "tcfdbrange3" + c_tcfdbrange3 :: Ptr FDB' -> CString -> CString -> CInt -> IO (Ptr LIST) + +foreign import ccall safe "tcfdbrange4" + c_tcfdbrange4 :: Ptr FDB' -> Ptr Word8 -> CInt -> CInt -> IO (Ptr LIST) + +foreign import ccall safe "tcfdbrange5" + c_tcfdbrange5 :: Ptr FDB' -> Ptr Word8 -> CInt -> IO (Ptr LIST) + +foreign import ccall safe "tcfdbaddint" + c_tcfdbaddint :: Ptr FDB' -> Int64 -> CInt -> IO CInt + +foreign import ccall safe "tcfdbadddouble" + c_tcfdbadddouble :: Ptr FDB' -> Int64 -> CDouble -> IO CDouble + +foreign import ccall safe "tcfdbsync" + c_tcfdbsync :: Ptr FDB' -> IO Bool + +foreign import ccall safe "tcfdboptimize" + c_tcfdboptimize :: Ptr FDB' -> Int32 -> Int64 -> IO Bool + +foreign import ccall safe "tcfdbvanish" + c_tcfdbvanish :: Ptr FDB' -> IO Bool + +foreign import ccall safe "tcfdbcopy" + c_tcfdbcopy :: Ptr FDB' -> CString -> IO Bool + +foreign import ccall safe "tcfdbpath" + c_tcfdbpath :: Ptr FDB' -> IO CString + +foreign import ccall safe "tcfdbrnum" + c_tcfdbrnum :: Ptr FDB' -> IO Int64 + +foreign import ccall safe "tcfdbfsiz" + c_tcfdbfsiz :: Ptr FDB' -> IO Int64 diff --git a/Database/TokyoCabinet/FDB/Key.hs b/Database/TokyoCabinet/FDB/Key.hs new file mode 100644 --- /dev/null +++ b/Database/TokyoCabinet/FDB/Key.hs @@ -0,0 +1,59 @@ +{-# LANGUAGE TypeSynonymInstances #-} +module Database.TokyoCabinet.FDB.Key (Key(..), ID(..)) where + +import Database.TokyoCabinet.FDB.C (ID(..), unID) + +import Data.Int +import Data.Word + +class Key a where + toID :: a -> ID + fromID :: ID -> a + +instance Key Int where + toID = ID . fromIntegral + fromID = fromIntegral . unID + +instance Key Int8 where + toID = ID . fromIntegral + fromID = fromIntegral . unID + +instance Key Int16 where + toID = ID . fromIntegral + fromID = fromIntegral . unID + +instance Key Int32 where + toID = ID . fromIntegral + fromID = fromIntegral . unID + +instance Key Int64 where + toID = ID + fromID = fromIntegral . unID + +instance Key Word8 where + toID = ID . fromIntegral + fromID = fromIntegral . unID + +instance Key Word16 where + toID = ID . fromIntegral + fromID = fromIntegral . unID + +instance Key Word32 where + toID = ID . fromIntegral + fromID = fromIntegral . unID + +instance Key Word64 where + toID = ID . fromIntegral + fromID = fromIntegral . unID + +instance Key ID where + toID = id + fromID = id + +instance Key String where + toID "min" = IDMIN + toID "max" = IDMAX + toID "prev" = IDPREV + toID "next" = IDNEXT + toID idstr = ID (read idstr) + fromID = show . unID diff --git a/Database/TokyoCabinet/HDB.hs b/Database/TokyoCabinet/HDB.hs new file mode 100644 --- /dev/null +++ b/Database/TokyoCabinet/HDB.hs @@ -0,0 +1,257 @@ +-- | Interface to Hash based DBM. See also, +-- for details +module Database.TokyoCabinet.HDB + ( + -- $doc + -- * Constructors + HDB + , ECODE(..) + , OpenMode(..) + , TuningOption(..) + -- * Basic API (tokyocabinet.idl compliant) + , new + , delete + , ecode + , errmsg + , tune + , setcache + , setxmsiz + , open + , close + , put + , putkeep + , putcat + , putasync + , out + , get + , vsiz + , iterinit + , iternext + , fwmkeys + , addint + , adddouble + , sync + , optimize + , vanish + , copy + , tranbegin + , trancommit + , tranabort + , path + , rnum + , fsiz + ) + where + +import Foreign.Storable (peek) +import Foreign.ForeignPtr +import Foreign.Marshal (alloca) +import Foreign.Marshal.Utils (maybePeek) + +import Data.Int + +import Database.TokyoCabinet.HDB.C +import Database.TokyoCabinet.Error +import Database.TokyoCabinet.Internal +import qualified Database.TokyoCabinet.Storable as S + +-- $doc +-- Example +-- +-- @ +-- import Control.Monad +-- import Database.TokyoCabinet.HDB +-- @ +-- +-- @ +-- main = do hdb <- new +-- -- open the database +-- open hdb \"casket.tch\" [OWRITER, OCREAT] >>= err hdb +-- -- store records +-- puts hdb [(\"foo\", \"hop\"), (\"bar\", \"step\"), (\"baz\", \"jump\")] >>= +-- err hdb . (all id) +-- -- retrieve records +-- get_print hdb \"foo\" +-- -- traverse records +-- iterinit hdb +-- iter hdb >>= mapM_ (\k -> putStr (k++\":\") >> get_print hdb k) +-- -- close the database +-- close hdb >>= err hdb +-- where +-- puts :: HDB -> [(String, String)] -> IO [Bool] +-- puts hdb = mapM (uncurry $ put hdb) +-- @ +-- +-- @ +-- get_print :: HDB -> String -> IO () +-- get_print hdb key = get hdb key >>= +-- maybe (error \"something goes wrong\") putStrLn +-- @ +-- +-- @ +-- err :: HDB -> Bool -> IO () +-- err hdb = flip unless $ ecode hdb >>= error . show +-- @ +-- +-- @ +-- iter :: HDB -> IO [String] +-- iter hdb = iternext hdb >>= +-- maybe (return []) (\x -> return . (x:) =<< iter hdb) +-- @ +-- + +data HDB = HDB { unTCHDB :: !(ForeignPtr HDB') } + +-- | Create a Hash database object. +new :: IO HDB +new = HDB `fmap` (c_tchdbnew >>= newForeignPtr tchdbFinalizer) + +-- | Free HDB resource forcibly. +-- HDB is kept by ForeignPtr, so Haskell runtime GC cleans up memory for +-- almost situation. Most always, you don't need to call this. +-- After call this, you must not touch HDB object. Its behavior is undefined. +delete :: HDB -> IO () +delete hdb = finalizeForeignPtr (unTCHDB hdb) + +-- | Return the last happened error code. +ecode :: HDB -> IO ECODE +ecode hdb = cintToError `fmap` withForeignPtr (unTCHDB hdb) c_tchdbecode + +-- | Set the tuning parameters. +tune :: HDB -- ^ HDB object + -> Int64 -- ^ the number of elements of the bucket array. + -> Int8 -- ^ the size of record alignment by power of 2. + -> Int8 -- ^ the maximum number of elements of the free block + -- pool by power of 2. + -> [TuningOption] -- ^ tuning options. + -> IO Bool -- ^ if successful, the return value is True. +tune hdb bnum apow fpow options = + withForeignPtr (unTCHDB hdb) $ \p -> + c_tchdbtune p bnum apow fpow (combineTuningOption options) + +-- | Set the caching parameters. +setcache :: HDB -- ^ HDB object. + -> Int32 -- ^ the maximum number of records to be cached. + -> IO Bool -- ^ if successful, the return value is True. +setcache hdb rcnum = withForeignPtr (unTCHDB hdb) (flip c_tchdbsetcache rcnum) + +-- | Set the size of extra mapped memory. +setxmsiz :: HDB -> Int64 -> IO Bool +setxmsiz hdb xmsiz = withForeignPtr (unTCHDB hdb) (flip c_tchdbsetxmsiz xmsiz) + +-- | Open a database file. +open :: HDB -> String -> [OpenMode] -> IO Bool +open = openHelper c_tchdbopen unTCHDB combineOpenMode + +-- | Close the database file. +close :: HDB -> IO Bool +close hdb = withForeignPtr (unTCHDB hdb) c_tchdbclose + +-- | Stora a record (key-value pair) on HDB. Key and value type must +-- be instance of Storable class. Usually, we can use `String', +-- `ByteString' for key, `String', `ByteString', `Int', `Double' for +-- value. +put :: (S.Storable k, S.Storable v) => HDB -> k -> v -> IO Bool +put = putHelper c_tchdbput unTCHDB + +-- | Store a new record. If a record with the same key exists in the +-- database, this function has no effect. +putkeep :: (S.Storable k, S.Storable v) => HDB -> k -> v -> IO Bool +putkeep = putHelper c_tchdbputkeep unTCHDB + +-- | Concatenate a value at the end of the existing record. +putcat :: (S.Storable k, S.Storable v) => HDB -> k -> v -> IO Bool +putcat = putHelper c_tchdbputcat unTCHDB + +-- | Store a record into a hash database object in asynchronous fashion. +putasync :: (S.Storable k, S.Storable v) => HDB -> k -> v -> IO Bool +putasync = putHelper c_tchdbputasync unTCHDB + +-- | Delete a record. +out :: (S.Storable k) => HDB -> k -> IO Bool +out = outHelper c_tchdbout unTCHDB + +-- | Return the value of record. +get :: (S.Storable k, S.Storable v) => HDB -> k -> IO (Maybe v) +get = getHelper c_tchdbget unTCHDB + +-- | Return the byte size of value in a record. +vsiz :: (S.Storable k) => HDB -> k -> IO (Maybe Int) +vsiz = vsizHelper c_tchdbvsiz unTCHDB + +-- | Initialize the iterator of a HDB object. +iterinit :: HDB -> IO Bool +iterinit hdb = withForeignPtr (unTCHDB hdb) c_tchdbiterinit + +-- | Return the next key of the iterator of a HDB object. +iternext :: (S.Storable k) => HDB -> IO (Maybe k) +iternext hdb = + withForeignPtr (unTCHDB hdb) $ \p -> + alloca $ \sizbuf -> do + vbuf <- c_tchdbiternext p sizbuf + flip maybePeek vbuf $ \vp -> + do siz <- peek sizbuf + S.peekPtrLen (vp, siz) + +-- | Return list of forward matched keys. +fwmkeys :: (S.Storable k1, S.Storable k2) => HDB -> k1 -> Int -> IO [k2] +fwmkeys = fwmHelper c_tchdbfwmkeys unTCHDB + +-- | Increment the corresponding value. (The value specified by a key +-- is treated as integer.) +addint :: (S.Storable k) => HDB -> k -> Int -> IO (Maybe Int) +addint = addHelper c_tchdbaddint unTCHDB fromIntegral fromIntegral (== cINT_MIN) + +-- | Increment the corresponding value. (The value specified by a key +-- is treated as double.) +adddouble :: (S.Storable k) => HDB -> k -> Double -> IO (Maybe Double) +adddouble = addHelper c_tchdbadddouble unTCHDB realToFrac realToFrac isNaN + +-- | Synchronize updated contents of a database object with the file +-- and the device. +sync :: HDB -> IO Bool +sync hdb = withForeignPtr (unTCHDB hdb) c_tchdbsync + +-- | Optimize the file of a Hash database object. +optimize :: HDB -- ^ HDB object + -> Int64 -- ^ the number of elements of the bucket array. + -> Int8 -- ^ the size of record alignment by power of 2. + -> Int8 -- ^ the maximum number of elements of the free block + -- pool by power of 2. + -> [TuningOption] -- ^ tuning options. + -> IO Bool -- ^ if successful, the return value is True. +optimize hdb bnum apow fpow options = + withForeignPtr (unTCHDB hdb) $ \p -> + c_tchdboptimize p bnum apow fpow (combineTuningOption options) + +-- | Delete all records. +vanish :: HDB -> IO Bool +vanish hdb = withForeignPtr (unTCHDB hdb) c_tchdbvanish + +-- | Copy the database file. +copy :: HDB -> String -> IO Bool +copy = copyHelper c_tchdbcopy unTCHDB + +-- | Begin the transaction. +tranbegin :: HDB -> IO Bool +tranbegin hdb = withForeignPtr (unTCHDB hdb) c_tchdbtranbegin + +-- | Commit the transaction. +trancommit :: HDB -> IO Bool +trancommit hdb = withForeignPtr (unTCHDB hdb) c_tchdbtrancommit + +-- | Abort the transaction. +tranabort :: HDB -> IO Bool +tranabort hdb = withForeignPtr (unTCHDB hdb) c_tchdbtranabort + +-- | Return the file path of currentry opened database. +path :: HDB -> IO (Maybe String) +path = pathHelper c_tchdbpath unTCHDB + +-- | Return the number of records in the database. +rnum :: HDB -> IO Int64 +rnum hdb = withForeignPtr (unTCHDB hdb) c_tchdbrnum + +-- | Return the size of the database file. +fsiz :: HDB -> IO Int64 +fsiz hdb = withForeignPtr (unTCHDB hdb) c_tchdbfsiz diff --git a/Database/TokyoCabinet/HDB/C.hsc b/Database/TokyoCabinet/HDB/C.hsc new file mode 100644 --- /dev/null +++ b/Database/TokyoCabinet/HDB/C.hsc @@ -0,0 +1,167 @@ +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +module Database.TokyoCabinet.HDB.C where + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.String + +import Data.Int +import Data.Word +import Data.Bits + +import Database.TokyoCabinet.List.C (LIST) + +#include + +data OpenMode = + OREADER | + OWRITER | + OCREAT | + OTRUNC | + ONOLCK | + OLCKNB | + OTSYNC + deriving (Eq, Ord, Show) + +openModeToCInt :: OpenMode -> CInt +openModeToCInt OREADER = #const HDBOREADER +openModeToCInt OWRITER = #const HDBOWRITER +openModeToCInt OCREAT = #const HDBOCREAT +openModeToCInt OTRUNC = #const HDBOTRUNC +openModeToCInt ONOLCK = #const HDBONOLCK +openModeToCInt OLCKNB = #const HDBOLCKNB +openModeToCInt OTSYNC = #const HDBOTSYNC + +combineOpenMode :: [OpenMode] -> CInt +combineOpenMode = foldr ((.|.) . openModeToCInt) 0 + +data TuningOption = + TLARGE | + TDEFLATE | + TBZIP | + TTCBS | + TEXCODEC + deriving (Eq, Ord, Show) + +tuningOptionToWord8 :: TuningOption -> Word8 +tuningOptionToWord8 TLARGE = #const HDBTLARGE +tuningOptionToWord8 TDEFLATE = #const HDBTDEFLATE +tuningOptionToWord8 TBZIP = #const HDBTBZIP +tuningOptionToWord8 TTCBS = #const HDBTTCBS +tuningOptionToWord8 TEXCODEC = #const HDBTEXCODEC + +combineTuningOption :: [TuningOption] -> Word8 +combineTuningOption = foldr ((.|.) . tuningOptionToWord8) 0 + +data HDB' + +foreign import ccall "&tchdbdel" + tchdbFinalizer :: FunPtr (Ptr HDB' -> IO ()) + +foreign import ccall safe "tchdbnew" + c_tchdbnew :: IO (Ptr HDB') + +foreign import ccall safe "tchdbdel" + c_tchdbdel :: Ptr HDB' -> IO () + +foreign import ccall safe "tchdbecode" + c_tchdbecode :: Ptr HDB' -> IO CInt + +foreign import ccall safe "tchdbtune" + c_tchdbtune :: Ptr HDB' -> Int64 -> Int8 -> Int8 -> Word8 -> IO Bool + +foreign import ccall safe "tchdbsetcache" + c_tchdbsetcache :: Ptr HDB' -> Int32 -> IO Bool + +foreign import ccall safe "tchdbsetxmsiz" + c_tchdbsetxmsiz :: Ptr HDB' -> Int64 -> IO Bool + +foreign import ccall safe "tchdbopen" + c_tchdbopen :: Ptr HDB' -> CString -> CInt -> IO Bool + +foreign import ccall safe "tchdbclose" + c_tchdbclose :: Ptr HDB' -> IO Bool + +foreign import ccall safe "tchdbput" + c_tchdbput :: Ptr HDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tchdbput2" + c_tchdbput2 :: Ptr HDB' -> CString -> CString -> IO Bool + +foreign import ccall safe "tchdbputkeep" + c_tchdbputkeep :: Ptr HDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tchdbputkeep2" + c_tchdbputkeep2 :: Ptr HDB' -> CString -> CString -> IO Bool + +foreign import ccall safe "tchdbputcat" + c_tchdbputcat :: Ptr HDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tchdbputcat2" + c_tchdbputcat2 :: Ptr HDB' -> CString -> CString -> IO Bool + +foreign import ccall safe "tchdbputasync" + c_tchdbputasync :: Ptr HDB' -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tchdbout" + c_tchdbout :: Ptr HDB' -> Ptr Word8 -> CInt -> IO Bool + +foreign import ccall safe "tchdbout2" + c_tchdbout2 :: Ptr HDB' -> CString -> IO Bool + +foreign import ccall safe "tchdbget" + c_tchdbget :: Ptr HDB' -> Ptr Word8 -> CInt -> Ptr CInt -> IO (Ptr Word8) + +foreign import ccall safe "tchdbget2" + c_tchdbget2 :: Ptr HDB' -> CString -> IO CString + +foreign import ccall safe "tchdbvsiz" + c_tchdbvsiz :: Ptr HDB' -> Ptr Word8 -> CInt -> IO CInt + +foreign import ccall safe "tchdbiterinit" + c_tchdbiterinit :: Ptr HDB' -> IO Bool + +foreign import ccall safe "tchdbiternext" + c_tchdbiternext :: Ptr HDB' -> Ptr CInt -> IO (Ptr Word8) + +foreign import ccall safe "tchdbiternext2" + c_tchdbiternext2 :: Ptr HDB' -> IO CString + +foreign import ccall safe "tchdbfwmkeys" + c_tchdbfwmkeys :: Ptr HDB' -> Ptr Word8 -> CInt -> CInt -> IO (Ptr LIST) + +foreign import ccall safe "tchdbaddint" + c_tchdbaddint :: Ptr HDB' -> Ptr Word8 -> CInt -> CInt -> IO CInt + +foreign import ccall safe "tchdbadddouble" + c_tchdbadddouble :: Ptr HDB' -> Ptr Word8 -> CInt -> CDouble -> IO CDouble + +foreign import ccall safe "tchdbsync" + c_tchdbsync :: Ptr HDB' -> IO Bool + +foreign import ccall safe "tchdboptimize" + c_tchdboptimize :: Ptr HDB' -> Int64 -> Int8 -> Int8 -> Word8 -> IO Bool + +foreign import ccall safe "tchdbvanish" + c_tchdbvanish :: Ptr HDB' -> IO Bool + +foreign import ccall safe "tchdbcopy" + c_tchdbcopy :: Ptr HDB' -> CString -> IO Bool + +foreign import ccall safe "tchdbtranbegin" + c_tchdbtranbegin :: Ptr HDB' -> IO Bool + +foreign import ccall safe "tchdbtrancommit" + c_tchdbtrancommit :: Ptr HDB' -> IO Bool + +foreign import ccall safe "tchdbtranabort" + c_tchdbtranabort :: Ptr HDB' -> IO Bool + +foreign import ccall safe "tchdbpath" + c_tchdbpath :: Ptr HDB' -> IO CString + +foreign import ccall safe "tchdbrnum" + c_tchdbrnum :: Ptr HDB' -> IO Int64 + +foreign import ccall safe "tchdbfsiz" + c_tchdbfsiz :: Ptr HDB' -> IO Int64 diff --git a/Database/TokyoCabinet/Internal.hs b/Database/TokyoCabinet/Internal.hs new file mode 100644 --- /dev/null +++ b/Database/TokyoCabinet/Internal.hs @@ -0,0 +1,115 @@ +module Database.TokyoCabinet.Internal where + +import Database.TokyoCabinet.List.C +import Database.TokyoCabinet.Storable + +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.C.Types +import Foreign.C.String +import Foreign.Storable (peek) +import Foreign.Marshal (alloca) +import Foreign.Marshal.Utils (maybePeek) + +import Data.Word + +peekTCListAndFree :: (Storable a) => Ptr LIST -> IO [a] +peekTCListAndFree list = do + vals <- peekTCList' list [] + c_tclistdel list + return vals + where + peekTCList' tclist acc = + alloca $ \sizbuf -> + do val <- c_tclistpop tclist sizbuf + siz <- peek sizbuf + if val == nullPtr + then return acc + else do elm <- peekPtrLen (val, siz) + peekTCList' tclist (elm:acc) + +type Lifter ptr tcdb = Ptr ptr -> tcdb +type UnLifter tcdb fptr = tcdb -> ForeignPtr fptr +type Combiner mode c_mode = [mode] -> c_mode +type Caster a b = a -> b +type Checker a = a -> Bool + +type FunOpen p c_mode = Ptr p -> CString -> c_mode -> IO Bool +type FunPath p = Ptr p -> IO CString +type FunCopy p = Ptr p -> CString -> IO Bool +type FunPut p = Ptr p -> Ptr Word8 -> CInt -> Ptr Word8 -> CInt -> IO Bool +type FunGet p = Ptr p -> Ptr Word8 -> CInt -> Ptr CInt -> IO (Ptr Word8) +type FunOut p = Ptr p -> Ptr Word8 -> CInt -> IO Bool +type FunAdd p n = Ptr p -> Ptr Word8 -> CInt -> n -> IO n +type FunFwm p = Ptr p -> Ptr Word8 -> CInt -> CInt -> IO (Ptr LIST) +type FunVsiz p = Ptr p -> Ptr Word8 -> CInt -> IO CInt + +openHelper :: FunOpen p c_mode -> UnLifter tcdb p + -> Combiner mode c_mode -> tcdb -> String -> [mode] -> IO Bool +openHelper opener unlifter combiner tcdb name modes = + withForeignPtr (unlifter tcdb) $ \db -> + withCString name $ \c_name -> + opener db c_name (combiner modes) + +pathHelper :: FunPath p -> UnLifter tcdb p -> tcdb -> IO (Maybe String) +pathHelper c_path unlifter tcdb = + withForeignPtr (unlifter tcdb) $ \db -> + c_path db >>= (maybePeek peekCString) + +copyHelper :: FunCopy p -> UnLifter tcdb p -> tcdb -> String -> IO Bool +copyHelper c_copy unlifter tcdb fpath = + withForeignPtr (unlifter tcdb) $ \db -> withCString fpath (c_copy db) + +putHelper :: (Storable a, Storable b) => + FunPut p -> UnLifter tcdb p -> tcdb -> a -> b -> IO Bool +putHelper c_put unlifter tcdb key val = + withForeignPtr (unlifter tcdb) $ \db -> + withPtrLen key $ \(kbuf, ksize) -> + withPtrLen val $ \(vbuf, vsize) -> c_put db kbuf ksize vbuf vsize + +getHelper :: (Storable a, Storable b) => + FunGet p -> UnLifter tcdb p -> tcdb -> a -> IO (Maybe b) +getHelper c_get unlifter tcdb key = + withForeignPtr (unlifter tcdb) $ \db -> + withPtrLen key $ \(kbuf, ksiz) -> + alloca $ \sizbuf -> do + vbuf <- c_get db kbuf ksiz sizbuf + flip maybePeek vbuf $ \vp -> + do siz <- peek sizbuf + peekPtrLen (vp, siz) + +outHelper :: (Storable a) => + FunOut p -> UnLifter tcdb p -> tcdb -> a -> IO Bool +outHelper c_out unlifter tcdb key = + withForeignPtr (unlifter tcdb) $ \db -> + withPtrLen key $ \(kbuf, ksize) -> c_out db kbuf ksize + +addHelper :: (Storable a) => + FunAdd p n -> UnLifter tcdb p + -> Caster hv n -> Caster n hv -> Checker n + -> tcdb -> a -> hv -> IO (Maybe hv) +addHelper c_add unlifter cast_in cast_out check tcdb key num = + withForeignPtr (unlifter tcdb) $ \db -> + withPtrLen key $ \(kbuf, ksiz) -> do + sumval <- c_add db kbuf ksiz (cast_in num) + return $ if check sumval + then Nothing + else Just $ cast_out sumval + + +fwmHelper :: (Storable a, Storable b) => + FunFwm p -> UnLifter tcdb p -> tcdb -> a -> Int -> IO [b] +fwmHelper c_fwm unlifter tcdb key maxn = + withForeignPtr (unlifter tcdb) $ \db -> + withPtrLen key $ \(kbuf, ksiz) -> + c_fwm db kbuf ksiz (fromIntegral maxn) >>= peekTCListAndFree + +vsizHelper :: (Storable a) => + FunVsiz p -> UnLifter tcdb p -> tcdb -> a -> IO (Maybe Int) +vsizHelper c_vsiz unlifter tcdb key = + withForeignPtr (unlifter tcdb) $ \db -> + withPtrLen key $ \(kbuf, ksiz) -> do + vsize <- c_vsiz db kbuf ksiz + return $ if vsize == -1 + then Nothing + else Just (fromIntegral vsize) diff --git a/Database/TokyoCabinet/List.hs b/Database/TokyoCabinet/List.hs new file mode 100644 --- /dev/null +++ b/Database/TokyoCabinet/List.hs @@ -0,0 +1,159 @@ +module Database.TokyoCabinet.List + ( + new + , new2 + , copy + , delete + , len + , get + , push + , pop + , unshift + , shift + , insert + , remove + , over + , sort + , lsearch + , bsearch + , clear + , dump + , load + , TCList + ) where + +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.Storable (peek) +import Foreign.Marshal (alloca, free, mallocBytes) +import Foreign.Marshal.Utils (maybePeek, copyBytes) + +import Database.TokyoCabinet.List.C +import qualified Database.TokyoCabinet.Storable as S + +import Data.ByteString.Unsafe +import qualified Data.ByteString as B + +data TCList = TCList { unTCList :: !(ForeignPtr LIST) } + +new :: IO TCList +new = c_tclistnew >>= newForeignPtr tclistFinalizer >>= return . TCList + +new2 :: Int -> IO TCList +new2 n = do + l <- c_tclistnew2 (fromIntegral n) + p <- newForeignPtr tclistFinalizer l + return $ TCList p + +copy :: TCList -> IO TCList +copy tcls = + withForeignPtr (unTCList tcls) $ \p -> do + l <- c_tclistdup p + TCList `fmap` newForeignPtr tclistFinalizer l + +delete :: TCList -> IO () +delete tcls = finalizeForeignPtr (unTCList tcls) + +len :: TCList -> IO Int +len tcls = + withForeignPtr (unTCList tcls) $ \p -> do + n <- c_tclistnum p + return $ fromIntegral n + +get :: (S.Storable a) => TCList -> Int -> IO (Maybe a) +get tcls index = + withForeignPtr (unTCList tcls) $ \p -> + alloca $ \sizbuf -> do + vbuf <- c_tclistval p (fromIntegral index) sizbuf + flip maybePeek vbuf $ \vp -> + do siz <- peek sizbuf + buf <- mallocBytes (fromIntegral siz) + copyBytes buf vp (fromIntegral siz) + S.peekPtrLen (buf, fromIntegral siz) + +push :: (S.Storable a) => TCList -> a -> IO () +push tcls val = + withForeignPtr (unTCList tcls) $ \p -> + S.withPtrLen val $ \(vbuf, vsiz) -> + c_tclistpush p (castPtr vbuf) (fromIntegral vsiz) + +pop :: (S.Storable a) => TCList -> IO (Maybe a) +pop tcls = + withForeignPtr (unTCList tcls) $ \p -> + alloca $ \sizbuf -> do + vbuf <- c_tclistpop p sizbuf + flip maybePeek vbuf $ \vp -> + do siz <- peek sizbuf + S.peekPtrLen (vp, fromIntegral siz) + +unshift :: (S.Storable a) => TCList -> a -> IO () +unshift tcls val = + withForeignPtr (unTCList tcls) $ \p -> + S.withPtrLen val $ \(vbuf, vsiz) -> + c_tclistunshift p (castPtr vbuf) (fromIntegral vsiz) + +shift :: (S.Storable a) => TCList -> IO (Maybe a) +shift tcls = + withForeignPtr (unTCList tcls) $ \p -> + alloca $ \sizbuf -> do + vbuf <- c_tclistshift p sizbuf + flip maybePeek vbuf $ \vp -> + do siz <- peek sizbuf + S.peekPtrLen (vp, fromIntegral siz) + +insert :: (S.Storable a) => TCList -> Int -> a -> IO () +insert tcls index val = + withForeignPtr (unTCList tcls) $ \p -> + S.withPtrLen val $ \(vbuf, vsiz) -> + c_tclistinsert p (fromIntegral index) (castPtr vbuf) + (fromIntegral vsiz) + +remove :: (S.Storable a) => TCList -> Int -> IO (Maybe a) +remove tcls index = + withForeignPtr (unTCList tcls) $ \p -> + alloca $ \sizbuf -> do + vbuf <- c_tclistremove p (fromIntegral index) sizbuf + flip maybePeek vbuf $ \vp -> + do siz <- peek sizbuf + S.peekPtrLen (vp, fromIntegral siz) + +over :: (S.Storable a) => TCList -> Int -> a -> IO () +over tcls index val = + withForeignPtr (unTCList tcls) $ \p -> + S.withPtrLen val $ \(vbuf, vsiz) -> + c_tclistover p (fromIntegral index) (castPtr vbuf) + (fromIntegral vsiz) + +sort :: TCList -> IO () +sort tcls = withForeignPtr (unTCList tcls) c_tclistsort + +lsearch :: (S.Storable a) => TCList -> a -> IO Int +lsearch tcls key = + withForeignPtr (unTCList tcls) $ \p -> + S.withPtrLen key $ \(kbuf, ksiz) -> + fmap fromIntegral $ + c_tclistlsearch p (castPtr kbuf) (fromIntegral ksiz) + +bsearch :: (S.Storable a) => TCList -> a -> IO Int +bsearch tcls key = + withForeignPtr (unTCList tcls) $ \p -> + S.withPtrLen key $ \(kbuf, ksiz) -> + fmap fromIntegral $ + c_tclistbsearch p (castPtr kbuf) (fromIntegral ksiz) + +clear :: TCList -> IO () +clear tcls = withForeignPtr (unTCList tcls) c_tclistclear + +dump :: TCList -> IO B.ByteString +dump tcls = + withForeignPtr (unTCList tcls) $ \p -> + alloca $ \sizbuf -> do + c_str <- c_tclistdump p sizbuf + size <- fromIntegral `fmap` peek sizbuf + unsafePackCStringFinalizer (castPtr c_str) size (free c_str) + +load :: B.ByteString -> IO TCList +load bytes = + unsafeUseAsCStringLen bytes $ \(buf, siz) -> do + tclis <- c_tclistload (castPtr buf) (fromIntegral siz) + TCList `fmap` newForeignPtr tclistFinalizer tclis diff --git a/Database/TokyoCabinet/List/C.hs b/Database/TokyoCabinet/List/C.hs new file mode 100644 --- /dev/null +++ b/Database/TokyoCabinet/List/C.hs @@ -0,0 +1,95 @@ +{-# INCLUDE #-} +{-# LANGUAGE ForeignFunctionInterface, EmptyDataDecls #-} +module Database.TokyoCabinet.List.C where + +import Data.Word + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.String + +data LIST + +foreign import ccall safe "tclistnew" + c_tclistnew :: IO (Ptr LIST) + +foreign import ccall safe "tclistnew2" + c_tclistnew2 :: CInt -> IO (Ptr LIST) + +foreign import ccall safe "tclistdup" + c_tclistdup :: Ptr LIST -> IO (Ptr LIST) + +foreign import ccall safe "tclistdel" + c_tclistdel :: Ptr LIST -> IO () + +foreign import ccall "&tclistdel" + tclistFinalizer :: FunPtr (Ptr LIST -> IO ()) + +foreign import ccall safe "tclistnum" + c_tclistnum :: Ptr LIST -> IO CInt + +foreign import ccall safe "tclistval" + c_tclistval :: Ptr LIST -> CInt -> Ptr CInt -> IO (Ptr Word8) + +foreign import ccall safe "tclistval2" + c_tclistval2 :: Ptr LIST -> CInt -> IO CString + +foreign import ccall safe "tclistpush" + c_tclistpush :: Ptr LIST -> Ptr Word8 -> CInt -> IO () + +foreign import ccall safe "tclistpush2" + c_tclistpush2 :: Ptr LIST -> CString -> IO () + +foreign import ccall safe "tclistpop" + c_tclistpop :: Ptr LIST -> Ptr CInt -> IO (Ptr Word8) + +foreign import ccall safe "tclistpop2" + c_tclistpop2 :: Ptr LIST -> IO CString + +foreign import ccall safe "tclistunshift" + c_tclistunshift :: Ptr LIST -> Ptr Word8 -> CInt -> IO () + +foreign import ccall safe "tclistunshift2" + c_tclistunshift2 :: Ptr LIST -> Ptr Word8 -> IO () + +foreign import ccall safe "tclistshift" + c_tclistshift :: Ptr LIST -> Ptr CInt -> IO (Ptr Word8) + +foreign import ccall safe "tclistshift2" + c_tclistshift2 :: Ptr LIST -> IO CString + +foreign import ccall safe "tclistinsert" + c_tclistinsert :: Ptr LIST -> CInt -> Ptr Word8 -> CInt -> IO () + +foreign import ccall safe "tclistinsert2" + c_tclistinsert2 :: Ptr LIST -> CInt -> Ptr Word8 -> IO () + +foreign import ccall safe "tclistremove" + c_tclistremove :: Ptr LIST -> CInt -> Ptr CInt -> IO (Ptr Word8) + +foreign import ccall safe "tclistremove2" + c_tclistremove2 :: Ptr LIST -> CInt -> IO CString + +foreign import ccall safe "tclistover" + c_tclistover :: Ptr LIST -> CInt -> Ptr Word8 -> CInt -> IO () + +foreign import ccall safe "tclistover2" + c_tclistover2 :: Ptr LIST -> CInt -> CString -> IO () + +foreign import ccall safe "tclistsort" + c_tclistsort :: Ptr LIST -> IO () + +foreign import ccall safe "tclistlsearch" + c_tclistlsearch :: Ptr LIST -> Ptr Word8 -> CInt -> IO CInt + +foreign import ccall safe "tclistbsearch" + c_tclistbsearch :: Ptr LIST -> Ptr Word8 -> CInt -> IO CInt + +foreign import ccall safe "tclistclear" + c_tclistclear :: Ptr LIST -> IO () + +foreign import ccall safe "tclistdump" + c_tclistdump :: Ptr LIST -> Ptr CInt -> IO (Ptr Word8) + +foreign import ccall safe "tclistload" + c_tclistload :: Ptr Word8 -> CInt -> IO (Ptr LIST) diff --git a/Database/TokyoCabinet/Storable.hs b/Database/TokyoCabinet/Storable.hs new file mode 100644 --- /dev/null +++ b/Database/TokyoCabinet/Storable.hs @@ -0,0 +1,187 @@ +module Database.TokyoCabinet.Storable where + +import Data.Int +import Data.Char +import Data.Word + +import Foreign.Ptr +import Foreign.C.Types +import Foreign.C.String +import Foreign.Marshal (peekArray, free) +import Foreign.Marshal.Array (withArray) +import Data.ByteString.Unsafe + +import qualified Foreign.Storable as F +import qualified Data.ByteString.Char8 as C +import qualified Data.ByteString.Lazy as L +import qualified Data.ByteString.Lazy.Char8 as LC +import qualified Foreign.Marshal.Utils as U + +type PtrLen = (Ptr Word8, CInt) + +liftPL :: (a -> (CStringLen -> IO b) -> IO b) -> a -> (PtrLen -> IO b) -> IO b +liftPL f val action = + f val $ \(buf, siz) -> + action (castPtr buf, fromIntegral siz) + +class (Show a, Read a) => Storable a where + withPtrLen :: a -> (PtrLen -> IO b) -> IO b + withPtrLenL :: [a] -> (PtrLen -> IO b) -> IO b + + peekPtrLenL :: PtrLen -> a -> IO [a] + peekPtrLen :: PtrLen -> IO a + + toInt64 :: a -> Int64 + toInt64L :: [a] -> Int64 + + fromString :: String -> a + fromStringL :: String -> [a] + + toInt64 = read . show + toInt64L = read . concatMap show + + fromString = read + fromStringL = (:[]) . fromString + + withPtrLenL = undefined + peekPtrLenL = undefined + +instance Storable C.ByteString where + withPtrLen = liftPL unsafeUseAsCStringLen + peekPtrLen (p, len) = + unsafePackCStringFinalizer p (fromIntegral len) (free p) + toInt64 = read . C.unpack + fromString = C.pack + +instance Storable L.ByteString where + withPtrLen = liftPL unsafeUseAsCStringLen . C.concat . L.toChunks + peekPtrLen (p, len) = do xs <- peekArray (fromIntegral len) p + free p + return $ L.pack xs + toInt64 = read . LC.unpack + fromString = LC.pack + +withPtrLenForFStorable :: (F.Storable a) => a -> (PtrLen -> IO b) -> IO b +withPtrLenForFStorable n f = + U.with n $ \p -> f (castPtr p, fromIntegral $ F.sizeOf n) + +peekPtrLenForFStorable :: (F.Storable a) => PtrLen -> IO a +peekPtrLenForFStorable (p, _) = do val <- F.peek (castPtr p) + free p + return val + +withPtrLenLForFStorable :: (F.Storable a) => [a] -> (PtrLen -> IO b) -> IO b +withPtrLenLForFStorable xs f = + withArray xs $ \p -> + f (castPtr p, fromIntegral $ (F.sizeOf $ head xs) * length xs) + +peekPtrLenLForFStorable :: (F.Storable a) => PtrLen -> a -> IO [a] +peekPtrLenLForFStorable (p, size) x = do + peekArray (fromIntegral size `div` (F.sizeOf x)) (castPtr p) + +instance Storable Char where + withPtrLen = withPtrLenForFStorable + peekPtrLen = peekPtrLenForFStorable + withPtrLenL = liftPL withCStringLen + peekPtrLenL (buf, siz) _ = + do val <- peekCStringLen (castPtr buf, fromIntegral siz) + free buf + return val + + toInt64 c | isDigit c = fromIntegral $ digitToInt c + toInt64 c | otherwise = fromIntegral $ ord c + + toInt64L cs = read cs + + fromString str = read ('\'':str ++ "'") + fromStringL = id + +instance Storable CInt where + withPtrLen = withPtrLenForFStorable + peekPtrLen = peekPtrLenForFStorable + withPtrLenL = withPtrLenLForFStorable + peekPtrLenL = peekPtrLenLForFStorable + +instance Storable Int where + withPtrLen = withPtrLenForFStorable + peekPtrLen = peekPtrLenForFStorable + withPtrLenL = withPtrLenLForFStorable + peekPtrLenL = peekPtrLenLForFStorable + +instance Storable CDouble where + withPtrLen = withPtrLenForFStorable + peekPtrLen = peekPtrLenForFStorable + withPtrLenL = withPtrLenLForFStorable + peekPtrLenL = peekPtrLenLForFStorable + +instance Storable Double where + withPtrLen = withPtrLenForFStorable + peekPtrLen = peekPtrLenForFStorable + withPtrLenL = withPtrLenLForFStorable + peekPtrLenL = peekPtrLenLForFStorable + +instance Storable CFloat where + withPtrLen = withPtrLenForFStorable + peekPtrLen = peekPtrLenForFStorable + withPtrLenL = withPtrLenLForFStorable + peekPtrLenL = peekPtrLenLForFStorable + +instance Storable Float where + withPtrLen = withPtrLenForFStorable + peekPtrLen = peekPtrLenForFStorable + withPtrLenL = withPtrLenLForFStorable + peekPtrLenL = peekPtrLenLForFStorable + +instance Storable Int8 where + withPtrLen = withPtrLenForFStorable + peekPtrLen = peekPtrLenForFStorable + withPtrLenL = withPtrLenLForFStorable + peekPtrLenL = peekPtrLenLForFStorable + +instance Storable Int16 where + withPtrLen = withPtrLenForFStorable + peekPtrLen = peekPtrLenForFStorable + withPtrLenL = withPtrLenLForFStorable + peekPtrLenL = peekPtrLenLForFStorable + +instance Storable Int32 where + withPtrLen = withPtrLenForFStorable + peekPtrLen = peekPtrLenForFStorable + withPtrLenL = withPtrLenLForFStorable + peekPtrLenL = peekPtrLenLForFStorable + +instance Storable Int64 where + withPtrLen = withPtrLenForFStorable + peekPtrLen = peekPtrLenForFStorable + withPtrLenL = withPtrLenLForFStorable + peekPtrLenL = peekPtrLenLForFStorable + +instance Storable Word8 where + withPtrLen = withPtrLenForFStorable + peekPtrLen = peekPtrLenForFStorable + withPtrLenL = withPtrLenLForFStorable + peekPtrLenL = peekPtrLenLForFStorable + +instance Storable Word16 where + withPtrLen = withPtrLenForFStorable + peekPtrLen = peekPtrLenForFStorable + withPtrLenL = withPtrLenLForFStorable + peekPtrLenL = peekPtrLenLForFStorable + +instance Storable Word32 where + withPtrLen = withPtrLenForFStorable + peekPtrLen = peekPtrLenForFStorable + withPtrLenL = withPtrLenLForFStorable + peekPtrLenL = peekPtrLenLForFStorable + +instance Storable Word64 where + withPtrLen = withPtrLenForFStorable + peekPtrLen = peekPtrLenForFStorable + withPtrLenL = withPtrLenLForFStorable + peekPtrLenL = peekPtrLenLForFStorable + +instance (F.Storable a, Storable a) => Storable [a] where + withPtrLen = withPtrLenL + peekPtrLen xs = peekPtrLenL xs undefined + toInt64 = toInt64L + fromString = fromStringL diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2009, Tom Tsuruhara +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. + + * The names of contributors may not be used to endorse or promote + products derived from this software without specific prior + written permission. + +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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,14 @@ +import Distribution.Simple +import Distribution.PackageDescription +import Distribution.Simple.LocalBuildInfo (LocalBuildInfo(..)) + +import System.Cmd (system) +import System.FilePath + +main = defaultMainWithHooks $ simpleUserHooks { runTests = myTestRunner } + +myTestRunner :: Args -> Bool -> PackageDescription -> LocalBuildInfo -> IO () +myTestRunner _ _ pkg_descr lbi = mapM_ (system . path) $ executables pkg_descr + where + path exec = let name = (dropExtension . exeName) exec + in (buildDir lbi) name name diff --git a/tokyocabinet-haskell.cabal b/tokyocabinet-haskell.cabal new file mode 100644 --- /dev/null +++ b/tokyocabinet-haskell.cabal @@ -0,0 +1,49 @@ +Name: tokyocabinet-haskell +Version: 0.0.1 +Cabal-Version: >= 1.6.0.2 +License: BSD3 +License-File: LICENSE +Author: Tom Tsuruhara +Maintainer: tom.lpsd@gmail.com +Stability: experimental +Category: Database +Synopsis: Haskell binding of Tokyo Cabinet +Description: + Bindings to Tokyo Cabinet library. + Tokyo Cabinet is a modern implementation of DBM. + For more about Tokyo Cabinet, see . + + This package provides `tokyocabinet.idl compliant' naive interfaces. + See, . + + Map interface and TDB have not supported yet. + +Tested-With: GHC +Build-Type: Simple + +Library + Build-Depends: base >= 4.0, bytestring >= 0.9, mtl >= 1.1 + Exposed-modules: + Database.TokyoCabinet, + Database.TokyoCabinet.HDB + Database.TokyoCabinet.HDB.C + Database.TokyoCabinet.BDB + Database.TokyoCabinet.BDB.C + Database.TokyoCabinet.BDB.Cursor + Database.TokyoCabinet.BDB.Cursor.C + Database.TokyoCabinet.FDB + Database.TokyoCabinet.FDB.C + Database.TokyoCabinet.FDB.Key + Database.TokyoCabinet.Error + Database.TokyoCabinet.List + Database.TokyoCabinet.List.C + Database.TokyoCabinet.Storable + other-modules: + Database.TokyoCabinet.Internal + Extensions: CPP, ForeignFunctionInterface, + EmptyDataDecls, TypeSynonymInstances, + GeneralizedNewtypeDeriving + Extra-libraries: tokyocabinet + Extra-lib-dirs: /usr/local/lib + Include-dirs: /usr/local/include + GHC-Options: -Wall