{-# 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.Sequence 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 import Data.Word -- $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, Sequence q) => a -- ^ database object -> k -- ^ search string -> Int -- ^ the maximum number of keys to be fetched -> TCM (q 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 Word64 -- | Get the size of the database file. size :: a -> TCM Word64 -- | 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"