factor/extra/forestdb/lib/lib.factor

! Copyright (C) 2014 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.data alien.strings byte-arrays
classes.struct combinators constructors continuations destructors
forestdb.ffi fry generalizations io.directories io.encodings.string
io.encodings.utf8 io.pathnames kernel libc math multiline namespaces
sequences strings ;
QUALIFIED: sets
IN: forestdb.lib

! Issues
! Get byseq ignores seqnum and uses key instead if key is set

ERROR: fdb-error error ;

: fdb-check-error ( ret -- )
    dup FDB_RESULT_SUCCESS = [ drop ] [ fdb-error ] if ;


TUPLE: fdb-kvs-handle < disposable handle ;
: <fdb-kvs-handle> ( handle -- obj )
    fdb-kvs-handle new-disposable
        swap >>handle ; inline

M: fdb-kvs-handle dispose*
    handle>> fdb_kvs_close fdb-check-error ;


TUPLE: fdb-file-handle < disposable handle ;
: <fdb-file-handle> ( handle -- obj )
    fdb-file-handle new-disposable
        swap >>handle ; inline

M: fdb-file-handle dispose*
    handle>> fdb_close fdb-check-error ;


SYMBOL: current-fdb-file-handle
SYMBOL: current-fdb-kvs-handle

: get-file-handle ( -- handle )
    current-fdb-file-handle get handle>> ;

: get-kvs-handle ( -- handle )
    current-fdb-kvs-handle get handle>> ;

GENERIC: encode-kv ( object -- bytes )

M: string encode-kv utf8 encode ;
M: byte-array encode-kv ;

: fdb-set-kv ( key value -- )
    [ get-kvs-handle ] 2dip
    [ encode-kv dup length ] bi@ fdb_set_kv fdb-check-error ;

: <key-doc> ( key -- doc )
    fdb_doc malloc-struct
        swap [ utf8 malloc-string >>key ] [ length >>keylen ] bi ;

: <seqnum-doc> ( seqnum -- doc )
    fdb_doc malloc-struct
        swap >>seqnum ;

! Fill in document by exemplar
: fdb-get ( doc -- doc )
    [ get-kvs-handle ] dip [ fdb_get fdb-check-error ] keep ;

: fdb-get-metaonly ( doc -- doc )
    [ get-kvs-handle ] dip [ fdb_get_metaonly fdb-check-error ] keep ;

: fdb-get-byseq ( doc -- doc )
    [ get-kvs-handle ] dip [ fdb_get_byseq fdb-check-error ] keep ;

: fdb-get-metaonly-byseq ( doc -- doc )
    [ get-kvs-handle ] dip [ fdb_get_metaonly_byseq fdb-check-error ] keep ;

: fdb-get-byoffset ( doc -- doc )
    [ get-kvs-handle ] dip [ fdb_get_byoffset fdb-check-error ] keep ;


! Set/delete documents
: fdb-set ( doc -- )
    [ get-kvs-handle ] dip fdb_set fdb-check-error ;

: fdb-del ( doc -- )
    [ get-kvs-handle ] dip fdb_del fdb-check-error ;

: ret>string ( void** len -- string )
    [ void* deref ] [ size_t deref ] bi*
    memory>byte-array utf8 decode ;

: fdb-get-kv ( key -- value/f )
    [ get-kvs-handle ] dip
    utf8 encode dup length f void* <ref> 0 size_t <ref>
    [ fdb_get_kv ] 2keep
    rot {
        { FDB_RESULT_SUCCESS [ ret>string ] }
        { FDB_RESULT_KEY_NOT_FOUND [ 2drop f ] }
        [ fdb-error ]
    } case ;

: fdb-del-kv ( key -- )
    [ get-kvs-handle ] dip
    utf8 encode dup length fdb_del_kv fdb-check-error ;

: fdb-doc-create ( key meta body -- doc )
    [ f void* <ref> ] 3dip
    [ utf8 encode dup length ] tri@
    [ fdb_doc_create fdb-check-error ] 7 nkeep 6 ndrop
    void* deref fdb_doc memory>struct ;

: fdb-doc-update ( doc meta body -- )
    [ void* <ref> ] 2dip
    [ utf8 encode dup length ] bi@
    fdb_doc_update fdb-check-error ;

: fdb-doc-free ( doc -- )
    fdb_doc_free fdb-check-error ;

: clear-doc-key ( doc -- doc )
    [ dup [ (free) f ] when ] change-key
    0 >>keylen ;

: with-doc ( doc quot: ( doc -- ) -- )
    over '[ _ _ [ _ fdb-doc-free rethrow ] recover ] call ; inline

: with-create-doc ( key meta body quot: ( doc -- ) -- )
    [ fdb-doc-create ] dip with-doc ; inline

: fdb-get-info ( -- fdb_file_info )
    get-file-handle
    fdb_file_info <struct> [ fdb_get_file_info fdb-check-error ] keep ;

: fdb-get-kvs-info ( -- fdb_kvs_info )
    get-kvs-handle
    fdb_kvs_info <struct> [ fdb_get_kvs_info fdb-check-error ] keep ;

: fdb-commit ( fdb_commit_opt_t -- )
    [ get-file-handle ] dip fdb_commit fdb-check-error ;

: fdb-maybe-commit ( fdb_commit_opt_t/f -- )
    [ fdb-commit ] when* ;

: fdb-commit-normal ( -- ) FDB_COMMIT_NORMAL fdb-commit ;

: fdb-commit-wal-flush ( -- ) FDB_COMMIT_MANUAL_WAL_FLUSH fdb-commit ;

: fdb-compact-to-path ( new-path -- )
    [ get-file-handle ] dip absolute-path
    fdb_compact fdb-check-error ;

: fdb-compact ( -- )
    get-file-handle f fdb_compact fdb-check-error ;

: fdb-compact-commit-to-path ( path -- )
    fdb-compact-to-path fdb-commit-wal-flush ;

: fdb-compact-commit ( -- )
    fdb-compact fdb-commit-wal-flush ;


! Call from within with-foresdb
: fdb-open-snapshot ( seqnum -- handle )
    [
        get-kvs-handle
        f void* <ref>
    ] dip [
        fdb_snapshot_open fdb-check-error
    ] 2keep drop void* deref <fdb-kvs-handle> ;

! fdb_rollback returns a new handle, so we
! have to replace our current handle with that one
! XXX: can't call dispose on old handle, library handles that
: fdb-rollback ( seqnum -- )
    [ get-kvs-handle void* <ref> ] dip
    [ fdb_rollback fdb-check-error ] 2keep drop
    void* deref <fdb-kvs-handle> current-fdb-kvs-handle set ;


TUPLE: fdb-iterator < disposable handle ;

: <fdb-iterator> ( handle -- obj )
    fdb-iterator new-disposable
        swap >>handle ; inline

M: fdb-iterator dispose*
    handle>> fdb_iterator_close fdb-check-error ;

: fdb-iterator-init ( start-key end-key fdb_iterator_opt_t -- iterator )
    [ get-kvs-handle f void* <ref> ] 3dip
    [ [ utf8 encode dup length ] bi@ ] dip
    [ fdb_iterator_init fdb-check-error ] 7 nkeep 5 ndrop nip
    void* deref <fdb-iterator> ;

: fdb-iterator-byseq-init ( start-seq end-seq fdb_iterator_opt_t -- iterator )
    [ get-kvs-handle f void* <ref> ] 3dip
    [ fdb_iterator_sequence_init fdb-check-error ] 5 nkeep 3 ndrop nip
    void* deref <fdb-iterator> ;

: fdb-iterator-init-none ( start-key end-key -- iterator )
    FDB_ITR_NONE fdb-iterator-init ;

: fdb-iterator-no-deletes ( start-key end-key -- iterator )
    FDB_ITR_NO_DELETES fdb-iterator-init ;

: check-iterate-result ( fdb_status -- ? )
    {
        { FDB_RESULT_SUCCESS [ t ] }
        { FDB_RESULT_ITERATOR_FAIL [ f ] }
        [ throw ]
    } case ;

! fdb_doc key, meta, body only valid inside with-forestdb
! so make a helper word to preserve them outside
TUPLE: fdb-doc seqnum keylen key metalen meta bodylen body deleted? offset size-ondisk ;

CONSTRUCTOR: <fdb-doc> fdb-doc ( seqnum keylen key metalen meta bodylen body deleted? offset size-ondisk -- obj ) ;

TUPLE: fdb-info filename new-filename doc-count space-used file-size ;
CONSTRUCTOR: <info> fdb-info ( filename new-filename doc-count space-used file-size -- obj ) ;

![[
! Example fdb_doc and converted doc
S{ fdb_doc
    { keylen 4 } { metalen 0 } { bodylen 4 } { size_ondisk 0 }
    { key alien: 1002f2f10 } { seqnum 5 } { offset 4256 }
    { meta alien: 1002dc790 } { body f } { deleted f }
}
T{ doc
    { seqnum 5 }
    { keylen 4 } { key "key5" }
    { metalen 0 } { bodylen 4 }
    { offset 4256 } { size-ondisk 0 }
}
]]

: alien/length>string ( alien n -- string/f )
    [ drop f ] [
        over [
            memory>byte-array utf8 decode
        ] [
            2drop f
        ] if
    ] if-zero ;

: fdb_doc>doc ( fdb_doc -- doc )
    {
        [ seqnum>> ]
        [ keylen>> ]
        [ [ key>> ] [ keylen>> ] bi alien/length>string ]
        [ metalen>> ]
        [ [ meta>> ] [ metalen>> ] bi alien/length>string ]
        [ bodylen>> ]
        [ [ body>> ] [ bodylen>> ] bi alien/length>string ]
        [ deleted>> >boolean ]
        [ offset>> ]
        [ size_ondisk>> ]
    } cleave <fdb-doc> ;

: fdb_file_info>info ( fdb_doc -- doc )
    {
        [ filename>> alien>native-string ]
        [ new_filename>> alien>native-string ]
        [ doc_count>> ]
        [ space_used>> ]
        [ file_size>> ]
    } cleave <info> ;

: fdb-iterator-get ( iterator -- doc/f )
    f void* <ref>
    [ fdb_iterator_get check-iterate-result ] keep swap
    [ void* deref fdb_doc memory>struct ]
    [ drop f ] if ;

: fdb-iterator-seek ( iterator key seek-opt -- )
    [ dup length ] dip fdb_iterator_seek fdb-check-error ;

: fdb-iterator-seek-lower ( iterator key -- )
    FDB_ITR_SEEK_LOWER fdb-iterator-seek ;

: fdb-iterator-seek-higher ( iterator key -- )
    FDB_ITR_SEEK_HIGHER fdb-iterator-seek ;

: with-fdb-iterator ( start-key end-key fdb_iterator_opt_t iterator-init iterator-advance quot: ( obj -- ) -- )
    [ execute ] 2dip
    swap
    '[
        _ &dispose handle>> [
            [ fdb-iterator-get ] keep swap
            [ _ with-doc _ execute check-iterate-result ]
            [ drop f ] if*
        ] curry loop
    ] with-destructors ; inline

<PRIVATE

: collector-when-as ( quot exemplar -- quot' vec )
    [ length ] keep new-resizable [ [ over [ push ] [ 2drop ] if ] curry compose ] keep ; inline

: collector-when ( quot -- quot' vec )
    V{ } collector-when-as ; inline

PRIVATE>

: get-kvs-default-config ( -- kvs-config )
    fdb_get_default_kvs_config ;

: fdb-open ( path config -- file-handle )
    [ f void* <ref> ] 2dip
    [ make-parent-directories ] dip
    [ fdb_open fdb-check-error ] 3keep
    2drop void* deref <fdb-file-handle> ;

: fdb-config-normal-commit ( -- config )
    fdb_get_default_config
        FDB_SEQTREE_USE >>seqtree_opt ;

: fdb-config-auto-commit ( -- config )
    fdb-config-normal-commit
        FDB_COMPACTION_AUTO >>compaction_mode
        1 >>compactor_sleep_duration
        t >>auto_commit ;

! Make SEQTREES by default
: fdb-open-auto-commit ( path -- file-handle )
    fdb-config-auto-commit fdb-open ;

: fdb-open-normal-commit ( path -- file-handle )
    fdb-config-normal-commit fdb-open ;

: fdb-kvs-open-config ( name config -- kvs-handle )
    [
        current-fdb-file-handle get handle>>
        f void* <ref>
    ] 2dip
    [ fdb_kvs_open fdb-check-error ] 3keep 2drop
    void* deref <fdb-kvs-handle> ;

: fdb-kvs-open-default-config ( name -- kvs-handle )
    get-kvs-default-config fdb-kvs-open-config ;

: with-fdb-map ( start-key end-key fdb_iterator_opt_t iterator-init iterator-next quot: ( obj -- ) -- )
    [ execute ] 2dip
    swap
    '[
        _ &dispose handle>> [
            [ fdb-iterator-get ] keep swap
            [ _ with-doc swap _ execute check-iterate-result ]
            [ drop f f ] if* swap
        ] curry collector-when [ loop ] dip
    ] with-destructors ; inline

: with-fdb-normal-iterator ( start-key end-key quot -- )
    [ FDB_ITR_NONE \ fdb-iterator-init \ fdb_iterator_next ] dip
    with-fdb-iterator ; inline

: with-fdb-byseq-each ( start-seq end-seq quot -- )
    [ FDB_ITR_NONE \ fdb-iterator-byseq-init \ fdb_iterator_next ] dip
    with-fdb-iterator ; inline

: with-fdb-byseq-map ( start-seq end-seq quot -- )
    [ FDB_ITR_NONE \ fdb-iterator-byseq-init \ fdb_iterator_next ] dip
    with-fdb-map ; inline

! : changes-cb ( handle doc ctx -- changes_decision )
!    ;

! : fdb-changes-since ( seqnum iterator_opt cb ctx -- seq )
!    f 101 FDB_ITR_NONE fdb_changes_since ;


: with-kvs-name-config ( name config quot -- )
    '[
        _ _ fdb-kvs-open-config &dispose current-fdb-kvs-handle _ with-variable
    ] with-destructors ; inline

: with-kvs-name ( name quot -- )
    [ fdb_get_default_kvs_config ] dip with-kvs-name-config ; inline


: with-forestdb-file-handle ( path config quot -- )
    '[
        _ _ fdb-open &dispose current-fdb-file-handle _ with-variable
    ] with-destructors ; inline

: with-forestdb-path-config-kvs-name-config ( path config kvs-name kvs-config quot -- )
    '[
        _ _ with-kvs-name-config
    ] with-forestdb-file-handle ; inline

: with-forestdb-path-config-kvs-name ( path config kvs-name quot -- )
    '[
        _ _ with-kvs-name
    ] with-forestdb-file-handle ; inline

![[
! Do not try to commit here, as it will fail with FDB_RESULT_RONLY_VIOLATION
! fdb-current is weird, it gets replaced if you call fdb-rollback
! Therefore, only clean up fdb-current once, and clean it up at the end
: with-forestdb-handles ( file-handle handle quot fdb_commit_opt_t/f -- )
    '[
        _ current-fdb-file-handle [
            _ current-fdb-kvs-handle [
                [
                    @
                    _ fdb-maybe-commit
                    current-fdb-file-handle get &dispose drop
                    current-fdb-kvs-handle get &dispose drop
                ] [
                    [
                        current-fdb-file-handle get &dispose drop
                        current-fdb-kvs-handle get &dispose drop
                    ] with-destructors
                    rethrow
                ] recover
            ] with-variable
        ] with-variable
    ] with-destructors ; inline

! XXX: When you don't commit-wal at the end of with-forestdb, it won't
! persist to disk for next time you open the db.
: with-forestdb-handles-commit-normal ( file-handle handle quot commit -- )
    FDB_COMMIT_NORMAL with-forestdb-handles ; inline

: with-forestdb-handles-commit-wal ( file-handle handle quot commit -- )
    FDB_COMMIT_MANUAL_WAL_FLUSH with-forestdb-handles ; inline

: with-forestdb-snapshot ( n quot -- )
    [ fdb-open-snapshot ] dip '[
        _ current-fdb-kvs-handle [
            [
                @
                current-fdb-kvs-handle get &dispose drop
            ] [
                current-fdb-kvs-handle get [ &dispose drop ] when*
                rethrow
            ] recover
        ] with-variable
    ] with-destructors ; inline

: with-forestdb-path ( path quot -- )
    [ absolute-path fdb-open-default-config ] dip with-forestdb-handles-commit-wal ; inline
    ! [ absolute-path fdb-open-default-config ] dip with-forestdb-handle-commit-normal ; inline
]]