Paste: Messing around wrt. #3158

USING: accessors calendar continuations db db.sqlite
db.sqlite.lib kernel math namespaces threads ;
IN: test

: db-path ( -- path ) "/tmp/locked-repro.db" ;

: init-db ( -- )
    db-path <sqlite-db> [
        "CREATE TABLE IF NOT EXISTS t (id INTEGER PRIMARY KEY, val TEXT)" sql-command
    ] with-db ;

: hold-write-lock ( -- )
    db-path <sqlite-db> [
        [
            "INSERT INTO t (val) VALUES ('locker')" sql-command
            2 seconds sleep
        ] with-transaction
    ] with-db ;

: sqlite-busy? ( error -- ? )
    dup sqlite-error? [ n>> 5 = ] [ drop f ] if ;

: try-write-retry ( retries-left -- )
    dup 0 <= [ drop "gave up: still locked" throw ] [
        [
            drop "INSERT INTO t (val) VALUES ('victim')" sql-command
        ] [
            dup sqlite-busy? [
                drop 200 milliseconds sleep 1 - try-write-retry
            ] [
                nip rethrow
            ] if
        ] recover
    ] if ;

: try-write-ok ( -- )
    db-path <sqlite-db> [ 20 try-write-retry ] with-db ;

: repro-fail ( -- )
    init-db
    [ hold-write-lock ] "locker" spawn drop
    500 milliseconds sleep
    db-path <sqlite-db> [ "INSERT INTO t (val) VALUES ('victim')" sql-command ] with-db ;

: repro-ok ( -- )
    init-db
    [ hold-write-lock ] "locker" spawn drop
    500 milliseconds sleep
    try-write-ok ;

! Yet another test (???)

SYMBOL: db-conn-a
SYMBOL: db-conn-b

: open-db-a ( -- ) "repro.db" sqlite-open db-conn-a set ;
: open-db-b ( -- ) "repro.db" sqlite-open db-conn-b set ;
: close-db-a ( -- ) db-conn-a get sqlite-close ;
: close-db-b ( -- ) db-conn-b get sqlite-close ;
: exec-sql-a ( str -- ) db-conn-a get swap sqlite-prepare dup sqlite-next drop sqlite-finalize ;
: exec-sql-b ( str -- ) db-conn-b get swap sqlite-prepare dup sqlite-next drop sqlite-finalize ;

: repro-lock ( -- )
    init-db
    open-db-a
    open-db-b
    [
        "BEGIN IMMEDIATE" exec-sql-a
        1 seconds sleep
        "COMMIT" exec-sql-a
        close-db-a
    ] "w1" spawn drop
    [
        300 milliseconds sleep
        "BEGIN IMMEDIATE" exec-sql-b
        "COMMIT" exec-sql-b
        close-db-b
    ] "w2" spawn drop
    2 seconds sleep ;