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"
|
