forestdb/lib/lib.factor

   1 ! Copyright (C) 2014 Doug Coleman.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien.c-types alien.data alien.strings byte-arrays
   4 classes.struct combinators constructors continuations destructors
   5 forestdb.ffi fry generalizations io.directories io.encodings.string
   6 io.encodings.utf8 io.pathnames kernel libc math multiline namespaces
   7 sequences strings ;
   8 QUALIFIED: sets
   9 IN: forestdb.lib
  10
  11 /*
  12 ! Issues
  13 ! Get byseq ignores seqnum and uses key instead if key is set
  14 */
  15
  16 ERROR: fdb-error error ;
  17
  18 : fdb-check-error ( ret -- )
  19     dup FDB_RESULT_SUCCESS = [ drop ] [ fdb-error ] if ;
  20
  21
  22 TUPLE: fdb-kvs-handle < disposable handle ;
  23 : <fdb-kvs-handle> ( handle -- obj )
  24     fdb-kvs-handle new-disposable
  25         swap >>handle ; inline
  26
  27 M: fdb-kvs-handle dispose*
  28     handle>> fdb_kvs_close fdb-check-error ;
  29
  30
  31 TUPLE: fdb-file-handle < disposable handle ;
  32 : <fdb-file-handle> ( handle -- obj )
  33     fdb-file-handle new-disposable
  34         swap >>handle ; inline
  35
  36 M: fdb-file-handle dispose*
  37     handle>> fdb_close fdb-check-error ;
  38
  39
  40 SYMBOL: current-fdb-file-handle
  41 SYMBOL: current-fdb-kvs-handle
  42
  43 : get-file-handle ( -- handle )
  44     current-fdb-file-handle get handle>> ;
  45
  46 : get-kvs-handle ( -- handle )
  47     current-fdb-kvs-handle get handle>> ;
  48
  49 GENERIC: encode-kv ( object -- bytes )
  50
  51 M: string encode-kv utf8 encode ;
  52 M: byte-array encode-kv ;
  53
  54 : fdb-set-kv ( key value -- )
  55     [ get-kvs-handle ] 2dip
  56     [ encode-kv dup length ] bi@ fdb_set_kv fdb-check-error ;
  57
  58 : <key-doc> ( key -- doc )
  59     fdb_doc malloc-struct
  60         swap [ utf8 malloc-string >>key ] [ length >>keylen ] bi ;
  61
  62 : <seqnum-doc> ( seqnum -- doc )
  63     fdb_doc malloc-struct
  64         swap >>seqnum ;
  65
  66 ! Fill in document by exemplar
  67 : fdb-get ( doc -- doc )
  68     [ get-kvs-handle ] dip [ fdb_get fdb-check-error ] keep ;
  69
  70 : fdb-get-metaonly ( doc -- doc )
  71     [ get-kvs-handle ] dip [ fdb_get_metaonly fdb-check-error ] keep ;
  72
  73 : fdb-get-byseq ( doc -- doc )
  74     [ get-kvs-handle ] dip [ fdb_get_byseq fdb-check-error ] keep ;
  75
  76 : fdb-get-metaonly-byseq ( doc -- doc )
  77     [ get-kvs-handle ] dip [ fdb_get_metaonly_byseq fdb-check-error ] keep ;
  78
  79 : fdb-get-byoffset ( doc -- doc )
  80     [ get-kvs-handle ] dip [ fdb_get_byoffset fdb-check-error ] keep ;
  81
  82
  83 ! Set/delete documents
  84 : fdb-set ( doc -- )
  85     [ get-kvs-handle ] dip fdb_set fdb-check-error ;
  86
  87 : fdb-del ( doc -- )
  88     [ get-kvs-handle ] dip fdb_del fdb-check-error ;
  89
  90 : ret>string ( void** len -- string )
  91     [ void* deref ] [ size_t deref ] bi*
  92     memory>byte-array utf8 decode ;
  93
  94 : fdb-get-kv ( key -- value/f )
  95     [ get-kvs-handle ] dip
  96     utf8 encode dup length f void* <ref> 0 size_t <ref>
  97     [ fdb_get_kv ] 2keep
  98     rot {
  99         { FDB_RESULT_SUCCESS [ ret>string ] }
 100         { FDB_RESULT_KEY_NOT_FOUND [ 2drop f ] }
 101         [ fdb-error ]
 102     } case ;
 103
 104 : fdb-del-kv ( key -- )
 105     [ get-kvs-handle ] dip
 106     utf8 encode dup length fdb_del_kv fdb-check-error ;
 107
 108 : fdb-doc-create ( key meta body -- doc )
 109     [ f void* <ref> ] 3dip
 110     [ utf8 encode dup length ] tri@
 111     [ fdb_doc_create fdb-check-error ] 7 nkeep 6 ndrop
 112     void* deref fdb_doc memory>struct ;
 113
 114 : fdb-doc-update ( doc meta body -- )
 115     [ void* <ref> ] 2dip
 116     [ utf8 encode dup length ] bi@
 117     fdb_doc_update fdb-check-error ;
 118
 119 : fdb-doc-free ( doc -- )
 120     fdb_doc_free fdb-check-error ;
 121
 122 : clear-doc-key ( doc -- doc )
 123     [ dup [ (free) f ] when ] change-key
 124     0 >>keylen ;
 125
 126 : with-doc ( doc quot: ( doc -- ) -- )
 127     over '[ _ _ [ _ fdb-doc-free rethrow ] recover ] call ; inline
 128
 129 : with-create-doc ( key meta body quot: ( doc -- ) -- )
 130     [ fdb-doc-create ] dip with-doc ; inline
 131
 132 : fdb-get-info ( -- fdb_file_info )
 133     get-file-handle
 134     fdb_file_info <struct> [ fdb_get_file_info fdb-check-error ] keep ;
 135
 136 : fdb-get-kvs-info ( -- fdb_kvs_info )
 137     get-kvs-handle
 138     fdb_kvs_info <struct> [ fdb_get_kvs_info fdb-check-error ] keep ;
 139
 140 : fdb-commit ( fdb_commit_opt_t -- )
 141     [ get-file-handle ] dip fdb_commit fdb-check-error ;
 142
 143 : fdb-maybe-commit ( fdb_commit_opt_t/f -- )
 144     [ fdb-commit ] when* ;
 145
 146 : fdb-commit-normal ( -- ) FDB_COMMIT_NORMAL fdb-commit ;
 147
 148 : fdb-commit-wal-flush ( -- ) FDB_COMMIT_MANUAL_WAL_FLUSH fdb-commit ;
 149
 150 : fdb-compact-to-path ( new-path -- )
 151     [ get-file-handle ] dip absolute-path
 152     fdb_compact fdb-check-error ;
 153
 154 : fdb-compact ( -- )
 155     get-file-handle f fdb_compact fdb-check-error ;
 156
 157 : fdb-compact-commit-to-path ( path -- )
 158     fdb-compact-to-path fdb-commit-wal-flush ;
 159
 160 : fdb-compact-commit ( -- )
 161     fdb-compact fdb-commit-wal-flush ;
 162
 163
 164 ! Call from within with-foresdb
 165 : fdb-open-snapshot ( seqnum -- handle )
 166     [
 167         get-kvs-handle
 168         f void* <ref>
 169     ] dip [
 170         fdb_snapshot_open fdb-check-error
 171     ] 2keep drop void* deref <fdb-kvs-handle> ;
 172
 173 ! fdb_rollback returns a new handle, so we
 174 ! have to replace our current handle with that one
 175 ! XXX: can't call dispose on old handle, library handles that
 176 : fdb-rollback ( seqnum -- )
 177     [ get-kvs-handle void* <ref> ] dip
 178     [ fdb_rollback fdb-check-error ] 2keep drop
 179     void* deref <fdb-kvs-handle> current-fdb-kvs-handle set ;
 180
 181
 182 TUPLE: fdb-iterator < disposable handle ;
 183
 184 : <fdb-iterator> ( handle -- obj )
 185     fdb-iterator new-disposable
 186         swap >>handle ; inline
 187
 188 M: fdb-iterator dispose*
 189     handle>> fdb_iterator_close fdb-check-error ;
 190
 191 : fdb-iterator-init ( start-key end-key fdb_iterator_opt_t -- iterator )
 192     [ get-kvs-handle f void* <ref> ] 3dip
 193     [ [ utf8 encode dup length ] bi@ ] dip
 194     [ fdb_iterator_init fdb-check-error ] 7 nkeep 5 ndrop nip
 195     void* deref <fdb-iterator> ;
 196
 197 : fdb-iterator-byseq-init ( start-seq end-seq fdb_iterator_opt_t -- iterator )
 198     [ get-kvs-handle f void* <ref> ] 3dip
 199     [ fdb_iterator_sequence_init fdb-check-error ] 5 nkeep 3 ndrop nip
 200     void* deref <fdb-iterator> ;
 201
 202 : fdb-iterator-init-none ( start-key end-key -- iterator )
 203     FDB_ITR_NONE fdb-iterator-init ;
 204
 205 : fdb-iterator-no-deletes ( start-key end-key -- iterator )
 206     FDB_ITR_NO_DELETES fdb-iterator-init ;
 207
 208 : check-iterate-result ( fdb_status -- ? )
 209     {
 210         { FDB_RESULT_SUCCESS [ t ] }
 211         { FDB_RESULT_ITERATOR_FAIL [ f ] }
 212         [ throw ]
 213     } case ;
 214
 215 ! fdb_doc key, meta, body only valid inside with-forestdb
 216 ! so make a helper word to preserve them outside
 217 TUPLE: fdb-doc seqnum keylen key metalen meta bodylen body deleted? offset size-ondisk ;
 218
 219 CONSTRUCTOR: <fdb-doc> fdb-doc ( seqnum keylen key metalen meta bodylen body deleted? offset size-ondisk -- obj ) ;
 220
 221 TUPLE: fdb-info filename new-filename doc-count space-used file-size ;
 222 CONSTRUCTOR: <info> fdb-info ( filename new-filename doc-count space-used file-size -- obj ) ;
 223
 224 /*
 225 ! Example fdb_doc and converted doc
 226 S{ fdb_doc
 227     { keylen 4 } { metalen 0 } { bodylen 4 } { size_ondisk 0 }
 228     { key ALIEN: 1002f2f10 } { seqnum 5 } { offset 4256 }
 229     { meta ALIEN: 1002dc790 } { body f } { deleted f }
 230 }
 231 T{ doc
 232     { seqnum 5 }
 233     { keylen 4 } { key "key5" }
 234     { metalen 0 } { bodylen 4 }
 235     { offset 4256 } { size-ondisk 0 }
 236 }
 237 */
 238
 239 : alien/length>string ( alien n -- string/f )
 240     [ drop f ] [
 241         over [
 242             memory>byte-array utf8 decode
 243         ] [
 244             2drop f
 245         ] if
 246     ] if-zero ;
 247
 248 : fdb_doc>doc ( fdb_doc -- doc )
 249     {
 250         [ seqnum>> ]
 251         [ keylen>> ]
 252         [ [ key>> ] [ keylen>> ] bi alien/length>string ]
 253         [ metalen>> ]
 254         [ [ meta>> ] [ metalen>> ] bi alien/length>string ]
 255         [ bodylen>> ]
 256         [ [ body>> ] [ bodylen>> ] bi alien/length>string ]
 257         [ deleted>> >boolean ]
 258         [ offset>> ]
 259         [ size_ondisk>> ]
 260     } cleave <fdb-doc> ;
 261
 262 : fdb_file_info>info ( fdb_doc -- doc )
 263     {
 264         [ filename>> alien>native-string ]
 265         [ new_filename>> alien>native-string ]
 266         [ doc_count>> ]
 267         [ space_used>> ]
 268         [ file_size>> ]
 269     } cleave <info> ;
 270
 271 : fdb-iterator-get ( iterator -- doc/f )
 272     f void* <ref>
 273     [ fdb_iterator_get check-iterate-result ] keep swap
 274     [ void* deref fdb_doc memory>struct ]
 275     [ drop f ] if ;
 276
 277 : fdb-iterator-seek ( iterator key seek-opt -- )
 278     [ dup length ] dip fdb_iterator_seek fdb-check-error ;
 279
 280 : fdb-iterator-seek-lower ( iterator key -- )
 281     FDB_ITR_SEEK_LOWER fdb-iterator-seek ;
 282
 283 : fdb-iterator-seek-higher ( iterator key -- )
 284     FDB_ITR_SEEK_HIGHER fdb-iterator-seek ;
 285
 286 : with-fdb-iterator ( start-key end-key fdb_iterator_opt_t iterator-init iterator-advance quot: ( obj -- ) -- )
 287     [ execute ] 2dip
 288     swap
 289     '[
 290         _ &dispose handle>> [
 291             [ fdb-iterator-get ] keep swap
 292             [ _ with-doc _ execute check-iterate-result ]
 293             [ drop f ] if*
 294         ] curry loop
 295     ] with-destructors ; inline
 296
 297 <PRIVATE
 298
 299 : collector-when-as ( quot exemplar -- quot' vec )
 300     [ length ] keep new-resizable [ [ over [ push ] [ 2drop ] if ] curry compose ] keep ; inline
 301
 302 : collector-when ( quot -- quot' vec )
 303     V{ } collector-when-as ; inline
 304
 305 PRIVATE>
 306
 307 : get-kvs-default-config ( -- kvs-config )
 308     fdb_get_default_kvs_config ;
 309
 310 : fdb-open ( path config -- file-handle )
 311     [ f void* <ref> ] 2dip
 312     [ make-parent-directories ] dip
 313     [ fdb_open fdb-check-error ] 3keep
 314     2drop void* deref <fdb-file-handle> ;
 315
 316 : fdb-config-normal-commit ( -- config )
 317     fdb_get_default_config
 318         FDB_SEQTREE_USE >>seqtree_opt ;
 319
 320 : fdb-config-auto-commit ( -- config )
 321     fdb-config-normal-commit
 322         FDB_COMPACTION_AUTO >>compaction_mode
 323         1 >>compactor_sleep_duration
 324         t >>auto_commit ;
 325
 326 ! Make SEQTREES by default
 327 : fdb-open-auto-commit ( path -- file-handle )
 328     fdb-config-auto-commit fdb-open ;
 329
 330 : fdb-open-normal-commit ( path -- file-handle )
 331     fdb-config-normal-commit fdb-open ;
 332
 333 : fdb-kvs-open-config ( name config -- kvs-handle )
 334     [
 335         current-fdb-file-handle get handle>>
 336         f void* <ref>
 337     ] 2dip
 338     [ fdb_kvs_open fdb-check-error ] 3keep 2drop
 339     void* deref <fdb-kvs-handle> ;
 340
 341 : fdb-kvs-open-default-config ( name -- kvs-handle )
 342     get-kvs-default-config fdb-kvs-open-config ;
 343
 344 : with-fdb-map ( start-key end-key fdb_iterator_opt_t iterator-init iterator-next quot: ( obj -- ) -- )
 345     [ execute ] 2dip
 346     swap
 347     '[
 348         _ &dispose handle>> [
 349             [ fdb-iterator-get ] keep swap
 350             [ _ with-doc swap _ execute check-iterate-result ]
 351             [ drop f f ] if* swap
 352         ] curry collector-when [ loop ] dip
 353     ] with-destructors ; inline
 354
 355 : with-fdb-normal-iterator ( start-key end-key quot -- )
 356     [ FDB_ITR_NONE \ fdb-iterator-init \ fdb_iterator_next ] dip
 357     with-fdb-iterator ; inline
 358
 359 : with-fdb-byseq-each ( start-seq end-seq quot -- )
 360     [ FDB_ITR_NONE \ fdb-iterator-byseq-init \ fdb_iterator_next ] dip
 361     with-fdb-iterator ; inline
 362
 363 : with-fdb-byseq-map ( start-seq end-seq quot -- )
 364     [ FDB_ITR_NONE \ fdb-iterator-byseq-init \ fdb_iterator_next ] dip
 365     with-fdb-map ; inline
 366
 367 ! : changes-cb ( handle doc ctx -- changes_decision )
 368 !    ;
 369
 370 ! : fdb-changes-since ( seqnum iterator_opt cb ctx -- seq )
 371 !    f 101 FDB_ITR_NONE fdb_changes_since ;
 372
 373
 374 : with-kvs-name-config ( name config quot -- )
 375     '[
 376         _ _ fdb-kvs-open-config &dispose current-fdb-kvs-handle _ with-variable
 377     ] with-destructors ; inline
 378
 379 : with-kvs-name ( name quot -- )
 380     [ fdb_get_default_kvs_config ] dip with-kvs-name-config ; inline
 381
 382
 383 : with-forestdb-file-handle ( path config quot -- )
 384     '[
 385         _ _ fdb-open &dispose current-fdb-file-handle _ with-variable
 386     ] with-destructors ; inline
 387
 388 : with-forestdb-path-config-kvs-name-config ( path config kvs-name kvs-config quot -- )
 389     '[
 390         _ _ with-kvs-name-config
 391     ] with-forestdb-file-handle ; inline
 392
 393 : with-forestdb-path-config-kvs-name ( path config kvs-name quot -- )
 394     '[
 395         _ _ with-kvs-name
 396     ] with-forestdb-file-handle ; inline
 397
 398 /*
 399 ! Do not try to commit here, as it will fail with FDB_RESULT_RONLY_VIOLATION
 400 ! fdb-current is weird, it gets replaced if you call fdb-rollback
 401 ! Therefore, only clean up fdb-current once, and clean it up at the end
 402 : with-forestdb-handles ( file-handle handle quot fdb_commit_opt_t/f -- )
 403     '[
 404         _ current-fdb-file-handle [
 405             _ current-fdb-kvs-handle [
 406                 [
 407                     @
 408                     _ fdb-maybe-commit
 409                     current-fdb-file-handle get &dispose drop
 410                     current-fdb-kvs-handle get &dispose drop
 411                 ] [
 412                     [
 413                         current-fdb-file-handle get &dispose drop
 414                         current-fdb-kvs-handle get &dispose drop
 415                     ] with-destructors
 416                     rethrow
 417                 ] recover
 418             ] with-variable
 419         ] with-variable
 420     ] with-destructors ; inline
 421
 422 ! XXX: When you don't commit-wal at the end of with-forestdb, it won't
 423 ! persist to disk for next time you open the db.
 424 : with-forestdb-handles-commit-normal ( file-handle handle quot commit -- )
 425     FDB_COMMIT_NORMAL with-forestdb-handles ; inline
 426
 427 : with-forestdb-handles-commit-wal ( file-handle handle quot commit -- )
 428     FDB_COMMIT_MANUAL_WAL_FLUSH with-forestdb-handles ; inline
 429
 430 : with-forestdb-snapshot ( n quot -- )
 431     [ fdb-open-snapshot ] dip '[
 432         _ current-fdb-kvs-handle [
 433             [
 434                 @
 435                 current-fdb-kvs-handle get &dispose drop
 436             ] [
 437                 current-fdb-kvs-handle get [ &dispose drop ] when*
 438                 rethrow
 439             ] recover
 440         ] with-variable
 441     ] with-destructors ; inline
 442
 443 : with-forestdb-path ( path quot -- )
 444     [ absolute-path fdb-open-default-config ] dip with-forestdb-handles-commit-wal ; inline
 445     ! [ absolute-path fdb-open-default-config ] dip with-forestdb-handle-commit-normal ; inline
 446 */