Factored out the non-gui stuff from TLC

[tcl-tlc-base.git] / scripts / datasource_chan_backend.itcl

# vim: foldmethod=marker foldmarker=<<<,>>> ft=tcl ts=4 shiftwidth=4

# TODO:
#       Periodic housecleaning routine for recently_deceased trimming

class tlc::DSchan_backend {
        inherit tlc::Baselog

        constructor {args} {}
        destructor {}

        public {
                variable id_column              0
                variable comp
                variable tag
                variable headers
                variable dbfile                 ":memory:"
                variable persist                0

                method register_pool {pool {check_cb {}}}
                method deregister_pool {pool}
                method add_item {pool item}
                method change_item {pool id newitem}
                method remove_item {pool id}
                method get_item {pool id}
                method item_count {pool}
                method id_list {pool}
                method pool_exists {pool}
                method id_exists {pool id}
                method start_init {}
                method end_init {}
                method abort_init {}
        }

        private {
                variable auth
                variable pools
                variable pool_jmids
                variable general_info_jmid
                variable db
                variable _dbfile
                variable in_init_transaction    0

                method announce_pool {pool}
                method announce_new {pool id item}
                method announce_changed {pool id olditem newitem}
                method announce_removed {pool id item}
                method check_pool {pool}
                method req_handler {auth user seq rest}
                method pool_chan_cb {pool op data}
                method general_info_chan_cb {op data}
                method init_db {}
        }
}


configbody tlc::DSchan_backend::headers { #<<<1
        if {[info exists general_info_jmid]} {
                $auth jm $general_info_jmid [list headers_changed $headers]
        }
}


configbody tlc::DSchan_backend::id_column { #<<<1
        if {[info exists general_info_jmid]} {
                $auth jm $general_info_jmid [list id_column_changed $id_column]
        }
}


body tlc::DSchan_backend::constructor {args} { #<<<1
        package require sqlite3

        array set pools                 {}
        array set pool_jmids    {}

        eval configure $args

        foreach reqf {comp tag headers} {
                if {![info exists $reqf]} {
                        error "Must set -$reqf"
                }
        }

        # Canonise dbfile <<<
        if {$dbfile == ":memory:" || $dbfile == ""} {
                set _dbfile             ":memory:"
        } else {
                if {![file exists $dbfile]} {
                        set file_hack   1
                        set fp  [open $dbfile w]
                        close $fp
                }
                set _dbfile     [file normalize $dbfile]
                while {[file type $_dbfile] == "link"} {
                        set _dbfile     [file readlink $_dbfile]
                        set _dbfile     [file normalize $_dbfile]
                }
                if {[info exists file_hack]} {
                        file delete $_dbfile
                }
        }
        # Canonise dbfile >>>

        set db          "db,$this"
        sqlite3 [namespace current]::$db $_dbfile

        init_db

        set auth        [$comp cget -auth]
        $comp handler $tag [code $this req_handler]
}


body tlc::DSchan_backend::destructor {} { #<<<1
        if {[info exists db]} {
                $db close
                unset db
                if {!($persist) && $_dbfile != ":memory:"} {
                        if {[file exists $_dbname]} {
                                file delete $_dbname
                        }
                }
        }
}


body tlc::DSchan_backend::register_pool {pool {check_cb {}}} { #<<<1
        set pools($pool)                $check_cb
        log debug "registered pool"
        announce_pool $pool
}


body tlc::DSchan_backend::deregister_pool {pool} { #<<<1
        check_pool $pool
        if {[info exists pool_jmids($pool)]} {
                $auth jm_can $pool_jmids($pool) [list pool_deregistered]
                $auth chans deregister_chan $pool_jmids($pool)
        }
        array unset pool_jmids $pool
        $db eval {
                delete from
                        pool_data
                where
                        pool = $pool
        }
        array unset pools $pool
        log debug "deregistered pool"
}


body tlc::DSchan_backend::add_item {pool item} { #<<<1
        log debug
        check_pool $pool
        set id          [lindex $item $id_column]

        if {[id_exists $pool $id]} {
                error "ID \"$id\" already exists in ($pool), adding ([join $item |])" \
                                "" [list duplicate_id $id $pool]
        }
        set last_updated        [clock seconds]
        $db eval {
                insert into pool_data (
                        pool,
                        id,
                        last_updated,
                        data
                ) values (
                        $pool,
                        $id,
                        $last_updated,
                        $item
                )
        }

        log debug "announcing new item ($id) in pool ($pool)"
        announce_new $pool $id $item
}


body tlc::DSchan_backend::change_item {pool id newitem} { #<<<1
        check_pool $pool

        if {![id_exists $pool $id]} {
                error "ID $id does not exist in $pool"
        }

        set newid       [lindex $newitem $id_column]
        if {$newid != $id} {
                error "Changing id column not allowed" "" \
                                [list id_column_changed $id $newid]
        }

        set olditem                     [get_item $pool $id]
        if {$olditem == $newitem} return

        set last_updated        [clock seconds]
        $db eval {
                update
                        pool_data
                set
                        data = $newitem,
                        last_updated = $last_updated
                where
                        id = $id
                        and pool = $pool
        }
        log debug "\nannouncing item change ($id) in pool ($pool)\nold: ($olditem)\nnew: ($newitem)"
        announce_changed $pool $id $olditem $newitem
}


body tlc::DSchan_backend::remove_item {pool id} { #<<<1
        check_pool $pool
        if {![id_exists $pool $id]} {
                log warning "item ($id) not found in pool ($pool)"
                return
        }

        set item                [get_item $pool $id]
        if {!($in_init_transaction)} {
                $db eval {begin}
        }
        tlc::try {
                set dbid        [$db onecolumn {
                        select
                                autoid
                        from
                                pool_data
                        where
                                id = $id
                                and pool = $pool
                }]
                $db eval {
                        delete from
                                pool_data
                        where
                                id = $id
                                and pool = $pool
                }
                set timeofdeath [clock seconds]
                $db eval {
                        insert into recently_deceased (
                                dbid,
                                timeofdeath
                        ) values (
                                $dbid,
                                $timeofdeath
                        )
                }
        } onok {
                if {!($in_init_transaction)} {
                        $db eval {commit}
                }
        } onerr {
                default {
                        $db eval {rollback}
                        error $errmsg "" $::errorCode
                }
        }
        log debug "announcing item removal ($id) from pool ($pool)"
        announce_removed $pool $id $item
}


body tlc::DSchan_backend::get_item {pool id} { #<<<1
        check_pool $pool
        set rows        [$db eval {
                select
                        data
                from
                        pool_data
                where
                        id = $id
                        and pool = $pool
        }]
        # WARNING: this logic will break if more columns are selected
        if {[llength $rows] == 0} {
                error "ID $id does not exist in $pool"
        }
        if {[llength $rows] > 1} {
                log warning "Duplicate rows for id ($id) and pool ($pool)"
        }
        return [lindex $rows 0]
}


body tlc::DSchan_backend::item_count {pool} { #<<<1
        check_pool $pool
        return [$db onecolumn {
                select
                        count(1)
                from
                        pool_data
                where
                        pool = $pool
        }]
}


body tlc::DSchan_backend::id_list {pool} { #<<<1
        check_pool $pool
        return [$db eval {
                select
                        id
                from
                        pool_data
                where
                        pool = $pool
        }]
}


body tlc::DSchan_backend::announce_pool {pool} { #<<<1
        log debug "general_info_jmid exists: [info exists general_info_jmid]"
        if {[info exists general_info_jmid]} {
                $auth jm $general_info_jmid [list new_pool $pool]
        }
}


body tlc::DSchan_backend::announce_new {pool id item} { #<<<1
        log debug "pool exists: [info exists pool_jmids($pool)]"
        if {[info exists pool_jmids($pool)]} {
                $auth jm $pool_jmids($pool) [list new $id $item]
        }
}


body tlc::DSchan_backend::announce_changed {pool id olditem newitem} { #<<<1
        log debug "pool exists: [info exists pool_jmids($pool)]"
        if {[info exists pool_jmids($pool)]} {
                $auth jm $pool_jmids($pool) [list changed $id $olditem $newitem]
        }
}


body tlc::DSchan_backend::announce_removed {pool id item} { #<<<1
        log debug "pool exists: [info exists pool_jmids($pool)]"
        if {[info exists pool_jmids($pool)]} {
                $auth jm $pool_jmids($pool) [list removed $id $item]
        }
}


body tlc::DSchan_backend::check_pool {pool} { #<<<1
        if {![info exists pools($pool)]} {
                return -code error "No such pool: ($pool)"
        }
}


body tlc::DSchan_backend::req_handler {auth user seq rest} { #<<<1
        switch -- [lindex $rest 0] {
                "setup_chans" {
                        set extra       [lindex $rest 1]

                        set userpools   {}
                        foreach {pool check_cb} [array get pools] {
                                if {[catch {
                                        # Provide a place for the check_cb callback to scribble into
                                        # via an upvar command.  We send the contents to the client
                                        array unset pool_meta
                                        array set pool_meta {}

                                        log debug "check_cb is: ($check_cb)"
                                        if {
                                                $check_cb == {}
                                                || [eval $check_cb [list $user $pool $extra]]
                                        } {
                                                lappend userpools       $pool
                                        }

                                        set pool_meta_all($pool)        [array get pool_meta]
                                        log debug "Saving pool_meta for ($pool):\n$pool_meta_all($pool)"
                                } errmsg]} {
                                        log error "error calling check_cb:\n$::errorInfo"
                                }
                        }

                        if {![info exists general_info_jmid]} {
                                set general_info_jmid   [$auth unique_id]
                                $auth chans register_chan $general_info_jmid \
                                                [code $this general_info_chan_cb]
                        }
                        $auth pr_jm $general_info_jmid $seq [list general [list \
                                        headers         $headers \
                                        id_column       $id_column \
                        ]]

                        foreach pool $userpools {
                                if {![info exists pool_jmids($pool)]} {
                                        set pool_jmids($pool)   [$auth unique_id]
                                        $auth chans register_chan $pool_jmids($pool) \
                                                        [code $this pool_chan_cb $pool]
                                }

                                log debug "Contents of pool_meta array:\n[array get pool_meta]"
                                set all_items   [$db eval {
                                        select
                                                data
                                        from
                                                pool_data
                                        where
                                                pool = $pool
                                }]
                                $auth pr_jm $pool_jmids($pool) $seq [list datachan $pool $all_items $pool_meta_all($pool)]
                        }

                        $auth ack $seq ""
                }

                "setup_new_pool" {
                        set new_pool    [lindex $rest 1]
                        set extra               [lindex $rest 2]

                        if {![info exists pools($new_pool)]} {
                                $auth nack $seq "No such pool: ($new_pool)"
                                return
                        }
                        set check_cb    $pools($new_pool)
                        if {[catch {

                                # Provide a place for the check_cb callback to scribble into
                                # via an upvar command.  We send the contents to the client
                                array set pool_meta {}

                                if {
                                        $check_cb == {}
                                        || [eval $check_cb [list $user $new_pool $extra]]
                                } {
                                        if {![info exists pool_jmids($new_pool)]} {
                                                set pool_jmids($new_pool)       [$auth unique_id]
                                                $auth chans register_chan $pool_jmids($new_pool) \
                                                                [code $this pool_chan_cb $new_pool]
                                        }

                                        set all_items   [$db eval {
                                                select
                                                        data
                                                from
                                                        pool_data
                                                where
                                                        pool = $new_pool
                                        }]
                                        $auth pr_jm $pool_jmids($new_pool) $seq [list datachan $new_pool $all_items [array get pool_meta]]
                                        log debug "Added user ([$user name]) to new pool ($new_pool), with ([llength $all_items]) initial items"

                                        $auth ack $seq ""
                                } else {
                                        log debug "User ([$user name]) is not a viewer of pool ($new_pool)"
                                        $auth ack $seq ""
                                }
                        } errmsg]} {
                                log error "error calling check_cb:\n$::errorInfo"
                                $auth nack $seq "Internal error"
                                return
                        }
                }

                default {
                        log error "invalid req type: [lindex $rest 0]"
                        $auth nack $seq "Invalid req type: ([lindex $rest 0])"
                }
        }
}


body tlc::DSchan_backend::pool_chan_cb {pool op data} { #<<<1
        switch -- $op {
                cancelled {
                        log debug "all destinations disconnected"
                        array unset pool_jmids $pool
                }

                req {
                        foreach {seq prev_seq msg} $data break
                        $auth nack $seq "Requests not allowed on this channel"
                }

                default {
                        log error "unexpected op: ($op)"
                }
        }
}


body tlc::DSchan_backend::general_info_chan_cb {op data} { #<<<1
        switch -- $op {
                cancelled {
                        log debug "all destinations disconnected"
                        if {[info exists general_info_jmid]} {
                                unset general_info_jmid
                        }
                }

                req {
                        foreach {seq prev_seq msg} $data break
                        $auth nack $seq "Requests not allowed on this channel"
                }

                default {
                        log error "unexpected op: ($op)"
                }
        }
}


body tlc::DSchan_backend::pool_exists {pool} { #<<<1
        return [info exists pools($pool)]
}


body tlc::DSchan_backend::init_db {} { #<<<1
        set exists      [$db onecolumn {
                select
                        count(1) > 0
                from
                        sqlite_master
                where
                        type = 'table'
                        and name = 'pool_data'
        }]

        if {!($persist) && $exists} {
                $db eval {
                        drop table pool_data;
                        drop table recently_deceased;
                }
                set exists      0
        }

        # recently_deceased.dbid == -1 gives the last cleanout time
        if {!($exists)} {
                $db eval {
                        create table pool_data (
                                autoid                  integer primary key autoincrement,
                                pool                    text,
                                id                              text,
                                last_updated    integer,
                                data                    text
                        );
                        create index pool_data_pool_idx on pool_data(pool);
                        create index pool_data_id_idx on pool_data(id);

                        create table recently_deceased (
                                dbid                    integer not null,
                                timeofdeath             integer not null
                        );
                        create index recently_deceased_timeofdeath_idx 
                                on recently_deceased(timeofdeath);
                }
        }
}


body tlc::DSchan_backend::id_exists {pool id} { #<<<1
        return [$db onecolumn {
                select
                        count(1) > 0
                from
                        pool_data
                where
                        pool = $pool
                        and id = $id
        }]
}


body tlc::DSchan_backend::start_init {} { #<<<1
        $db eval {begin}
        set in_init_transaction 1
}


body tlc::DSchan_backend::end_init {} { #<<<1
        $db eval {commit; analyze}
        set in_init_transaction 0
}


body tlc::DSchan_backend::abort_init {} { #<<<1
        $db eval {rollback}
        set in_init_transaction 0
}