~singpolyma/tokyocabinet-haskell

ref: b4fdd27f34c558e70464b38ae15123562c2a9278 tokyocabinet-haskell/Database/TokyoCabinet.hs -rw-r--r-- 14.0 KiB
b4fdd27f — tom.lpsd don't export ECODE from ADB module 11 years ago
                                                                                
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
module Database.TokyoCabinet
    (
    -- $doc
      TCM
    , runTCM
    , OpenMode(..)
    , TCDB(..)
    , H.HDB
    , F.FDB
    , T.TDB
    , 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.TDB as T
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"

openModeToTOpenMode :: OpenMode -> T.OpenMode
openModeToTOpenMode OREADER = T.OREADER
openModeToTOpenMode OWRITER = T.OWRITER
openModeToTOpenMode OCREAT  = T.OCREAT
openModeToTOpenMode OTRUNC  = T.OTRUNC
openModeToTOpenMode ONOLCK  = T.ONOLCK
openModeToTOpenMode OLCKNB  = T.OLCKNB

instance TCDB T.TDB where
    new               = TCM   T.new
    delete            = lift  T.delete
    open tc name mode = TCM $ T.open tc name (map openModeToTOpenMode mode)
    close             = lift  T.close
    put               = lift3 T.put'
    putkeep           = lift3 T.putkeep'
    putcat            = lift3 T.putcat'
    get               = lift2 T.get'
    out               = lift2 T.out
    vsiz              = lift2 T.vsiz
    iterinit          = lift  T.iterinit
    iternext          = lift  T.iternext
    fwmkeys           = lift3 T.fwmkeys
    addint            = lift3 T.addint
    adddouble         = lift3 T.adddouble
    sync              = lift  T.sync
    vanish            = lift  T.vanish
    copy              = lift2 T.copy
    path              = lift  T.path
    rnum              = lift  T.rnum
    size              = lift  T.fsiz
    ecode             = lift  T.ecode
    defaultExtension  = const ".tct"