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