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