DELETED TODO.md Index: TODO.md ================================================================== --- TODO.md +++ /dev/null @@ -1,45 +0,0 @@ - ---- - -1. Check and fix merge -1. Check and fix split -1. Website - want more pages - statistics, project index/details -1. Test add/update handling of network/server issues, i.e. disconnects, timeouts, ... - ---- - -1. merge - logic still based on projects -- rework to place repos at center -1. projects - list projects -1. projects - show project details -1. need stats command - summary of projects, repos, stores -1. repos - need commands to move repos between projects -1. repos - need commands to remove projects - - note: currently auto-removing a project when last repo removed - - extend this to moves ? - -1. note! forks and their origin can all be in different projects -1. new list - show only primary repos, exclude forks -1. log information saved at stores - should be at repos - - - issues happen when acessing a repo - - alternate: keep with store (on disk), but separate logs per repo. - -1. refresh stores ? - old github stores can be big, containing shared data from all forks ... kill and recreate store to reduce it ? - - better: - - rename old github repo projects, then re-add => new stores - - disable old stores - hide from web indices ? (another repo flag) - - more disk space - - but keeps old state until new setup has initialized - - - Save old database, and pull the `store_github_forks` data for assessment of repos and their forks => handle the small ones first - -1. export command (`dump`?) to save a store with associated metadata to external directory - - => save old github stores before removing from management - -1. more various internal commands between packages - support for various list commands should be in repo now, instead of store - -1. mirror config store - changes - broken Index: _scratch_/gh-org-pull ================================================================== --- _scratch_/gh-org-pull +++ _scratch_/gh-org-pull @@ -1,9 +1,8 @@ #!/usr/bin/env tclsh ## -*- tcl -*- # # ## ### ##### ######## ############# ###################### -## Syntax: $0 user-or-org ?name? # Pull a list of github repositories for a person or org. # Resolve forked repositories to the main repository. # Print the result as a mirror import spec. Index: _scratch_/git-tag-check ================================================================== --- _scratch_/git-tag-check +++ _scratch_/git-tag-check @@ -1,9 +1,8 @@ #!/usr/bin/env tclsh ## -*- tcl -*- # # ## ### ##### ######## ############# ###################### -## Syntax: $0 gitdir package require Tcl 8.6 package require m::futil proc main {} { Index: _scratch_/v3-exec.tcl ================================================================== --- _scratch_/v3-exec.tcl +++ _scratch_/v3-exec.tcl @@ -1,426 +1,426 @@ -## -*- tcl -*- -# # ## ### ##### ######## ############# ##################### -## Simplified execution of external commands. - -# @@ Meta Begin -# Package m::exec 0 -# Meta author {Andreas Kupries} -# Meta location https://core.tcl.tk/akupries/???? -# Meta platform tcl -# Meta summary Simplified execution of external commands. -# Meta description Simplified execution of external commands. -# Meta subject {exec simplified api} -# Meta require {Tcl 8.5-} -# @@ Meta End - -package provide m::exec 0 - -# # ## ### ##### ######## ############# ##################### -## Requisites - -package require Tcl 8.5 -package require debug -package require debug::caller -package require m::msg -package require m::futil - -# # ## ### ##### ######## ############# ###################### - -debug level m/exec -debug prefix m/exec {[debug caller] | } - -# # ## ### ##### ######## ############# ##################### -## Definition - -namespace eval ::m { - namespace export exec - namespace ensemble create -} - -namespace eval ::m::exec { - namespace export verbose go get nc-get silent capture post-hook - # - namespace export spawn spawn2 - # - namespace ensemble create -} - -namespace eval ::m::exec::capture { - namespace export to on off clear get path active - namespace ensemble create -} - -# # ## ### ##### ######## ############# ##################### -## Spawned (jobs) - -proc ::m::exec::spawn {outcmd donecmd args} { - set stdout [open |$args 2>@1] - fconfigure $stdout -blocking 0 - fileevent $stdout readable [list m::exec::Data $outcmd $donecmd $stdout] - return -} - -proc ::m::exec::spawn2 {routecmd outcmd errcmd donecmd args} { - lassign [chan pipe] readfrom writeto - - set stdout [open |$args 2>@ $writeto] - set stderr $readfrom - - fconfigure $stdout -blocking 0 - fconfigure $stderr -blocking 0 - - set out [list m::exec::Route $routecmd out $outcmd $errcmd] - set err [list m::exec::Route $routecmd err $outcmd $errcmd] - - fileevent $stdout readable [list m::exec::Data $out $donecmd $stdout $stderr] - fileevent $stderr readable [list m::exec::Data $err $donecmd $stderr $stdout] - # TODO: Stop after both are closed! - return -} - -proc ::m::exec::Route {route baseroute out err line} { - set lineroute [Do $route $line] - if {$lineroute ne {}} { - upvar 0 $lineroute cmd - } else { - upvar 0 $baseroute cmd - } - Do $cmd $line -} - -proc ::m::exec::Data {report done chan args} { - if {[eof $chan]} { - foreach $c $args { close $c } - fconfigure $chan -blocking 1 - if {[catch { - close $chan - }] - Do $done - return - } - if {[gets $chan line] < 0} return - Do $report $line - return -} - -proc ::m::exec::Do {cmd args} { - uplevel #0 [list {*}$cmd {*}$args] -} - -# # ## ### ##### ######## ############# ##################### -## Capture management - -proc ::m::exec::capture::to {stdout stderr {enable 1}} { - debug.m/exec {} - B $enable - # Set clear capture destinations, and start (default). - # Note: Be independent of future CWD changes. - variable out [file normalize $stdout] - variable err [file normalize $stderr] - clear - variable active $enable - return -} - -proc ::m::exec::capture::off {{reset 0}} { - debug.m/exec {} - # Stop capture. - B $reset - variable active 0 - if {!$reset} { - debug.m/exec { /done} - return - } - variable out {} - variable err {} - - debug.m/exec {/done+reset} - return -} - -proc ::m::exec::capture::on {} { - # Start capture. Error if no destinations specified - debug.m/exec {} - variable out - variable err - if {($err eq "") || ($out eq "")} { - return -code error \ - -errorcode {M EXEC CAPTURE NO DESTINATION} \ - "Unable to start capture without destination" - } - variable active 1 - return -} - -proc ::m::exec::capture::clear {} { - # Clear the capture buffers - debug.m/exec {} - C out - C err - return -} - -proc ::m::exec::capture::get {key} { - # Get captured content - debug.m/exec {} - V $key - set path [P $key] - if {$path eq {}} return - return [m futil cat $path] -} - -proc ::m::exec::capture::path {key} { - # Get path of capture buffer - debug.m/exec {} - V $key - return [P $key] -} - -proc ::m::exec::capture::active {} { - # Query state of capture system - debug.m/exec {} - variable active - return $active -} - -proc ::m::exec::capture::P {key} { - # Get path of capture buffer - debug.m/exec {} - variable $key - upvar 0 $key path - return $path -} - -proc ::m::exec::capture::C {key} { - debug.m/exec {} - variable $key - upvar 0 $key path - if {$path eq {}} return - # open for writing, truncates. - close [open $path w] - return -} - -proc ::m::exec::capture::V {key} { - debug.m/exec {} - if {$key in {out err}} return - return -code error \ - -errorcode {M EXEC CAPTURE BAD KEY} \ - "Bad channel key $key" -} - -proc ::m::exec::capture::B {x} { - debug.m/exec {} - if {[string is boolean -strict $x]} return - return -code error \ - -errorcode {M EXEC CAPTURE BAD BOOL} \ - "Expected boolean, got \"$x\"" -} - -# # ## ### ##### ######## ############# ##################### - -proc ::m::exec::verbose {{newvalue {}}} { - debug.m/exec {} - variable verbose - if {[llength [info level 0]] == 2} { - capture::B $newvalue - set verbose $newvalue - } - return $verbose -} - -proc ::m::exec::post-hook {args} { - debug.m/exec {} - variable posthook $args - return $posthook -} - -# # ## ### ##### ######## ############# ##################### - -proc ::m::exec::go {cmd args} { - debug.m/exec {} - variable verbose - set args [linsert $args 0 $cmd] - - # V C | - # ----+- - # 0 0 | (a) null - # 0 1 | (b) capture - # 1 0 | (c) pass to inherited out/err - # 1 1 | (d) capture, pass to inherited - - if {$verbose} { - # c, d - m msg "> $args" - } - if {[capture active]} { - # b, d - CAP $args $verbose $verbose - # d - verbose ^----^ - } elseif {$verbose} { - # c - debug.m/exec {2>@ stderr >@ stdout $args} - exec 2>@ stderr >@ stdout {*}$args - } else { - # a - debug.m/exec {2> [NULL] > [NULL] $args} - exec 2> [NULL] > [NULL] {*}$args - } - return -} - -proc ::m::exec::get {cmd args} { - debug.m/exec {} - variable verbose - set args [linsert $args 0 $cmd] - - # V C | - # ----+- - # 0 0 | (a) null to stderr, return stdout - # 0 1 | (b) capture, return stdout - # 1 0 | (c) pass to stderr, return stdout - # 1 1 | (d) capture, return stdout, pass stderr - - if {$verbose} { - # (c) - m msg "> $args" - } - - if {[capture active]} { - # b, d - lassign [CAP $args 0 $verbose] oc ec - # d - verbose -------^ - debug.m/exec {==> ($oc)} - return $oc - } elseif {$verbose} { - # c - debug.m/exec {2>@ stderr $args} - return [exec 2>@ stderr {*}$args] - } else { - # a - debug.m/exec {2> [NULL] $args} - return [exec 2> [NULL] {*}$args] - } -} - -proc ::m::exec::nc-get {cmd args} { - debug.m/exec {} - variable verbose - set args [linsert $args 0 $cmd] - - if {$verbose} { - # c - m msg "> $args" - debug.m/exec {2>@ stderr $args} - return [::exec 2>@ stderr {*}$args] - } else { - # a - debug.m/exec {2> [NULL] $args} - return [::exec 2> [NULL] {*}$args] - } -} - -proc ::m::exec::silent {cmd args} { - debug.m/exec {} - variable verbose - set args [linsert $args 0 $cmd] - - # V C | - # ----+- - # 0 0 | (a) null - # 0 1 | (b) capture - # 1 0 | (c) null - # 1 1 | (d) capture - # ----> a == c - # ----> b == d - - if {$verbose} { - # c, d - m msg "> $args" - } - if {[capture active]} { - # b, d - set o [capture path out] - set e [capture path err] - debug.m/exec {2> $e > $o $args} - exec 2> $e > $o {*}$args - } else { - # a, c - debug.m/exec {2> [NULL] > [NULL] $args} - exec 2> [NULL] > [NULL] {*}$args - } - return -} - -proc ::m::exec::CAP {cmd vo ve} { - debug.m/exec {} - # Note: Temp files capture just current execution, - # Main capture then extended from these. - - variable posthook - set o [capture path out] - set e [capture path err] - - try { - debug.m/exec {2> $e.now > $o.now $cmd} - exec 2> $e.now > $o.now {*}$cmd - } finally { - set oc [m futil cat $o.now] - set ec [m futil cat $e.now] - - # Run the post command hook, if present - if {[llength $posthook]} { - set oc [split $oc \n] - set ec [split $ec \n] - lassign [uplevel #0 [list {*}$posthook $oc $ec]] oc ec - set oc [join $oc \n] - set ec [join $ec \n] - } - - POST $oc $o $vo stdout - POST $ec $e $ve stderr - } - - list $oc $ec -} - -proc ::m::exec::POST {content path verbose stdchan} { - debug.m/exec {} - # Extend capture - m futil append $path $content - if {$verbose} { - # Pass to inherited std channel - puts -nonewline $stdchan $content - flush $stdchan - } - file delete ${path}.now - return -} - -if {$tcl_platform(platform) eq "windows"} { - proc ::m::exec::NULL {} { - debug.m/exec {} - return NUL: - } -} else { - proc ::m::exec::NULL {} { - debug.m/exec {} - return /dev/null - } -} - -# # ## ### ##### ######## ############# ##################### -## State - -namespace eval ::m::exec { - variable verbose 0 - variable posthook {} -} -namespace eval ::m::exec::capture { - variable active 0 - variable out {} - variable err {} -} - -# # ## ### ##### ######## ############# ##################### -return +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Simplified execution of external commands. + +# @@ Meta Begin +# Package m::exec 0 +# Meta author {Andreas Kupries} +# Meta location https://core.tcl.tk/akupries/???? +# Meta platform tcl +# Meta summary Simplified execution of external commands. +# Meta description Simplified execution of external commands. +# Meta subject {exec simplified api} +# Meta require {Tcl 8.5-} +# @@ Meta End + +package provide m::exec 0 + +# # ## ### ##### ######## ############# ##################### +## Requisites + +package require Tcl 8.5 +package require debug +package require debug::caller +package require m::msg +package require m::futil + +# # ## ### ##### ######## ############# ###################### + +debug level m/exec +debug prefix m/exec {[debug caller] | } + +# # ## ### ##### ######## ############# ##################### +## Definition + +namespace eval ::m { + namespace export exec + namespace ensemble create +} + +namespace eval ::m::exec { + namespace export verbose go get nc-get silent capture post-hook + # + namespace export spawn spawn2 + # + namespace ensemble create +} + +namespace eval ::m::exec::capture { + namespace export to on off clear get path active + namespace ensemble create +} + +# # ## ### ##### ######## ############# ##################### +## Spawned (jobs) + +proc ::m::exec::spawn {outcmd donecmd args} { + set stdout [open |$args 2>@1] + fconfigure $stdout -blocking 0 + fileevent $stdout readable [list m::exec::Data $outcmd $donecmd $stdout] + return +} + +proc ::m::exec::spawn2 {routecmd outcmd errcmd donecmd args} { + lassign [chan pipe] readfrom writeto + + set stdout [open |$args 2>@ $writeto] + set stderr $readfrom + + fconfigure $stdout -blocking 0 + fconfigure $stderr -blocking 0 + + set out [list m::exec::Route $routecmd out $outcmd $errcmd] + set err [list m::exec::Route $routecmd err $outcmd $errcmd] + + fileevent $stdout readable [list m::exec::Data $out $donecmd $stdout $stderr] + fileevent $stderr readable [list m::exec::Data $err $donecmd $stderr $stdout] + # TODO: Stop after both are closed! + return +} + +proc ::m::exec::Route {route baseroute out err line} { + set lineroute [Do $route $line] + if {$lineroute ne {}} { + upvar 0 $lineroute cmd + } else { + upvar 0 $baseroute cmd + } + Do $cmd $line +} + +proc ::m::exec::Data {report done chan args} { + if {[eof $chan]} { + foreach $c $args { close $c } + fconfigure $chan -blocking 1 + if {[catch { + close $chan + }] + Do $done + return + } + if {[gets $chan line] < 0} return + Do $report $line + return +} + +proc ::m::exec::Do {cmd args} { + uplevel #0 [list {*}$cmd {*}$args] +} + +# # ## ### ##### ######## ############# ##################### +## Capture management + +proc ::m::exec::capture::to {stdout stderr {enable 1}} { + debug.m/exec {} + B $enable + # Set clear capture destinations, and start (default). + # Note: Be independent of future CWD changes. + variable out [file normalize $stdout] + variable err [file normalize $stderr] + clear + variable active $enable + return +} + +proc ::m::exec::capture::off {{reset 0}} { + debug.m/exec {} + # Stop capture. + B $reset + variable active 0 + if {!$reset} { + debug.m/exec { /done} + return + } + variable out {} + variable err {} + + debug.m/exec {/done+reset} + return +} + +proc ::m::exec::capture::on {} { + # Start capture. Error if no destinations specified + debug.m/exec {} + variable out + variable err + if {($err eq "") || ($out eq "")} { + return -code error \ + -errorcode {M EXEC CAPTURE NO DESTINATION} \ + "Unable to start capture without destination" + } + variable active 1 + return +} + +proc ::m::exec::capture::clear {} { + # Clear the capture buffers + debug.m/exec {} + C out + C err + return +} + +proc ::m::exec::capture::get {key} { + # Get captured content + debug.m/exec {} + V $key + set path [P $key] + if {$path eq {}} return + return [m futil cat $path] +} + +proc ::m::exec::capture::path {key} { + # Get path of capture buffer + debug.m/exec {} + V $key + return [P $key] +} + +proc ::m::exec::capture::active {} { + # Query state of capture system + debug.m/exec {} + variable active + return $active +} + +proc ::m::exec::capture::P {key} { + # Get path of capture buffer + debug.m/exec {} + variable $key + upvar 0 $key path + return $path +} + +proc ::m::exec::capture::C {key} { + debug.m/exec {} + variable $key + upvar 0 $key path + if {$path eq {}} return + # open for writing, truncates. + close [open $path w] + return +} + +proc ::m::exec::capture::V {key} { + debug.m/exec {} + if {$key in {out err}} return + return -code error \ + -errorcode {M EXEC CAPTURE BAD KEY} \ + "Bad channel key $key" +} + +proc ::m::exec::capture::B {x} { + debug.m/exec {} + if {[string is boolean -strict $x]} return + return -code error \ + -errorcode {M EXEC CAPTURE BAD BOOL} \ + "Expected boolean, got \"$x\"" +} + +# # ## ### ##### ######## ############# ##################### + +proc ::m::exec::verbose {{newvalue {}}} { + debug.m/exec {} + variable verbose + if {[llength [info level 0]] == 2} { + capture::B $newvalue + set verbose $newvalue + } + return $verbose +} + +proc ::m::exec::post-hook {args} { + debug.m/exec {} + variable posthook $args + return $posthook +} + +# # ## ### ##### ######## ############# ##################### + +proc ::m::exec::go {cmd args} { + debug.m/exec {} + variable verbose + set args [linsert $args 0 $cmd] + + # V C | + # ----+- + # 0 0 | (a) null + # 0 1 | (b) capture + # 1 0 | (c) pass to inherited out/err + # 1 1 | (d) capture, pass to inherited + + if {$verbose} { + # c, d + m msg "> $args" + } + if {[capture active]} { + # b, d + CAP $args $verbose $verbose + # d - verbose ^----^ + } elseif {$verbose} { + # c + debug.m/exec {2>@ stderr >@ stdout $args} + exec 2>@ stderr >@ stdout {*}$args + } else { + # a + debug.m/exec {2> [NULL] > [NULL] $args} + exec 2> [NULL] > [NULL] {*}$args + } + return +} + +proc ::m::exec::get {cmd args} { + debug.m/exec {} + variable verbose + set args [linsert $args 0 $cmd] + + # V C | + # ----+- + # 0 0 | (a) null to stderr, return stdout + # 0 1 | (b) capture, return stdout + # 1 0 | (c) pass to stderr, return stdout + # 1 1 | (d) capture, return stdout, pass stderr + + if {$verbose} { + # (c) + m msg "> $args" + } + + if {[capture active]} { + # b, d + lassign [CAP $args 0 $verbose] oc ec + # d - verbose -------^ + debug.m/exec {==> ($oc)} + return $oc + } elseif {$verbose} { + # c + debug.m/exec {2>@ stderr $args} + return [exec 2>@ stderr {*}$args] + } else { + # a + debug.m/exec {2> [NULL] $args} + return [exec 2> [NULL] {*}$args] + } +} + +proc ::m::exec::nc-get {cmd args} { + debug.m/exec {} + variable verbose + set args [linsert $args 0 $cmd] + + if {$verbose} { + # c + m msg "> $args" + debug.m/exec {2>@ stderr $args} + return [::exec 2>@ stderr {*}$args] + } else { + # a + debug.m/exec {2> [NULL] $args} + return [::exec 2> [NULL] {*}$args] + } +} + +proc ::m::exec::silent {cmd args} { + debug.m/exec {} + variable verbose + set args [linsert $args 0 $cmd] + + # V C | + # ----+- + # 0 0 | (a) null + # 0 1 | (b) capture + # 1 0 | (c) null + # 1 1 | (d) capture + # ----> a == c + # ----> b == d + + if {$verbose} { + # c, d + m msg "> $args" + } + if {[capture active]} { + # b, d + set o [capture path out] + set e [capture path err] + debug.m/exec {2> $e > $o $args} + exec 2> $e > $o {*}$args + } else { + # a, c + debug.m/exec {2> [NULL] > [NULL] $args} + exec 2> [NULL] > [NULL] {*}$args + } + return +} + +proc ::m::exec::CAP {cmd vo ve} { + debug.m/exec {} + # Note: Temp files capture just current execution, + # Main capture then extended from these. + + variable posthook + set o [capture path out] + set e [capture path err] + + try { + debug.m/exec {2> $e.now > $o.now $cmd} + exec 2> $e.now > $o.now {*}$cmd + } finally { + set oc [m futil cat $o.now] + set ec [m futil cat $e.now] + + # Run the post command hook, if present + if {[llength $posthook]} { + set oc [split $oc \n] + set ec [split $ec \n] + lassign [uplevel #0 [list {*}$posthook $oc $ec]] oc ec + set oc [join $oc \n] + set ec [join $ec \n] + } + + POST $oc $o $vo stdout + POST $ec $e $ve stderr + } + + list $oc $ec +} + +proc ::m::exec::POST {content path verbose stdchan} { + debug.m/exec {} + # Extend capture + m futil append $path $content + if {$verbose} { + # Pass to inherited std channel + puts -nonewline $stdchan $content + flush $stdchan + } + file delete ${path}.now + return +} + +if {$tcl_platform(platform) eq "windows"} { + proc ::m::exec::NULL {} { + debug.m/exec {} + return NUL: + } +} else { + proc ::m::exec::NULL {} { + debug.m/exec {} + return /dev/null + } +} + +# # ## ### ##### ######## ############# ##################### +## State + +namespace eval ::m::exec { + variable verbose 0 + variable posthook {} +} +namespace eval ::m::exec::capture { + variable active 0 + variable out {} + variable err {} +} + +# # ## ### ##### ######## ############# ##################### +return Index: _scratch_/vcs-api-3-schema.md ================================================================== --- _scratch_/vcs-api-3-schema.md +++ _scratch_/vcs-api-3-schema.md @@ -1,48 +1,49 @@ - -repository == remote - -|Attribute |Type |Notes | -|--- |--- |--- | -|url |string |External location | -|store |int |Id of internal store | -|active |bool |Indicator if remote in use | -|check_pending |bool |Indicator if not yet checked in cycle | -|check_active |bool |Indicator if check is running (bg job) | -|attend |bool |Indicator if remote has issues to attend | -|checked |int |Epoch of last check | -|min_duration |int |Min duration (seconds) over all checks | -|max_duration |int |Max duration (seconds) over all checks | -|primary |int |Id of primary remote, set (only) for magic remotes | - -# Update behaviour - -## Primary remote - -### Success (setup, update) - -Read current set of forks from operation log. -Add missing forks as magic remotes. -Remove magic remotes for unknown forks. -Reactivate inactive magic remotes. - -### Failure - -Flag for attend. - -Note: Need a command to re-parent|elect-new-primary - Query github to determine parent of a repo. - -## Magic remote - -### Success - -Store is updated, nothing more. - -### Failure - -Flag for attend. Flag to inactive. -Will be removed on the next round of handling the primary. -Or reactivated if still/again found. - -At store level peers for the magic remote are renamed / moved around -(Do not wish to lose the references) + +repository == remote + +|Attribute |Type |Notes | +|--- |--- |--- | +|url |string |External location | +|store |int |Id of internal store | +|active |bool |Indicator if remote in use | +|check_pending |bool |Indicator if not yet checked in cycle | +|check_active |bool |Indicator if check is running (bg job) | +|attend |bool |Indicator if remote has issues to attend | +|checked |int |Epoch of last check | +|min_duration |int |Min duration (seconds) over all checks | +|max_duration |int |Max duration (seconds) over all checks | +|primary |int |Id of primary remote, set (only) for magic remotes | + +# Update behaviour + +## Primary remote + +### Success (setup, update) + +Read current set of forks from operation log. +Add missing forks as magic remotes. +Remove magic remotes for unknown forks. +Reactivate inactive magic remotes. + +### Failure + +Flag for attend. + +Note: Need a command to re-parent|elect-new-primary + Query github to determine parent of a repo. + + +## Magic remote + +### Success + +Store is updated, nothing more. + +### Failure + +Flag for attend. Flag to inactive. +Will be removed on the next round of handling the primary. +Or reactivated if still/again found. + +At store level peers for the magic remote are renamed / moved around +(Do not wish to lose the references) DELETED doc/schema-v2-issues.md Index: doc/schema-v2-issues.md ================================================================== --- doc/schema-v2-issues.md +++ /dev/null @@ -1,36 +0,0 @@ - -# V2 Schema Issues - - 1. Nit: `Mirror set` is not a good name for the concept. `Project` is better. - - 2. The `Mirror set`, `Repository`, and `Store` relations are not - nicely modeled in the tables. Using the indirect coupling of the - last through the `Mirror set`/`VCS` combination is messy. - - The relation that a `repository` __has a_ (backing) `store` (1:n) - is the core, and not modeled. - - 3. The various fields of the `store_times` table belong to `store`, - and `repository`. It is unclear and not remembered anymore why an - adjunct table was added to the system, instead of the entity - properly extended. - - 4. Nit: The `store_times.attend` field should be named `has_issues`. - - 5. Do we truly need current and previous values for size and commits ? - - 6. Table `store_github_forks` is IMHO superfluous with the ideas - around changing the fork handling currently hidden in the github - driver. See next point. - - 7. The github driver, with its complex internal handling of forks in - a single store is messy and fragile. The fragility is mainly - around the handling of tags per fork, and having to - add/remove/rename/readd origins. - - The other issue is that various git/hub operations are linear in - the number of forks. This becomes problematic above a 100 or so forks. - - It definitely prevents using some kind of timeout to break out of - stuck processes. It cannot be decided if the process is truly - stuck, or simply crawling through the pile of forks. DELETED doc/schema-v2.md Index: doc/schema-v2.md ================================================================== --- doc/schema-v2.md +++ /dev/null @@ -1,175 +0,0 @@ -# V2 - Mirroring. Backing up Sources - -As of 2019-10-03T21:20 (`lib/db/db.tcl`, `SETUP-201910032120` and all preceding). - -Streamlined v1 to basics. - - - Removed VCS operation hooks. - VCS support is fixed, no plugin system. - Near-plugin system through extensible set of VCS specific packages - - - Removed tags. Not needed for an initial setup. - -## Entities - -### Overview - -|Table |Description | -|--- |--- | -|mirror_set |Group of repositories, same logical project | -|mset_pending |Projects waiting for update in current cycle | -|rejected |Rejected repositories, for use by future submissions | -|reply |Mail replies for submission handling | -|repository |A set of versioned files to back up | -|rolodex |Shorthand repository references, recently seen | -|state |Global system state and config | -|store |Local holder of a repository backup | -|store_github_forks |Number of forks per github store | -|store_times |Cycle information per store | -|submission |Submitted repositories waiting for handling | -|submission_handled |Handled submissions for next sync with site database | -|version_control_system |Information about supported VCS | - -### Examples - -|Entity |Example | -|--- |--- | -|Repository | | -| |github@github:andreas.kupries/marpa | -| |https://chiselapp.com/user/andreas-kupries/repository/marpa | -| |https://core.tcl-lang.org/akupries/marpa | -|Mirror Set | | -| |Tcl Marpa | -|Version Control System | | -| |bazaar | -| |cvs | -| |fossil (__+__) | -| |git, github (__+__) | -| |mercurial (hg) (__+__) | -| |monotone | -| |rcs | -| |sccs | -| |svn (__+__) | - -### Core Relations - - 1. A `repository` __is managed by a__ `version control system` (n:1) - 1. A `repository` __belongs to a__ `mirror set` (n:1) - 1. A `store` __is managed by a__ `version control system` (n:1) - 1. A `store` __belongs to a__ `mirror set` (n:1) - 1. A `repository` __has a_ (backing) `store` (1:n) - -The above as a diagram, with some of the adjunct tables added, and the last relation __not__ shown. - -``` - Mset Pending ----\ - \-> /--> Mirror Set <--------------\ - Rolodex --> Repository Store <-- Store Times - \--> Version Control System <--/ \ <-- Store Github Forks - -``` - -### Entity Attributes - -|Entity |Field |Type |Modifiers |Comments | -|--- |--- |--- |--- |--- | -|schema | | | | | -| |key |text |PK |fix: `version` | -| |version |int | | | -|~ |~ |~ |~ |~ | -|mirror_set | | | | | -| |id |int |PK | | -| |name |text |unique | | -|mset_pending | | | | | -| |id |int |PK, FK mirror_set | | -|rejected | | | | | -| |id |int |PK | | -| |url |text |unique | | -| |reason |text | | | -|reply | | | | | -| |id |int |PK | | -| |name |text |unique | | -| |automail |bool | |Send mail by default | -| |isdefault |bool | |Use when no reason given | -| |text |text | | | -|repository | | | | | -| |id |int |PK | | -| |url |text |unique |Loction | -| |vcs |int |FK version_control_... | __index 1__ | -| |mset |int |FK mirror_set | __index 1__ | -| |active |bool | | | -|rolodex | | | | | -| |id |int |PK | | -| |repository |int |unique, FK repository | | -|state | | | | | -| |name |text |PK | | -| |value |text | | | -|store | | | | | -| |id |int |PK | | -| |vcs |int |FK version_control_... | __unique 1__ | -| |mset |int |FK mirror_set | __unique 1__ | -| |size_kb |int | |Kilobyte | -| |size_previous |int | |ditto | -| |commits_current |int | | | -| |commits_previous |int | | | -|store_github_forks | | | | | -| |store |int |PK, FK store | | -| |nforks |int | | | -|store_times | | | | | -| |store |int |PK, FK store | | -| |created |int | |Epoch | -| |updated |int | |Epoch | -| |changed |int | |Epoch | -| |attend |bool | |Has issues | -| |min_seconds |int | | | -| |max_seconds |int | | | -| |window_seconds |text | |CSV, last N | -|submission | | | | | -| |id |int |PK | | -| |session |text | __unique 1__ | | -| |url |text | __unique 1__ | index 1 | -| |vcode |text |nullable | VCS.code | -| |description |text |nullable | | -| |email |text | |subm. email | -| |submitter |text |nullable |subm. name | -| |sdate |int | |epoch, index 2 | -|submission_handled | | | | | -| |session |text | __unique 1__ | | -| |url |text | __unique 1__ | | -|version_control_system | | | | | -| |id |int |PK | | -| |code |text |unique |Short tag | -| |name |text |unique |Human Readable | - -## State keys and semantics - -|Key |Meaning | -|--- |--- | -|limit |State, #repos per `list` page | -|start-of-current-cycle |State, epoch when update cycle started | -|start-of-previous-cycle |State, epoch, previous update cycle | -|store |State, path to stores on disk | -|store-window-size |State, #of update durations to retain | -|take |State, #mirror sets to update per run | -|top |State, repo shown at top of `list` | -|~ |~ | -|mail-debug |Mail transport, debug flag | -|mail-host |Mail transport, smtpd host | -|mail-pass |Mail transport, smtp password | -|mail-port |Mail transport, smtpd port | -|mail-sender |Mail transport, smtp sender | -|mail-tls |Mail transport, tls flag | -|mail-user |Mail transport, smtp user | -|~ |~ | -|mail-footer |Mail config, footer text | -|mail-header |Mail config, header text | -|mail-width |Mail config, table width limit | -|report-mail-destination |Mail config, destination | -|~ |~ | -|site-active |Site config, flag of use | -|site-logo |Site config, url to logo | -|site-mgr-mail |Site config, email of manager | -|site-mgr-name |Site config, name of manager | -|site-store |Site config, path to site on disk | -|site-title |Site config, general title | -|site-url |Site config, url of site | DELETED doc/schema-v3.md Index: doc/schema-v3.md ================================================================== --- doc/schema-v3.md +++ /dev/null @@ -1,240 +0,0 @@ -# V3 - Mirroring. Backing up Sources - -In planning, to address the [issues of V2](schema-v2-issues.md) - -## Changes - - 1. Renamed `mirror_set` to `project`. - 1. Renamed `mset_pending` to `repo_pending`. - 1. Moved `store_times.created` to `store`. - 1. Moved `store_times.updated` to `store`. - 1. Moved `store_times.changed` to `store`. - 1. Moved `store_times.attend` to `repository.has_issues`. - 1. Moved `store_times.min_seconds` to `repository.min_duration`. - 1. Moved `store_times.max_seconds` to `repository.max_duration`. - 1. Moved `store_times.window_seconds` to `repository`. - 1. Dropped table `store_times`. - 1. Dropped table `store_github_forks`. - 1. Redid the core relations. - 1. Made the fork handling explicit in the schema. - 1. Removed `store.mset`. - 1. Renamed `repository.mset` to `repository.project`. - 1. Added `repository.store`. - 1. Added `repository.checked`. - -Redesign of the fork handling: - - 1. A VCS driver may report forks on `setup` and `update` operations. - - 1. The reported forks are automatically added to the project of the - primary (aka fork_origin), as their own repositories, and activated. - - Unreported known forks are deactivated. __Not__ removed. - - 1. Forks get their own store. While this blows up the disk space - needed to handle the project it also makes handling much easier, - as there is no need to fiddle with git(hub) tags and origins. - - If desired it is always possible to manually merge stores. Not - recommended for git. - -## Entities - -### Overview - -|Table |Description | -|--- |--- | -|project |Group of repositories, same logical project | -|rejected |Rejected repositories, for use by future submissions | -|reply |Mail replies for submission handling | -|repo_pending |Repositories waiting for update in current cycle | -|repository |A set of versioned files to back up | -|rolodex |Shorthand repository references, recently seen | -|state |Global system state and config | -|store |Local holder of a repository backup | -|submission |Submitted repositories waiting for handling | -|submission_handled |Handled submissions for next sync with site database | -|version_control_system |Information about supported VCS | - -### Examples - -|Entity |Example | -|--- |--- | -|Repository | | -| |github@github:andreas.kupries/marpa | -| |https://chiselapp.com/user/andreas-kupries/repository/marpa | -| |https://core.tcl-lang.org/akupries/marpa | -|Project | | -| |Tcl Marpa | -|Version Control System | | -| |bazaar | -| |cvs | -| |fossil (__+__) | -| |git, github (__+__) | -| |mercurial (hg) (__+__) | -| |monotone | -| |rcs | -| |sccs | -| |svn (__+__) | - -### Core Relations - - 1. A `project` __has__ zero or more `repositories` (1:n). - 1. __(x)__ A `repository` __belongs to__ a single `project` (n:1). - 1. __(x)__ A `repository` __is managed by__ a single `version control system` (n:1). - 1. A `version control system` __manages__ zero or more `repositories` (1:n). - 1. __(x)__ A `repository` __has_ a single (backing) `store` (1:n). - 1. A `store` __contains the data__ of one or more __repositories (1:n). - 1. __(x)__ A `store` __is managed by__ a single `version control system` (n:1). - 1. A `version control system` __manages__ zero or more `stores` (1:n). - 1. __(x)__ A `repository` may __have__ a parent `repository` it is forked from (n:1). - 1. A `repository` __has__ zero or more forked `repositories` (1:n). - -A checking contraint: - - 1. A `repository` and its backing `store` are managed by the same `version control system`. - - IOW `repository.store.vcs == repository.vcs`. - -Below we see the above as diagram, with the relations marked __(x)__ -as the shown arrows / foreign key references, and some adjunct tables added. - -``` -rolodex ------>\ -repo_pending -->\ - project <-- repository ------------------->\ - \--> store ---------> version_control_system -``` - -### Entity Attributes - -|Entity |Field |Type |Modifiers |Comments | -|--- |--- |--- |--- |--- | -|schema | | | | | -| |key |text |PK |fix: `version` | -| |version |int | | | -|~ |~ |~ |~ |~ | -|__Main Database__ | | | | | -|~ |~ |~ |~ |~ | -|project | | | | | -| |id |int |PK | | -| |name |text |unique | | -|repo_pending | | | | | -| |id |int |PK, FK repository | | -|rejected | | | | | -| |id |int |PK | | -| |url |text |unique | | -| |reason |text | | | -|reply | | | | | -| |id |int |PK | | -| |name |text |unique | | -| |automail |bool | |Send mail by default | -| |isdefault |bool | |Use when no reason given | -| |text |text | | | -|repository | | | | | -| |id |int |PK | | -| |url |text |unique |Location | -| |project |int |FK project | __index 1__ | -| |vcs |int |FK version_control_... | __index 1__ | -| |store |int |FK store | __index 2__ | -| |fork_origin |int |FK repository, nullable| __index 3__ | -| |is_active |bool | | | -| |has_issues |bool | |Has issues | -| |min_duration |int | | | -| |max_duration |int | | | -| |window_duration |text | |CSV, last N | -| |checked |int | |epoch | -|rolodex | | | | | -| |id |int |PK | | -| |repository |int |unique, FK repository | | -|state | | | | | -| |name |text |PK | | -| |value |text | | | -|store | | | | | -| |id |int |PK | | -| |vcs |int |FK version_control_... | | -| |size_kb |int | |Kilobyte | -| |size_previous |int | |ditto | -| |commits_current |int | | | -| |commits_previous |int | | | -| |created |int | |Epoch | -| |updated |int | |Epoch | -| |changed |int | |Epoch | -|submission | | | | | -| |id |int |PK | | -| |session |text | __unique 1__ | | -| |url |text | __unique 1__ | index 1 | -| |vcode |text |nullable | VCS.code | -| |description |text |nullable | | -| |email |text | |subm. email | -| |submitter |text |nullable |subm. name | -| |sdate |int | |epoch, index 2 | -|submission_handled | | | | | -| |session |text | __unique 1__ | | -| |url |text | __unique 1__ | | -|version_control_system | | | | | -| |id |int |PK | | -| |code |text |unique |Short tag | -| |name |text |unique |Human Readable | -|~ |~ |~ |~ |~ | -|__Site Database__ | | | | | -|~ |~ |~ |~ |~ | -|cache_desc | | | | | -| |expiry |int | |epoch | -| |url |text |unique | | -| |desc |text | | | -|cache_url | | | | | -| |expiry |int | |epoch | -| |url |text |unique | | -| |ok |int | | | -| |resolved |text | | | -|rejected | | | | | -| |main.rejected | | | | -|store_index | | | | | -| |id |int |PK | | -| |name |text | __unique 1__ |index 1 | -| |vcode |text | __unique 1__ | | -| |page |text | | | -| |remotes |text | |index 2 | -| |status |text | | | -| |size_kb |int | | | -| |changed |int | |epoch | -| |updated |int | |epoch | -| |created |int | |epoch | -|submission | | | | | -| |main.submission | | | | -|vcs | | | | | -| |main.version_control_system| | | | - -## State keys and semantics - -|Key |Meaning | -|--- |--- | -|limit |State, #repos per `list` page | -|start-of-current-cycle |State, epoch when update cycle started | -|start-of-previous-cycle |State, epoch, previous update cycle | -|store |State, path to stores on disk | -|store-window-size |State, #of update durations to retain | -|take |State, #repositories to update per run | -|top |State, repo shown at top of `list` | -|~ |~ | -|mail-debug |Mail transport, debug flag | -|mail-host |Mail transport, smtpd host | -|mail-pass |Mail transport, smtp password | -|mail-port |Mail transport, smtpd port | -|mail-sender |Mail transport, smtp sender | -|mail-tls |Mail transport, tls flag | -|mail-user |Mail transport, smtp user | -|~ |~ | -|mail-footer |Mail config, footer text | -|mail-header |Mail config, header text | -|mail-width |Mail config, table width limit | -|report-mail-destination |Mail config, destination | -|~ |~ | -|site-active |Site config, flag of use | -|site-logo |Site config, url to logo | -|site-mgr-mail |Site config, email of manager | -|site-mgr-name |Site config, name of manager | -|site-store |Site config, path to site on disk | -|site-title |Site config, general title | -|site-url |Site config, url of site | ADDED doc/schema.md Index: doc/schema.md ================================================================== --- /dev/null +++ doc/schema.md @@ -0,0 +1,247 @@ +# V2 - Mirroring. Backing up Sources + +Streamlined v1 to basics. + + - Removed VCS operation hooks. + VCS support is coded fixed, no plugin system. + + - Removed tags. Not needed for an initial setup. + +## Entities + + 1. Repository. + Examples: + + - https://core.tcl-lang.org/akupries/marpa/ + - github@github:andreas.kupries/marpa + - https://chiselapp.com/user/andreas-kupries/repository/marpa/ + + A versioned collection of files. + + 1. Mirror Set. + Example: + + - First item. + + A group of repositories holding the same versioned collection of + files. + + 1. Version Control System (VCS). + Examples: + - git + - fossil + - bazaar + - mercurial + - monotone + - svn + - cvs + - rcs + - sccs + + An application (or collection thereof) to manage a repository. + + 1. Store + + A repository, internal to the mirroring system. Each kind of VCS + used by a sub-set of the repositories in a mirror set has an + associated store, to hold the local mirror of the repositories + in question. + + 1. Name + + The name of a mirror set. This is an 1:1 relation. + + It is separate from the mirror set because this is also the hook + where we can replace the link to the name with a link into a Tcl + Package Pedia containing much more information. + +## Entity Relations + +``` +Repository has-a|is-managed-by-a Version Control System + n:1 + +Repository belongs-to-a Mirror Set + n:1 + +Mirror Set has-a Name + 1:1 + +Store has-a|is-managed-by-a Version Control System + n:1 + +Store belongs-to-a Mirror Set + n:1 +``` + +As a diagram + +``` + Mset Pending ----\ /-> Name + \-> /--> Mirror Set <--------------\ + Rolodex --> Repository Store <-- Store Times + \--> Version Control System <--/ + +``` + +## Entities & Attributes + +### version_control_system + +|Name |Type |Modifiers |Comments | +|--- |--- |--- |--- | +|id |int |PK | | +|code |text |unique |Short tag | +|name |text |unique |Human Readable | + +### name + +|Name |Type |Modifiers |Comments | +|--- |--- |--- |--- | +|id |int |PK | | +|name |text |unique | | + +### mirror_set + +|Name |Type |Modifiers |Comments | +|--- |--- |--- |--- | +|id |int |PK | | +|name |int |unique, FK name|1:1 | + +### mset_pending + +|Name |Type |Modifiers |Comments | +|--- |--- |--- |--- | +|id |int |PK, FK mirror_set | | + +### repository + +|Name |Type |Modifiers |Comments | +|--- |--- |--- |--- | +|id |int |PK | | +|url |text |unique |Location | +|vcs |int |FK version_control_system | __index 1__ | +|mset |int |FK mirror_set | __index 1__ | +|active |bool | | | + +### rolodex + +|Name |Type |Modifiers |Comments | +|--- |--- |--- |--- | +|id |int |PK | | +|repository |int |unique, FK repository | | + +### store + +|Name |Type |Modifiers |Comments | +|--- |--- |--- |--- | +|id |int |PK | | +|path |text |unique |Relative to `state('store')` | +|vcs |int |FK version_control_system | __index 1__ | +|mset |int |FK mirror_set | __index 1__ | +|size_kb |int | | | +|size_previous |int | | | +|commits_current|int | | | +|commit_previous|int | | | + +### store_times + +|Name |Type |Modifiers |Comments | +|--- |--- |--- |--- | +|store |int |PK, FK store | | +|created |int | |epoch | +|updated |int | |epoch | +|changed |int | |epoch | +|attend |bool | |flag for issues | +|min_seconds |int | |min duration of updates | +|max_seconds |int | |max duration of update | +|window_seconds |text | |CSV line for durations | + +## Entities & Attributes around submission handling + +### submission + +|Name |Type |Modifiers |Comments | +|--- |--- |--- |--- | +|id |int |PK | | +|session |text |unique (+url) |int. code for session ident | +|url |text |unique (+sess) |__index 1__, location | +|vcode |text |nullable |vcs | +|description |text |nullable | | +|email |text | |submitter email | +|submitter |text |nullable | | +|sdate |int | |__index 2__, epoch | + +### submission_handled + +|Name |Type |Modifiers |Comments | +|--- |--- |--- |--- | +|session|text |unique (+url) | | +|url |text |unique (+sess) | | + +### rejected + +|Name |Type |Modifiers |Comments | +|--- |--- |--- |--- | +|id |int |PK | | +|url |text |unique | | +|reason |text | | | + +### reply + +|Name |Type |Modifiers |Comments | +|--- |--- |--- |--- | +|id |int |PK | | +|name |text |unique | | +|automail |bool | |Send mail by default when used | +|isdefault |bool | |Use this when no reason spec'd | +|text |text | | | + +## Entities & Attributes for Internal Management + +### schema + +|Name |Type |Modifiers |Comments | +|--- |--- |--- |--- | +|key |text |PK |always 'version' | +|version|int | |version number | + +### state + +|Name |Type |Modifiers |Comments | +|--- |--- |--- |--- | +|name |text |PK | | +|value |text | | | + +Known keys + +|Key |Meaning | +|--- |--- | +|limit |State, #repos per `list` page | +|start-of-current-cycle |State, epoch when update cycle started | +|start-of-previous-cycle |State, epoch, previous update cycle | +|store |State, path to stores on disk | +|store-window-size |State, #of update durations to retain | +|take |State, #mirror sets to update per run | +|top |State, repo shown at top of `list` | +|~ |~ | +|mail-debug |Mail transport, debug flag | +|mail-host |Mail transport, smtpd host | +|mail-pass |Mail transport, smtp password | +|mail-port |Mail transport, smtpd port | +|mail-sender |Mail transport, smtp sender | +|mail-tls |Mail transport, tls flag | +|mail-user |Mail transport, smtp user | +|~ |~ | +|mail-width |Mail config, table width limit | +|mail-footer |Mail config, footer text | +|mail-header |Mail config, header text | +|report-mail-destination |Mail config, destination | +|~ |~ | +|site-active |Site config, flag of use | +|site-logo |Site config, url to logo | +|site-mgr-mail |Site config, email of manager | +|site-mgr-name |Site config, name of manager | +|site-store |Site config, path to site on disk | +|site-title |Site config, general title | +|site-url |Site config, url of site | Index: lib/cli/cmdr.tcl ================================================================== --- lib/cli/cmdr.tcl +++ lib/cli/cmdr.tcl @@ -203,23 +203,23 @@ Terminal Height. Auto supplied to all commands. } { generate [lambda {args} { linenoise lines }] } - common .optional-project { - input project { - The project to operate on. + common .optional-mirror-set { + input mirror-set { + The mirror set to operate on. } { optional - validate [m::cmdr::vt project] - generate [m::cmdr::call glue gen_current_project] + validate [m::cmdr::vt mset] + generate [m::cmdr::call glue gen_current_mset] } } - common .list-optional-project { - input projects { - Projects to operate on. - } { list ; optional ; validate [m::cmdr::vt project] } + common .list-optional-mirror-set { + input mirror-sets { + Repositories to operate on. + } { list ; optional ; validate [m::cmdr::vt mset] } } common .optional-repository { input repository { Repository to operate on. @@ -283,15 +283,15 @@ } { optional ; validate rwpath } } [m::cmdr::call glue cmd_store] private take { description { - Query/change the number of repositories processed per + Query/change the number of mirror sets processed per update cycle. } input take { - New number of projects to process in one update. + New number of mirror sets to process in one update. } { optional ; validate cmdr::validate::posint } } [m::cmdr::call glue cmd_take] private report { description { @@ -382,17 +382,14 @@ private add { use .cms description { Add repository. The new repository is placed into its own - project. Command tries to auto-detect vcs type if not + mirror set. Command tries to auto-detect vcs type if not specified. Command derives a name from the url if not specified. New repository becomes current. } - option track-forks { - Force tracking when seeing a large number of forks. - } { presence } option vcs { Version control system handling the repository. } { validate [m::cmdr::vt vcs] generate [m::cmdr::call glue gen_vcs] @@ -405,11 +402,11 @@ } input url { Location of the repository to add. } { validate [m::cmdr::vt url] } option name { - Name for the project to hold the repository. + Name for the mirror set to hold the repository. } { alias N validate str generate [m::cmdr::call glue gen_name] } @@ -416,46 +413,46 @@ } [m::cmdr::call glue cmd_add] private rename { use .cms description { - Change the name of the specified project, or - the project indicated by the current repository. + Change the name of the specified mirror set, or the mirror + set indicated by the current repository. The rolodex does not change. } - use .optional-project + use .optional-mirror-set input name { - New name for the project. + New name for the mirror set. } { validate str } } [m::cmdr::call glue cmd_rename] private merge { use .cms description { - Merges the specified projects into a single project. - When only one project is specified the set of the + Merges the specified mirror sets into a single mirror + set. When only one mirror set is specified the set of the current repository is used as the merge target. When no - projects are specified at all the projects of + mirror sets are specified at all the mirror sets of current and previous repositories are merged, using - the prooject of current as merge target + the mirror set of current as merge target - The name of the primary project becomes the name of the + The name of the primary mirror set becomes the name of the merge. The rolodex does not change. } - use .list-optional-project + use .list-optional-mirror-set } [m::cmdr::call glue cmd_merge] private split { use .cms description { - Split the specified or current repository from its project. - Generates a new project for the repository. The name will be - derived from the original name. The referenced repository - becomes current. + Split the specified or current repository from its mirror + set. Generates a new mirror set for the repository. The + name will be derived from the original name. The + referenced repository becomes current. If the referenced repository is a standalone already then nothing is done. } use .optional-repository @@ -470,27 +467,27 @@ alias @ private export { use .cms.ex description { - Write the known set of repositories and projects to + Write the known set of repositories and mirror sets to stdout, in a form suitable for (re)import. } } [m::cmdr::call glue cmd_export] private import { use .cms.ex description { - Read a set of repositories and projects from the - specified file, or stdin, and add them here. Ignores - known repositories. Makes projects on name conflicts. - Ignores projects with no repositories (including only - ignored repositories). Processes the format generated - by export. + Read a set of repositories and mirror sets from the + specified file, or stdin, and add them here. Ignores known + repositories. Makes new mirror sets on name + conflicts. Ignores mirror sets with no repositories + (including only ignored repositories). Processes the + format generated by export. } option dated { - Add datestamp to the generated projects. + Add datestamp to the generated mirror sets. } { presence } input spec { Path to the file to read the import specification from. Falls back to stdin when no file is specified. } { optional ; validate rchan ; default stdin } @@ -515,17 +512,17 @@ } [m::cmdr::call glue cmd_swap_current] private update { use .cms description { - Runs an update cycle on the specified repositories. When no - repositories are specified use the next `take` number of - repositories from the list of pending repositories. If no - repositories are pending refill the list with the entire - set of repositories and then take from the list. + Runs an update cycle on the specified mirror sets. When no + mirror sets are specified use the next `take` number of + mirror sets from the list of pending mirror sets. If no + mirror sets are pending refill the list with the entire + set of mirror sets and then take from the list. } - use .list-optional-repository + use .list-optional-mirror-set } [m::cmdr::call glue cmd_update] private updates { use .cms.in description { @@ -536,13 +533,13 @@ } [m::cmdr::call glue cmd_updates] private pending { use .cms.in description { - Show list of currently pending repositories. I.e repositories - waiting for an update. Order shown is the order they are taken, - from the top down. + Show list of currently pending mirror sets. I.e mirror + sets waiting for an update. Order shown is the order they + are taken, from the top down. } } [m::cmdr::call glue cmd_pending] private issues { use .cms.in @@ -579,11 +576,11 @@ generate [m::cmdr::call glue gen_limit] } input pattern { When specified, search for repositories matching the pattern. This is a case-insensitive substring search on - repository urls and project names. A search overrides + repository urls and mirror set names. A search overrides and voids any and all repository and limit specifications. This also keeps the cursor unchanged. The rolodex however is filled with the search results. } { optional ; validate str } } [m::cmdr::call glue cmd_list] @@ -644,11 +641,11 @@ Internal code, derived from the option value (database id). } { generate [m::cmdr::call glue gen_vcs_code] } option name { - Name for the future project to hold the submitted repository. + Name for the future mirror set to hold the submitted repository. } { alias N validate str generate [m::cmdr::call glue gen_name] } @@ -670,13 +667,10 @@ Override the submission. } { validate [m::cmdr::vt vcs] generate [m::cmdr::call glue gen_submit_vcs] } - option track-forks { - Force tracking when seeing a large number of forks. - } { presence } option nomail { Disable generation and sending of acceptance mail. } { presence } state vcs-code { Version control system handling the repository. @@ -688,11 +682,11 @@ Location of the repository. Taken from the submission. } { validate str generate [m::cmdr::call glue gen_submit_url] } option name { - Name for the project to hold the repository. + Name for the mirror set to hold the repository. Overrides the name from the submission. } { alias N validate str generate [m::cmdr::call glue gen_submit_name] @@ -958,15 +952,15 @@ description { Show the knowledge map used by the repository validator. } } [m::cmdr::call glue cmd_test_vt_repository] - private test-vt-project { + private test-vt-mset { description { - Show the knowledge map used by the project validator. + Show the knowledge map used by the mirror-set validator. } - } [m::cmdr::call glue cmd_test_vt_project] + } [m::cmdr::call glue cmd_test_vt_mset] private test-vt-submission { description { Show the knowledge map used by the submission validator. } Index: lib/cli/glue.tcl ================================================================== --- lib/cli/glue.tcl +++ lib/cli/glue.tcl @@ -131,11 +131,11 @@ return $vcs } proc ::m::glue::gen_name {p} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset package require m::vcs # Derive a name from the url when no such was specified by the # user. Add a serial number if that name is already in use. set name [MakeName \ @@ -189,24 +189,24 @@ debug.m/glue {[debug caller] | undefined } $p undefined! # Will not reach here } -proc ::m::glue::gen_current_project {p} { +proc ::m::glue::gen_current_mset {p} { debug.m/glue {[debug caller] | } - # Provide current as project for operation when not specified + # Provide current as mirror set for operation when not specified # by the user. Fail if we have no current repository to trace # from. package require m::repo package require m::rolodex # set r [m rolodex top] if {$r ne {}} { - set project [m repo project $r] - if {$project ne {}} { - debug.m/glue {[debug caller] | --> $project } - return $project + set m [m repo mset $r] + if {$m ne {}} { + debug.m/glue {[debug caller] | --> $m } + return $m } } debug.m/glue {[debug caller] | [$p config] } debug.m/glue {[debug caller] | undefined } @@ -216,11 +216,11 @@ # # ## ### ##### ######## ############# ###################### proc ::m::glue::cmd_import {config} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset package require m::repo package require m::rolodex package require m::store package require m::url @@ -240,14 +240,14 @@ OK } proc ::m::glue::cmd_export {config} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset package require m::repo - m msg [m project spec] + m msg [m mset spec] } proc ::m::glue::cmd_reply_add {config} { debug.m/glue {[debug caller] | } package require m::db @@ -361,11 +361,11 @@ OK } proc ::m::glue::cmd_show {config} { debug.m/glue {[debug caller] | } - package require m::repo + package require m::mset package require m::state set all [$config @all] m db transaction { @@ -373,11 +373,11 @@ if {!$n} { set n [color note {adjust to terminal height}] } [table/d t { $t add Store [m state store] $t add Limit $n - $t add Take "[m state take] ([m repo count-pending] pending/[m repo count] total)" + $t add Take "[m state take] ([m mset count-pending] pending/[m mset count] total)" $t add Window [m state store-window-size] $t add {Report To} [m state report-mail-destination] $t add {-} {} $t add {Cycle, Last} [m format epoch [m state start-of-previous-cycle]] $t add {Cycle, Now} [m format epoch [m state start-of-current-cycle]] @@ -530,11 +530,11 @@ } set n [m state take] } - set g [expr {$n == 1 ? "project" : "projects"}] + set g [expr {$n == 1 ? "mirror set" : "mirror sets"}] m msg "Per update, take [color note $n] $g" OK } proc ::m::glue::cmd_window {config} { @@ -584,11 +584,11 @@ OK } proc ::m::glue::cmd_add {config} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset package require m::repo package require m::rolodex package require m::store m db transaction { @@ -599,51 +599,44 @@ OK } proc ::m::glue::cmd_remove {config} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset package require m::repo package require m::rolodex package require m::store m db transaction { set repo [$config @repository] - - set rinfo [m repo get $repo] - dict with rinfo {} - # -> url : repo url - # vcs : vcs id - # -> vcode : vcs code - # -> project: project id - # -> name : project name - # -> store : id of backing store for repo - - m msg "Removing $vcode repository [color note $url] ..." - m msg "from Project [color note $name]" - + m msg "Removing [color note [m repo name $repo]] ..." + + set rinfo [m repo get $repo] + dict with rinfo {} + # -> url : repo url + # vcs : vcs id + # vcode : vcs code + # mset : mirror set id + # name : mirror set name + # store : store id, of backing store for the repo + m repo remove $repo - set siblings [m store remotes $store] - set nsiblings [llength $siblings] - if {!$nsiblings} { - m msg "- Removing unshared $vcode store $store ..." + # TODO MAYBE: stuff how much of the cascading remove logic + # TODO MAYBE: into `repo remove` ? + + # Remove store for the repo's vcs if no repositories for that + # vcs remain in the mirror set. + if {![m mset has-vcs $mset $vcs]} { + m msg "- Removing $vcode store ..." m store remove $store - } else { - set x [expr {($nsiblings == 1) ? "repository" : "repositories"}] - m msg "- Keeping $vcode store $store still used by $nsiblings $x" } - # Remove project if no repositories remain at all. - set nsiblings [m project size $project] - - if {!$nsiblings} { - m msg "- Removing now empty project ..." - m project remove $project - } else { - set x [expr {($nsiblings == 1) ? "repository" : "repositories"}] - m msg "- Keeping project still used by $nsiblings $x" + # Remove mirror set if no repositories remain at all. + if {![m mset size $mset]} { + m msg "- Removing mirror set [color note $name] ..." + m mset remove $mset } m rolodex drop $repo m rolodex commit } @@ -663,211 +656,139 @@ lappend r $line } join $r \n } -proc m::glue::Short {repo} { - set ri [m repo get $repo] - dict with ri {} - - set active [color {*}[dict get { - 0 {warning offline} - 1 {note UP} - } [expr {!!$active}]]] - - return "$url ([SIB [expr {!$issues}]] $active)" -} - -proc ::m::glue::cmd_details {config} { ;# XXX REWORK due the project/repo/store relation changes +proc ::m::glue::cmd_details {config} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset package require m::repo package require m::rolodex package require m::state package require m::store package require linenoise - set w [$config @tw] ;#linenoise columns + set w [$config @tw] ;#linenoise columns # table/d -> 2 columns, 7 overhead, 1st col 14 wide => set w [expr {$w - 21}] ;# max width for col 2. - + m db transaction { set full [$config @full] set repo [$config @repository] + m msg "Details of [color note [m repo name $repo]] ..." - # Basic repository details ........................... set rinfo [m repo get $repo] dict with rinfo {} - #m msg "Details of [color note $url] ..." - # -> url : repo url - # active : usage state - # vcs : vcs id - # vcode : vcs code - # * project: project id - # * name : project name - # -> store : id of backing store for repo - # min_sec: minimal time spent on setup/update - # max_sec: maximal time spent on setup/update - # win_sec: last n times for setup/update - # checked: epoch of last check - # origin : repository this is forked from, or empty + # -> url : repo url + # vcs : vcs id + # vcode : vcs code + # * mset : mirror set id + # * name : mirror set name + # * store : store id, of backing store for the repo + + # Get pieces ... + + lassign [m store remotes $store] remotes plugin + lappend r Remotes $remotes + if {[llength $plugin]} { + lappend r {*}$plugin + } + + set path [m store path $store] + set sd [m store get $store] + dict with sd {} + # -> size, sizep + # commits, commitp + # vcs + # vcsname + # created + # changed + # updated + # min_sec, max_sec, win_sec set spent [StatsTime $min_sec $max_sec $win_sec] - # Get store details ... - - set path [m store path $store] - set sd [m store get $store] - dict unset sd vcs - dict unset sd min_sec - dict unset sd max_sec - dict unset sd win_sec - dict with sd {} - # size, sizep - # commits, commitp - # vcsname - # created - # changed - # updated lassign [m vcs caps $store] stdout stderr set stdout [string trim $stdout] set stderr [string trim $stderr] - - # Find repositories sharing the store ................ - - set storesibs [m store repos $store] - - # Find repositories which are siblings of the same origin - - set forksibs {} - set dorigin {} - if {$origin ne {}} { - set forksibs [m repo forks $origin] - set dorigin [Short $origin] - } - - # Find repositories which are siblings of the same project - - set projectsibs [m repo for $project] - - #puts O(($origin))/\nR(($repo))/\nS(($storesibs))/\nF(($forksibs))/\nP(($projectsibs)) - - # Compute derived information ... set status [SI $stderr] set export [m vcs export $vcs $store] set dcommit [DeltaCommitFull $commits $commitp] set dsize [DeltaSizeFull $size $sizep] set changed [color note [m format epoch $changed]] set updated [m format epoch $updated] set created [m format epoch $created] - - set active [color {*}[dict get { - 0 {warning offline} - 1 {note UP} - } [expr {!!$active}]]] - - set s [[table/d s { - $s borders 0 - set sibs 0 - foreach sibling $storesibs { - if {$sibling == $repo} continue - incr sibs - $s add ${sibs}. [Short $sibling] - } - if {$sibs} { $s add {} {} } - $s add Size $dsize - $s add Commits $dcommit - if {$export ne {}} { - $s add Export $export - } - $s add {Update Stats} $spent - $s add {Last Change} $changed - $s add {Last Check} $updated - $s add Created $created - - if {!$full} { - set nelines [llength [split $stderr \n]] - set nllines [llength [split $stdout \n]] - - if {$nelines == 0} { set nelines [color note {no log}] } - if {$nllines == 0} { set nllines [color note {no log}] } - - $s add Operation $nllines - if {$stderr ne {}} { - $s add "Notes & Errors" [color bad $nelines] - } else { - $s add "Notes & Errors" $nelines - } - } else { - if {$stdout ne {}} { $s add Operation [L $stdout] } - if {$stderr ne {}} { $s add "Notes & Errors" [L $stderr] } - } - }] show return] - - [table/d t { - $t add {} [color note $url] - if {$origin ne {}} { - $t add Origin $dorigin - } - $t add Status "$status $active @[color note [m format epoch $checked]]" - $t add Project $name - $t add VCS $vcsname - - $t add {Local Store} $path - $t add {} $s - - # Show other locations serving the project, except for forks. - # Forks are shown separately. - set sibs 0 - foreach sibling $projectsibs { - if {$sibling == $repo} continue - if {$sibling == $origin} continue - if {$sibling in $storesibs} continue - if {$sibling in $forksibs} continue - if {!$sibs} { $t add Other {} } - incr sibs - $t add ${sibs}. [Short $sibling] - } - - set threshold 20 - # Show the sibling forks. Only the first, only if not sharing the store. - set sibs 0 - foreach sibling $forksibs { - if {$sibling == $repo} continue - if {$sibling == $origin} continue - if {$sibling in $storesibs} continue - if {!$sibs} { $t add Related {} } - incr sibs - - # - if {$sibs > $threshold} continue - $t add ${sibs}. [Short $sibling] - } - if {$sibs > $threshold} { - $t add {} "(+[expr {$sibs - $threshold}] more)" - } - + + [table/d t { + $t add Status $status + $t add {Mirror Set} $name + $t add VCS $vcsname + $t add {Local Store} $path + $t add Size $dsize + $t add Commits $dcommit + if {$export ne {}} { + $t add Export $export + } + $t add {Update Stats} $spent + $t add {Last Change} $changed + $t add {Last Check} $updated + $t add Created $created + + set active 1 + foreach {label urls} $r { + $t add $label "\#[llength $urls]" + # TODO: options to show all, part, none + if {$label eq "Forks"} break + foreach url [lsort -dict $urls] { + incr id + set a " " + if {$active} { + set a [dict get [m repo get [m repo id $url]] active] + if {$a} { + set a " " + } else { + set a "off " + } + } + $t add $id [L "$a$url"] + } + unset -nocomplain id + incr active -1 + } + + if {!$full} { + set nelines #[llength [split $stderr \n]] + set nllines #[llength [split $stdout \n]] + + $t add Operation $nllines + if {$stderr ne {}} { + $t add "Notes & Errors" [color bad $nelines] + } else { + $t add "Notes & Errors" $nelines + } + } else { + if {$stdout ne {}} { $t add Operation [L $stdout] } + if {$stderr ne {}} { $t add "Notes & Errors" [L $stderr] } + } }] show } OK } proc ::m::glue::SI {stderr} { - SIB [expr {$stderr eq {}}] -} - -proc ::m::glue::SIB {ok} { - color {*}[dict get { - 0 {bad ATTEND} - 1 {good OK} - } $ok] + if {$stderr eq {}} { + return [color good OK] + } else { + set status images/bad.svg + return [color bad ATTEND] + } } proc ::m::glue::cmd_enable {flag config} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset package require m::repo package require m::rolodex package require m::store set op [expr {$flag ? "Enabling" : "Disabling"}] @@ -879,21 +800,22 @@ set rinfo [m repo get $repo] dict with rinfo {} # -> url : repo url # vcs : vcs id # vcode : vcs code - # project: project id - # name : project name - # store : id of backing store for repo - + # mset : mirror set id + # name : mirror set name + # store : store id, of backing store for the repo + m repo enable $repo $flag - # Note: We do not manipulate `repo_pending`. An existing - # repo is always in `repo_pending`, even if it is - # inactive. The commands to retrieve the pending repos - # (all, or taken for update) is where we do the filtering, - # i.e. exclusion of the inactive. + # Note: We do not manipulate `mset_pending`. An existing + # mirror set is always in `mset_pending`, even if all its + # remotes are inactive. The commands to retrieve the + # pending msets (all, or taken for update) is where we do + # the filtering, i.e. exclusion of those without active + # remotes. } } ShowCurrent $config SiteRegen @@ -900,64 +822,64 @@ OK } proc ::m::glue::cmd_rename {config} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset package require m::store m db transaction { - set project [$config @project] ; debug.m/glue {project : $project} - set newname [$config @name] ; debug.m/glue {new name: $newname} - set oldname [m project name $project] + set mset [$config @mirror-set] ; debug.m/glue {mset : $mset} + set newname [$config @name] ; debug.m/glue {new name: $newname} + set oldname [m mset name $mset] m msg "Renaming [color note $oldname] ..." if {$newname eq $oldname} { m::cmdr::error \ "The new name is the same as the current name." \ NOP } - if {[m project has $newname]} { + if {[m mset has $newname]} { m::cmdr::error \ "New name [color note $newname] already present" \ HAVE_ALREADY NAME } - Rename $project $newname + Rename $mset $newname } ShowCurrent $config SiteRegen OK } proc ::m::glue::cmd_merge {config} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset package require m::repo package require m::rolodex package require m::store package require m::vcs m db transaction { - set msets [Dedup [MergeFill [$config @projects]]] + set msets [Dedup [MergeFill [$config @mirror-sets]]] # __Attention__: Cannot place the mergefill into a generate # clause, the parameter logic is too simple (set / not set) to # handle the case of `set only one`. debug.m/glue {msets = ($msets)} if {[llength $msets] < 2} { m::cmdr::error \ - "All repositories are already in the same project." \ + "All repositories are already in the same mirror set." \ NOP } set secondaries [lassign $msets primary] - m msg "Target: [color note [m project name $primary]]" + m msg "Target: [color note [m mset name $primary]]" foreach secondary $secondaries { - m msg "Merging: [color note [m project name $secondary]]" + m msg "Merging: [color note [m mset name $secondary]]" Merge $primary $secondary } } ShowCurrent $config @@ -965,62 +887,62 @@ OK } proc ::m::glue::cmd_split {config} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset package require m::repo package require m::rolodex package require m::store package require m::vcs m db transaction { set repo [$config @repository] set rinfo [m repo get $repo] dict with rinfo {} - # -> url : repo url - # vcs : vcs id - # vcode : vcs code - # project: project id - # name : project name - # store : id of backing store for repo + # -> url : repo url + # vcs : vcs id + # vcode : vcs code + # mset : mirror set id + # name : mirror set name + # store : store id, of backing store for the repo m msg "Attempting to separate" m msg " Repository [color note $url]" m msg " Managed by [color note [m vcs name $vcs]]" m msg "From" - m msg " Project [color note $name]" + m msg " Mirror set [color note $name]" - if {[m project size $mset] < 2} { + if {[m mset size $mset] < 2} { m::cmdr::error \ - "The project is to small for splitting" \ + "The mirror set is to small for splitting" \ ATOMIC } - set newname [MakeName $name] - set projectnew [m project add $newname] + set newname [MakeName $name] + set msetnew [m mset add $newname] m msg "New" - m msg " Project [color note $newname]" + m msg " Mirror set [color note $newname]" - m repo move/1 $repo $projectnew + m repo move/1 $repo $msetnew - if {![m project has-vcs $mset $vcs]} { + if {![m mset has-vcs $mset $vcs]} { # The moved repository was the last user of its vcs in the - # original project. We can simply move its store over + # original mirror set. We can simply move its store over # to the new holder to be ok. m msg " Move store ..." - m store move $store $projectnew + m store move $store $msetnew } else { # The originating mset still has users for the store used # by the moved repo. Need a new store for the moved repo. m msg " Split store ..." - m store cleave $store $projectnew + m store cleave $store $msetnew } } ShowCurrent $config SiteRegen @@ -1062,109 +984,71 @@ OK } proc ::m::glue::cmd_update {config} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset package require m::state package require m::store - package require struct::set set startcycle [m state start-of-current-cycle] set nowcycle [clock seconds] - + m db transaction { set verbose [$config @verbose] - set repos [UpdateRepos $startcycle $nowcycle [$config @repositories]] - - debug.m/glue {repositories = ($repos)} - - foreach repo $repos { - set ri [m repo get $repo] - dict with ri {} - # url, active, issues, vcs, vcode, project, name, store - # min/max/win_sec, checked, origin - - set si [m store get $store] - # size, vcs, sizep, commits, commitp, vcsname, updated, changed, created - # (atted, min/max/win, remote, active) - set before [dict get $si commits] - - set durl [color note $url] - if {$origin eq {}} { set durl [color bg-cyan $durl] } - - m msg "Updating repository $durl ..." - m msg "In project [color note $name]" - if {$verbose} { - m msg " [color note [string totitle $vcode]] store ... " - } else { - m msg* " [string totitle $vcode] store ... " - } - set primary [expr {$origin eq {}}] - - # -- has_issues, is_active/enable -- fork handling - - set now [clock seconds] - lassign [m store update $primary $url $store $nowcycle $now $before] \ - ok duration commits size forks - set attend [expr {!$ok || [m store has-issues $store]}] - set suffix ", in [color note [m format interval $duration]]" - - m repo times $repo $duration $now $attend - if {!$primary && $attend} { m repo enable $repo 0 } - - if {!$ok} { - lassign [m vcs caps $store] _ e - m msg "[color bad Fail]$suffix" - m msg $e - - continue - } elseif {$before != $commits} { - set delta [expr {$commits - $before}] - if {$delta < 0} { - set mark bad - } else { - set mark note - set delta +$delta - } - m msg "[color note Changed] $before $commits ([color $mark $delta])$suffix" - } elseif {$verbose} { - m msg "[color note "No changes"]$suffix" - } else { - m msg "No changes$suffix" - } - - if {$primary} { - # check currently found forks against what is claimed by the system - set forks_prev [m repo fork-locations $repo] - - lassign [struct::set intersect3 $forks_prev $forks] same removed added - # previous - current => removed from previous - # current - previous => added over previous - - # Actions: - # - The removed forks are detached from the primary. - # We keep the repository. Activation state is unchanged - # - # - Unchanged forks are reactivated if they got disabled. - # - # - New forks are attempted to be added back - # This may actually reclaim a fork which was declaimed before. - # - # Note: Only these new forks have to be validated! - # Note: Tracking threshold is irrelevant here. - - foreach r $removed { - m msg " [color warning {Detaching lost}] [color note $r]" - m repo declaim [m repo id $r] - } - foreach r $same { - # m msg " Unchanged [color note $r], activating" - m repo enable [m repo id $r] - } - - AddForks $added $repo $vcs $vcode $name $project + set msets [UpdateSets $startcycle $nowcycle [$config @mirror-sets]] + debug.m/glue {msets = ($msets)} + + foreach mset $msets { + set mname [m mset name $mset] + m msg "Updating Mirror Set [color note $mname] ..." + + set stores [m mset stores $mset] + debug.m/glue {stores = ($stores)} + + foreach store $stores { + set vname [m store vcs-name $store] + if {$verbose} { + m msg " [color note $vname] store ... " + } else { + m msg* " $vname store ... " + } + + # TODO MAYBE: List the remotes we are pulling from ? + # => VCS layer, notification callback ... + set counts [m store update $store $nowcycle [clock seconds]] + lassign $counts before after forks remotes spent + debug.m/glue {update = ($counts)} + + set suffix "" + append suffix ", in " [color note [m format interval $spent]] + append suffix " (" [color note [lindex $remotes 0]] ")" + if {$forks ne {}} { + append suffix \n " Github: Currently tracking [color note [llength $forks]] additional forks" + } + + if {$before < 0} { + # Highlevel VCS url check failed for this store. + # Results in the stderr log. + lassign [m vcs caps $store] _ e + m msg "[color bad Fail]$suffix" + m msg $e + + } elseif {$before != $after} { + set delta [expr {$after - $before}] + if {$delta < 0} { + set mark bad + } else { + set mark note + set delta +$delta + } + m msg "[color note Changed] $before $after ([color $mark $delta])$suffix" + } elseif {$verbose} { + m msg "[color note "No changes"]$suffix" + } else { + m msg "No changes$suffix" + } } } } SiteRegen @@ -1174,47 +1058,38 @@ proc ::m::glue::cmd_updates {config} { debug.m/glue {[debug caller] | } package require m::store m db transaction { - - # m store updates XXX rework actually repos - # TODO: get status (stderr), show - store id set series {} foreach row [TruncH [m store updates] [expr {[$config @th]-1}]] { - - - if {[lindex $row 0] eq "..."} { lappend series [list ... {} {} {} {} {} {}] continue } - # store mname vcode changed updated created size active - # remote sizep commits commitp mins maxs lastn url origin - + # store mname vcode changed updated created size active remote + # sizep commits commitp mins maxs lastn dict with row {} if {$created eq "."} { lappend series [list - - - - - - -] continue } - + set changed [m format epoch $changed] set updated [m format epoch $updated] set created [m format epoch $created] set dsize [DeltaSize $size $sizep] set dcommit [DeltaCommit $commits $commitp] set lastn [LastTime $lastn] - if {$origin eq {}} { set url [color bg-cyan $url] } - - lappend series [list $url $vcode $dsize $dcommit $lastn $changed $updated $created] + lappend series [list $mname $vcode $dsize $dcommit $lastn $changed $updated $created] } } lassign [TruncW \ - {Project VCS Size Commits Time Changed Updated Created} \ - {1 0 0 0 0 0 0 0} \ + {{Mirror Set} VCS Size Commits Time Changed Updated Created} \ + {1 0 0 0 0 0 0 0} \ $series [$config @tw]] \ titles series m msg "Cycles: [m format epoch [m state start-of-previous-cycle]] ... [m format epoch [m state start-of-current-cycle]] ..." [table t $titles { foreach row $series { @@ -1224,44 +1099,39 @@ OK } proc ::m::glue::cmd_pending {config} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset package require m::state set tw [$config @tw] set th [$config @th] ; incr th -1 ;# Additional line before the table (counts). - set nrepo [m repo count] - set npending [m repo count-pending] - + set nmset [m mset count] + set npending [m mset count-pending] + m db transaction { set series {} set take [m state take] - - foreach {pname url origin nforks} [m repo pending] { - if {$origin eq {}} { set url [color bg-cyan $url] } - set row {} + foreach {mname numrepo} [m mset pending] { if {$take} { - lappend row * + lappend series [list * $mname $numrepo] incr take -1 } else { - lappend row {} + lappend series [list {} $mname $numrepo] } - lappend row $url $nforks $pname - lappend series $row } } lassign [TruncW \ - {{} Repository Forks Project} \ - {0 0 0 1} \ + {{} {Mirror Set} #Repositories} \ + {0 1 0} \ [TruncH $series $th] $tw] \ titles series - puts @[color note $npending]/$nrepo + puts @[color note $npending]/$nmset [table t $titles { foreach row $series { $t add {*}$row } }] show @@ -1268,28 +1138,31 @@ OK } proc ::m::glue::cmd_issues {config} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset package require m::repo package require m::rolodex package require m::store m db transaction { set series {} - foreach row [m store issues] { ;# XXX rework actually repo issues + foreach row [m store issues] { dict with row {} - # store mname vcode changed updated created size active remote rid url + # store mname vcode changed updated created size active remote set size [m format size $size] - if {$origin eq {}} { set url [color bg-cyan $url] } - - lappend series [list $rid $url $mname $vcode $size] - m rolodex push $rid + # urls of repos associated with the store + set urls [lindex [m store remotes $store] 0] + + foreach url $urls { + set rid [m repo id $url] + lappend series [list $rid $url $mname $vcode $size] + m rolodex push $rid + } } - m rolodex commit set n [llength $series] set table {} foreach row $series { @@ -1301,12 +1174,12 @@ if {$n == 0} { lappend tag @c } lappend table [list $tag {*}$row] } } lassign [TruncW \ - {Tag Repository Project VCS Size} \ - {0 0 1 0 0} \ + {Tag Repository Set VCS Size} \ + {0 1 3 0 0} \ $table [$config @tw]] \ titles series [table t $titles { foreach row $series { $t add {*}[C $row 1 note] ;# 1 => url @@ -1315,24 +1188,22 @@ OK } proc ::m::glue::cmd_disabled {config} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset package require m::repo package require m::rolodex package require m::store m db transaction { set series {} - foreach row [m store disabled] { # XXX REWORK actually repo state + foreach row [m store disabled] { dict with row {} - # store mname vcode changed updated created size active remote attend rid url origin + # store mname vcode changed updated created size active remote attend rid url set size [m format size $size] - if {$origin eq {}} { set url [color bg-cyan $url] } - lappend series [list $rid $url $mname $vcode $size] m rolodex push $rid } m rolodex commit set n [llength $series] @@ -1347,12 +1218,12 @@ if {$n == 0} { lappend tag @c } lappend table [list $tag {*}$row] } } lassign [TruncW \ - {Tag Repository Project VCS Size} \ - {0 0 1 0 0} \ + {Tag Repository Set VCS Size} \ + {0 1 3 0 0} \ $table [$config @tw]] \ titles series [table t $titles { foreach row $series { $t add {*}[C $row 1 note] ;# 1 => url @@ -1376,19 +1247,13 @@ # No search, show a chunk of the list as per options. if {[$config @repository set?]} { set repo [$config @repository] set ri [m repo get $repo] dict with ri {} - # -> url : repo url - # vcs : vcs id - # vcode : vcs code - # project: project id - # -> name : project name - # store : id of backing store for repo set first [list $name $url] debug.m/glue {from request: $first} - unset name url vcs vcode store ri project + unset name url vcs vcode store ri } else { set first [m state top] debug.m/glue {from state: $first} } set limit [$config @limit] @@ -1399,50 +1264,48 @@ lassign [m repo get-n $first $limit] next series debug.m/glue {next ($next)} m state top $next } - # series = list (dict (primary name url rid vcode sizekb active sizep commits commitp mins maxs lastn)) + # series = list (dict (mset url rid vcode sizekb active sizep commits commitp mins maxs lastn)) debug.m/glue {series ($series)} set n 0 foreach row $series { m rolodex push [dict get $row id] incr n } - + set idx -1 set table {} foreach row $series { dict with row {} - # primary name url id vcode sizekb active sizep commits commitp mins maxs lastn + # name url id vcode sizekb active sizep commits commitp mins maxs lastn incr idx #set url [color note $url] set ix [m rolodex id $id] set tag {} if {$ix ne {}} { lappend tag @$ix } if {$idx == ($n-2)} { lappend tag @p } if {$idx == ($n-1)} { lappend tag @c } set a [expr {$active ? "A" : "-"}] - if {$primary} { set url [color bg-cyan $url] } - set dsize [DeltaSize $sizekb $sizep] set dcommit [DeltaCommit $commits $commitp] set lastn [LastTime $lastn] - + lappend table [list $tag $a $url $name $vcode $dsize $dcommit $lastn] # ................. 0 1 2 3 4 5 6 7 } } # See also ShowCurrent # TODO: extend list with store times ? lassign [TruncW \ - {Tag {} Repository Project VCS Size Commits Time} \ - {0 0 0 1 0 -1 -1 0} \ + {Tag {} Repository Set VCS Size Commits Time} \ + {0 0 1 2 0 -1 -1 0} \ $table [$config @tw]] \ titles series [table t $titles { foreach row $series { $t add {*}[C $row 2 note] ;# 2 => url @@ -1506,11 +1369,11 @@ lappend series [list $id $when $url $vcode $desc $email $submitter] } } lassign [TruncW \ {{} When Url VCS Description Email Submitter} \ - {0 0 0 0 3 0 1} \ + {0 0 2 0 3 0 1} \ $series [$config @tw]] \ titles series [table t $titles { foreach row $series { $t add {*}[C $row 2 note] ;# 2 => url @@ -1529,11 +1392,11 @@ lappend series [list $url $reason] } } lassign [TruncW \ {Url Reason} \ - {1 0} \ + {1 0} \ $series [$config @tw]] \ titles series [table t $titles { foreach row $series { $t add {*}[C $row 0 note] ;# 0 => url @@ -1547,11 +1410,11 @@ package require m::submission package require m::repo # session id for cli, daily rollover, keyed to host and user set sid "cli.[expr {[clock second] % 86400}]/[info hostname]/$::tcl_platform(user)" - + m db transaction { set url [Url $config] set email [$config @email] set submitter [$config @submitter] set vcode [$config @vcs-code] @@ -1589,11 +1452,11 @@ OK } proc ::m::glue::cmd_accept {config} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset package require m::repo package require m::rolodex package require m::store package require m::submission package require m::mail::generator @@ -1744,25 +1607,20 @@ m db transaction { set message [ComeAroundMail [$config @tw] [m state start-of-current-cycle] [clock seconds]] } m msg $message } - OK + OK } proc ::m::glue::cmd_test_mail_config {config} { debug.m/glue {[debug caller] | } package require m::mailer package require m::mail::generator - try { - m mailer to [$config @destination] [m mail generator test] - } on error {e o} { - m msg [color bad $e] - exit - } - OK + m mailer to [$config @destination] [m mail generator test] + OK } proc ::m::glue::cmd_test_vt_repository {config} { debug.m/glue {[debug caller] | } package require m::repo @@ -1769,25 +1627,25 @@ set map [m repo known] [table/d t { foreach k [lsort -dict [dict keys $map]] { set v [dict get $map $k] - $t add $v $k + $t add $k $v } }] show OK } -proc ::m::glue::cmd_test_vt_project {config} { +proc ::m::glue::cmd_test_vt_mset {config} { debug.m/glue {[debug caller] | } - package require m::project + package require m::mset - set map [m project known] + set map [m mset known] [table/d t { foreach k [lsort -dict [dict keys $map]] { set v [dict get $map $k] - $t add $v $k + $t add $k $v } }] show OK } @@ -1797,11 +1655,11 @@ set map [m reply known] [table/d t { foreach k [lsort -dict [dict keys $map]] { set v [dict get $map $k] - $t add $v $k + $t add $k $v } }] show OK } @@ -1811,11 +1669,11 @@ set map [m submission known] [table/d t { foreach k [lsort -dict [dict keys $map]] { set v [dict get $map $k] - $t add $v $k + $t add $k $v } }] show OK } @@ -1885,20 +1743,18 @@ proc ::m::glue::ImportRead {label chan} { debug.m/glue {[debug caller] | } m msg "Reading [color note $label] ..." return [split [string trim [read $chan]] \n] # :: list (command) - # command :: list ('M' name) - old: 'M'irrorset - # | list ('P' name) - new: 'P'roject + # command :: list ('M' name) # | list ('R' vcode url) } proc ::m::glue::ImportVerify {commands} { debug.m/glue {} # commands :: list (command) - # command :: list ('M' name) - old: 'M'irrorset - # | list ('P' name) - new: 'P'roject + # command :: list ('M' name) # | list ('R' vcode url) m msg "Verifying ..." foreach {code name} [m vcs all] { @@ -1922,12 +1778,11 @@ # skip empty lines if {$command eq {}} continue lassign $command cmd a b switch -exact -- $cmd { - M - - P { + M { Ping " $command" # M name --> a = name, b = ((empty string)) if {[llength $command] != 2} { lappend msg "Line [format $lfmt $lno]: Bad syntax: $command" } @@ -2018,11 +1873,11 @@ lappend x $resolved lappend repo $vcs $resolved } M { if {![llength $repo]} { - m msg "Line $lno: [color warning Skip] empty project [color note $vcs]" + m msg "Line $lno: [color warning Skip] empty mirror set [color note $vcs]" set repo {} continue } foreach r $x { dict lappend seen $r $vcs } ;# vcs = mname unset x @@ -2071,28 +1926,28 @@ proc ::m::glue::Import1 {date mname repos} { debug.m/glue {[debug caller] | } # repos = list (vcode url ...) - m msg "Handling project [color note $mname] ..." + m msg "Handling [color note $mname] ..." if {[llength $repos] == 2} { lassign $repos vcode url - # The project contains only a single repository. + # The mirror set contains only a single repository. # We might be able to skip the merge - if {![m project has $mname]} { - # No project of the given name exists. + if {![m mset has $mname]} { + # No mirror set of the given name exists. # Create directly in final form. Skip merge. try { ImportMake1 $vcode $url $mname } trap {M VCS CHILD} {e o} { # Revert creation of mset and repository set repo [m rolodex top] set mset [m repo mset $repo] m repo remove $repo m rolodex drop $repo - m project remove $mset + m mset remove $mset m msg "[color bad {Unable to import}] [color note $mname]: $e" # No rethrow, the error in the child is not an error # for the whole command. Continue importing the remainder. } @@ -2099,27 +1954,27 @@ return } } # More than a single repository in this set, or the destination - # project exists. Merging is needed. And the untrusted nature + # mirror set exists. Merging is needed. And the untrusted nature # of the input means that we cannot be sure that merging is even # allowed. # Two phases: - # - Create the repositories. Each in its own project, like for - # `add`. Project names are of the form `import_`, plus a - # serial number. Comes with associated store. + # - Create the repositories. Each in its own mirror set, like for `add`. + # Set names are of the form `import_`, plus a serial number. + # Comes with associated store. # # - Go over the repositories again and merge them. If a # repository is rejected by the merge keep it separate. Retry # merging using the rejections. The number of retries is finite - # because each round finalizes at least one project and its + # because each round finalizes at least one mirror set and its # repositories of the finite supply. At the end of this phase we - # have one or more projects each with maximally merged - # repositories. Each finalized project is renamed to final form, - # based on the incoming mname and date. + # have one or more mirror sets each with maximally merged + # repositories. Each finalized mirror set is renamed to final + # form, based on the incoming mname and date. set serial 0 set r {} foreach {vcode url} $repos { try { @@ -2130,11 +1985,11 @@ # Revert creation of mset and repository set repo [m rolodex top] set mset [m repo mset $repo] m repo remove $repo m rolodex drop $repo - m project remove $mset + m mset remove $mset m msg "[color bad {Unable to use}] [color note $url]: $e\n" # No rethrow, the error in the child is not an error # for the whole command. Continue importing the remainder. } @@ -2145,13 +2000,13 @@ m msg "[color bad {Unable to import}] [color note $mname]: No repositories" return } set rename 1 - if {[m project has $mname]} { - # Targeted project exists. Make it first in the merge list. - set mset [m project id $mname] + if {[m mset has $mname]} { + # Targeted mirror set exists. Make it first in the merge list. + set mset [m mset id $mname] set repos [linsert $repos 0 dummy_vcode @$mname] dict set r @$mname [list dummy_vcs $mset dummy_store] set rename 0 } @@ -2184,12 +2039,12 @@ } if {![llength $unmatched]} break # Retry to merge the leftovers. Note, each iteration - # finalizes at least one project, ensuring termination of the - # loop. + # finalizes at least one mirror set, ensuring termination of + # the loop. set repos $unmatched set rename 1 } m rolodex commit @@ -2198,32 +2053,26 @@ proc ::m::glue::ImportMake1 {vcode url base} { debug.m/glue {[debug caller] | } set vcs [m vcs id $vcode] set tmpname [MakeName $base] - set project [m project add $tmpname] + set mset [m mset add $tmpname] set url [m vcs url-norm $vcode $url] - set vcode [m vcs code $vcs] - - m msg "> [string totitle $vcode] repository [color note $url]" - - # ----------------------- - # vcs project url - - lassign [AddStoreRepo $vcs $vcode $tmpname $url $project] repo forks - set store [m repo store $repo] - - # Forks are not processed. It is expected that forks are in the import file. - # The next update of the primary will link them to the origin. - set nforks [llength $forks] - if {$nforks} { - m msg " [color warning "Forks found ($nforks), ignored"]" - } - - m rolodex push $repo - - return [list $vcs $project $store] + + m rolodex push [m repo add $vcs $mset $url] + + m msg " Setting up the $vcode store for [color note $url] ..." + lassign [m store add $vcs $mset $tmpname $url] store spent forks + m msg " [color note Done] in [color note [m format interval $spent]]" + if {$forks ne {}} { + m msg " Github: Currently tracking [color note [llength $forks]] additional forks" + foreach f $forks { + m msg " - [color note $f]" + } + } + + return [list $vcs $mset $store] } proc ::m::glue::Add {config} { debug.m/glue {[debug caller] | } set url [Url $config] @@ -2239,122 +2088,41 @@ m msg "Attempting to add" m msg " Repository [color note $url]" m msg " Managed by [color note [m vcs name $vcs]]" m msg "New" - m msg " Project [color note $name]" + m msg " Mirror set [color note $name]" if {[m repo has $url]} { m::cmdr::error \ "Repository already present" \ HAVE_ALREADY REPOSITORY } - if 0 {if {[m project has $name]} { + if {[m mset has $name]} { m::cmdr::error \ "Name already present" \ HAVE_ALREADY NAME - }} - - # Relevant entities - # 1. repository - # 2. store - # 3. project - # - # As the repository references the other two these have to be initialized first. - # The creation of the repository caps the process. - # Issues roll database changes back. - - m msg "Actions ..." - - # ---------------------------------- Project - if {![m project has $name]} { - m msg* " Setting up the project ... " - set project [m project add $name] - OKx - } else { - m msg " Project is known" - } - - lassign [AddStoreRepo $vcs $vcode $name $url $project] repo forks - - # ---------------------------------- Forks + } + + # TODO MAYBE: stuff how much of this logic into `repo add` ? + + set mset [m mset add $name] + + m rolodex push [m repo add $vcs $mset $url] + + m msg " Setting up the $vcode store ..." + lassign [m store add $vcs $mset $name $url] _ spent forks + + m rolodex commit + m msg " [color note Done] in [color note [m format interval $spent]]" if {$forks ne {}} { - set threshold 22 - set nforks [llength $forks] - m msg "Found [color note $nforks] forks to track." - - if {![$config @track-forks] && ($nforks > $threshold)} { - m msg [color warning "Auto-tracking threshold of $threshold forks exceeded"] - m::cmdr::error "Please confirm using [color note --track-forks] that this many forks should be tracked." \ - TRACKING-THRESHOLD - } - - AddForks $forks $repo $vcs $vcode $name $project - } - - # ---------------------------------- - m msg "Setting new primary as current repository" - - m rolodex push $repo - m rolodex commit - - return -} - -proc ::m::glue::AddForks {forks repo vcs vcode name project} { - debug.m/glue {[debug caller] | } - - set nforks [llength $forks] - set format %-[string length $nforks]d - set pad [string repeat " " [expr {3+[string length $nforks]}]] - - foreach fork $forks { - incr k - m msg " [color cyan "([format $format $k])"] Fork [color note $fork] ... " - - if {[m repo has $fork]} { - m msg " $pad[color note "Already known, claiming it"]" - - # NOTE: The fork exists in a different project. We - # leave that part alone. The ERD allows that, a fork - # and its origin do not have to be in the same - # project. - - m repo claim $repo [m repo id $fork] - continue - } - - # Note: Fork urls have to be validated, same as the primary location. - if {![m url ok $fork xr]} { - m msg " [color warning {Not reachable}], might be private or gone" - m msg " Ignored" - continue - } - - AddStoreRepo $vcs $vcode $name $fork $project $repo - } - return -} - -proc ::m::glue::AddStoreRepo {vcs vcode name url project {origin {}}} { - debug.m/glue {[debug caller] | } - - # ---------------------------------- Store - m msg* " Setting up the $vcode store ... " - lassign [m store add $vcs $name $url] \ - store duration commits size forks - # id seconds int int list(url) - set x [expr {($commits == 1) ? "commit" : "commits"}] - m msg "[color good OK] in [color note [m format interval $duration]] ($commits $x, $size KB)" - - # ---------------------------------- Repository - - m msg* " Creating repository ... " - set repo [m repo add $vcs $project $store $url $duration $origin] - OKx - - return [list $repo $forks] + m msg " Github: Currently tracking [color note [llength $forks]] additional forks" + foreach f $forks { + m msg " - [color note $f]" + } + } + return } proc ::m::glue::InvalE {label key} { set v [m state $key] return [list [Inval $label {$v ne {}}] $v] @@ -2388,17 +2156,17 @@ set series {} foreach r $rolodex { incr id set rinfo [m repo get $r] dict with rinfo {} - # -> url : repo url - # vcs : vcs id - # -> vcode : vcs code - # project: project id - # -> name : project name - # store : id of backing store for repo - + # -> url : repo url + # vcs : vcs id + # vcode : vcs code + # mset : mirror set id + # name : mirror set name + # store : store id, of backing store for the repo + lappend tag @$id if {$id == ($n-2)} { lappend tag @p } if {$id == ($n-1)} { lappend tag @c } lappend series [list $tag $url $name $vcode] unset tag @@ -2406,11 +2174,11 @@ } } if {$n} { lassign [TruncW \ {{} {} {} {}} \ - {0 1 3 0} \ + {0 1 3 0} \ $series [$config @tw]] \ titles series [table t $titles { $t borders 0 $t headers 0 @@ -2426,20 +2194,15 @@ debug.m/glue {[debug caller] | } m msg [color good OK] return -code return } -proc ::m::glue::OKx {} { - debug.m/glue {[debug caller] | } - m msg [color good OK] -} - proc ::m::glue::MakeName {prefix} { debug.m/glue {[debug caller] | } - if {![m project has $prefix]} { return $prefix } + if {![m mset has $prefix]} { return $prefix } set n 1 - while {[m project has ${prefix}#$n]} { incr n } + while {[m mset has ${prefix}#$n]} { incr n } return "${prefix}#$n" } proc ::m::glue::ComeAroundMail {width current newcycle} { debug.m/glue {[debug caller] | } @@ -2448,11 +2211,11 @@ package require m::store package require m::format # Get updates and convert into a series for the table. A series we # can compress width-wise before formatting. - set series {} + set series {} foreach row [m store updates] { dict with row {} # store mname vcode changed updated created size active remote # sizep commits commitp mins maxs lastn if {$created eq "."} continue ;# ignore separations @@ -2463,51 +2226,51 @@ set changed [m format epoch/short $changed] set spent [LastTime $lastn] lappend series [list $changed $vcode $mname $spent $dsize $dcommit] } - + lappend mail "\[[info hostname]\] Cycle Report." lappend mail "Cycle\nFrom [clock format $current]\nTo [clock format $newcycle]" set n [llength $series] if {!$n} { lappend mail "Found no changes." } else { lappend mail "Found @/n/@ changed repositories:\n" lassign [TruncW \ - {Changed VCS Project Time Size Commits} \ - {0 0 1 0 0 0} \ + {Changed VCS {Mirror Set} Time Size Commits} \ + {0 0 1 0 0 0} \ $series \ $width] \ titles series - + table t $titles { foreach row $series { $t add {*}$row } } lappend mail [$t show return] $t destroy } - + MailFooter mail return [string map [list @/n/@ $n] [join $mail \n]] } proc ::m::glue::ComeAround {newcycle} { debug.m/glue {[debug caller] | } # Called when the update cycle comes around back to the start. - # Creates a mail reporting on all the projects which where + # Creates a mail reporting on all the mirror sets which where # changed in the previous cycle. set current [m state start-of-current-cycle] m state start-of-previous-cycle $current m state start-of-current-cycle $newcycle m msg "Cycle complete, coming around and starting new ..." - + set email [m state report-mail-destination] if {$email eq {}} { debug.m/glue {[debug caller] | Skipping report without destination} # Nobody to report to, skipping report @@ -2516,38 +2279,38 @@ } package require m::mail::generator package require m::mailer m msg "- [color good "Mailing report to"] [color note $email]" - + set comearound [ComeAroundMail [m state mail-width] $current $newcycle] m mailer to $email [m mail generator reply $comearound {}] m msg [color good OK] return } -proc ::m::glue::UpdateRepos {start now repos} { +proc ::m::glue::UpdateSets {start now msets} { debug.m/glue {[debug caller] | } - set n [llength $repos] + set n [llength $msets] if {$n} { # The note below is not shown when the user explicitly - # specifies the repositories to process. Because that is + # specifies the mirror sets to process. Because that is # outside any cycle. - return $repos + return $msets } set take [m state take] - set nrepo [m repo count] - set npending [m repo count-pending] + set nmset [m mset count] + set npending [m mset count-pending] - m msg "In cycle started on [m format epoch $start]: $take/$npending/$nrepo" + m msg "In cycle started on [m format epoch $start]: $take/$npending/$nmset" # No repositories specified. - # Pull repositories directly from pending - return [m repo take-pending $take \ + # Pull mirror sets directly from pending + return [m mset take-pending $take \ ::m::glue::ComeAround $now] } proc ::m::glue::Dedup {values} { debug.m/glue {[debug caller] | } @@ -2565,11 +2328,11 @@ proc ::m::glue::MergeFill {msets} { debug.m/glue {[debug caller] | } set n [llength $msets] if {!$n} { - # No project. Use the projects for current and previous + # No mirror sets. Use the mirror sets for current and previous # repository as merge target and source set target [m rolodex top] if {$target eq {}} { m::cmdr::error \ @@ -2584,12 +2347,12 @@ } lappend msets [m repo mset $target] [m repo mset $origin] return $msets } if {$n == 1} { - # A single project is the merge origin. Use the project of the - # current repository as merge target. + # A single mirror set is the merge origin. Use the mirror set + # of the current repository as merge target. set target [m rolodex top] if {$target eq {}} { m::cmdr::error \ "No current repository to indicate merge target" \ MISSING CURRENT @@ -2599,32 +2362,32 @@ return $msets } proc ::m::glue::Rename {mset newname} { debug.m/glue {[debug caller] | } - m project rename $mset $newname + m mset rename $mset $newname # TODO MAYBE: stuff cascading logic into `mset rename` ? - foreach store [m project stores $mset] { + foreach store [m mset stores $mset] { m store rename $store $newname } return } proc ::m::glue::Merge {target origin} { debug.m/glue {[debug caller] | } - # Target and origin are projects + # Target and origin are mirror sets. # # - Check that all the origin's repositories fit into the target. # This is done by checking the backing stores of the vcs in use # for compatibility. # # - When they do the stores are moved or merged, depending on # - presence of the associated vcs in the target. - set vcss [m project used-vcs $origin] + set vcss [m mset used-vcs $origin] # Check that all the origin's repositories fit into the target. foreach vcs $vcss { # Ignore vcs which are not yet used by the target # Assumed to be compatible. @@ -2649,12 +2412,12 @@ m store merge [m store id $vcs $target] $ostore } } # Move the repositories, drop the origin set, empty after the move - m repo move/project $origin $target - m project remove $origin + m repo move/mset $origin $target + m mset remove $origin return } proc ::m::glue::MailConfigShow {t {prefix {}}} { debug.m/glue {[debug caller] | } @@ -2792,12 +2555,12 @@ ## ## TODO column specific minimum widths ## TODO column specific shaving (currently all on the right, urls: left better, or middle) ## TODO column specific shave commands (ex: size rounding) -## TODO -## TODO +## TODO +## TODO ## proc ::m::glue::TruncW {titles weights series width} { # series :: list (row) # row :: list (0..n-1 str) @@ -2815,11 +2578,11 @@ debug.m/glue { terminal : $width } debug.m/glue { len(series) : [llength $series] } debug.m/glue { len(row) : $n } debug.m/glue { len(weights) : $k ($weights)} - + if {$n < $k} { set d [expr {$k - $n}] set weights [lreplace $weights end-$d end] # TODO: Check arith (off by x ?) } @@ -2831,21 +2594,21 @@ # Remove table border overhead to get usable terminal space set width [expr {$width - (3*$n+1)}] debug.m/glue { terminal' : $width (-[expr {3*$n+1}]) } debug.m/glue { weights' : ($weights)} - + # Compute series column widths (max len) for all columns. If the # total width is larger than width we have to shrink by weight. # Note: Min column width after shrinking is 6 (because we want to # show something for each column). If shrink by weight goes below # this min width bump up to it and remove the needed characters # from the weight 0 columns, but not below min width. set min 6 while {$k} { incr k -1 ; set wc($k) 0 } - + foreach row [linsert $series 0 $titles] { set col 0 foreach el $row { set n [string length $el] if {$n > $wc($col)} { set wc($col) $n } @@ -2852,53 +2615,47 @@ incr col } } debug.m/glue { col.widths = [W wc] } - + # max width over all rows. set fw 0 foreach {_ v} [array get wc] { incr fw $v } debug.m/glue { full = $fw vs terminal $width } - + # Nothing to do if the table fits already if {$fw <= $width} { return [list $titles $series] } # No fit, start shrinking. - + # Sum of weights to apportion set tw 0 foreach w $weights { if {$w <= 0} continue ; incr tw $w } # Number of characters over the allowed width. set over [expr {$fw - $width}] debug.m/glue { over : $over } - + # Shrink columns per weight set col 0 ; set removed 0 foreach w $weights { set c $col ; incr col - if {$w <= 0} { - debug.m/glue { ($col): skip } - continue - } + if {$w <= 0} continue set drop [format %.0f [expr {double($over * $w)/$tw}]] - - debug.m/glue { ($col): drop $drop int(($over*$w)/$tw)) } - incr removed $drop incr wc($c) -$drop } # --assert: removed >= over debug.m/glue { removed : $removed } - # Rounding may cause removed < over, leaving too many characters behind. + # Rounding may cause removed < over, leaving too much chracters behind. # Run a constant shaver, on the weighted cols set over [expr {$over - $removed}] if {$over} { ShaveWeighted wc $weights $over } - + debug.m/glue { col.widths = [W wc] } # If a weighted column has become to small, i.e. less than the # allowed min, in the above we bump it back to that width and will # shave these then from other columns. @@ -2911,19 +2668,19 @@ set wc($c) $min } debug.m/glue { under : $under } debug.m/glue { col.widths = [W wc] } - + # Claw back the added characters from other columns now, as much # as we can. We try to shrink other weighted columns first before # goign for the unweighted, i.e. strongly fixed ones. if {$under} { set under [ShaveWeighted wc $weights $under] } if {$under} { set under [ShaveUnweighted wc $weights $under] } debug.m/glue { col.widths = [W wc] } - + # At last, truncate the series elements to the chosen column # widths. Same for the titles. set new {} foreach row $series { set col 0 @@ -2945,11 +2702,11 @@ set el [string range $el 0 $wc($col)-1] } lappend newtitles $el incr col } - + return [list $newtitles $new] } proc ::m::glue::ShaveWeighted {wv weights shave} { set min 6 ;# todo place in common @@ -3001,24 +2758,27 @@ proc ::m::glue::StatsTime {mins maxs lastn} { set mins [expr {$mins < 0 ? "+Inf" : [m format interval $mins]}] set maxs [m format interval $maxs] - # See also ::m::repo::times, ::m::web::site::Store - append text "$mins ... $maxs" - set lastn [m format win $lastn] - set n [llength $lastn] + set lastn [split [string trim $lastn ,] ,] + set n [llength $lastn] + if {!$n} { return $text } - - set lastn [m format win-trim $lastn [m state store-window-size]] + + set maxn [m state store-window-size] + if {$n > $maxn} { + set over [expr {$n - $maxn}] + set lastn [lreplace $lastn 0 ${over}-1] + } set n [llength $lastn] set total [expr [join $lastn +]] set avg [m format interval [format %.0f [expr {double($total)/$n}]]] - - append text " \[avg $avg (over $n)]" + + append text " ($avg * $n)" return $text } proc ::m::glue::DeltaSizeFull {current previous} { append text [m format size $current] @@ -3066,11 +2826,11 @@ } else { # delta > 0 set color note set delta +$delta } - + append text $current " (" [color $color "$previous ($delta)"] ")" return $text } proc ::m::glue::DeltaCommit {current previous} { @@ -3082,12 +2842,12 @@ } else { # delta > 0 set color note set delta +$delta } - + append text $current " (" [color $color "$delta"] ")" return $text } # # ## ### ##### ######## ############# ###################### return Index: lib/db/db.tcl ================================================================== --- lib/db/db.tcl +++ lib/db/db.tcl @@ -2,16 +2,16 @@ # # ## ### ##### ######## ############# ##################### ## Mirror database - core access and schema # @@ Meta Begin # Package m::db 0 -# Meta author {Andreas Kupries} +# Meta author {Andreas Kupries} # Meta location https://core.tcl.tk/akupries/???? # Meta platform tcl -# Meta summary Main database access and schema +# Meta summary Main database access and schema # Meta description Main database access and schema -# Meta subject {database access} schema main +# Meta subject {database access} schema main # Meta require {Tcl 8.5-} # @@ Meta End package provide m::db 0 @@ -102,11 +102,11 @@ C name TEXT NOT NULL UNIQUE T name # - -- --- ----- -------- ------------- ## Mirror Set - Group of repositories holding the same logical set - ## of files/content. + ## of files/content. I+ C name INTEGER NOT NULL ^name UNIQUE T mirror_set @@ -130,36 +130,36 @@ U vcs mset T store # - -- --- ----- -------- ------------- ## Version Control System - Applications able to manage - ## repositories + ## repositories I+ C code TEXT NOT NULL UNIQUE ; # Short semi-internal tag C name TEXT NOT NULL UNIQUE ; # Human readable name T version_control_system >+ 'fossil' 'Fossil' - >+ 'git' 'Git' + >+ 'git' 'Git' ## State tables # - -- --- ----- -------- ------------- ## Client state - Named values C name TEXT NOT NULL PRIMARY KEY C value TEXT NOT NULL T state - > 'limit' '20' ;# Show this many repositories per `list` - > 'store' '~/.mirror/store' ;# Directory for the backend stores - > 'take' '5' ;# Check this many mirrors sets per `update` - > 'top' '' ;# State for `list`, next repository to show. + > 'limit' '20' ;# Show this many repositories per `list` + > 'store' '~/.mirror/store' ;# Directory for the backend stores + > 'take' '5' ;# Check this many mirrors sets per `update` + > 'top' '' ;# State for `list`, next repository to show. # - -- --- ----- -------- ------------- ## Mirror Set Pending - List of repositories waiting for an update - ## to process them + ## to process them C mset INTEGER NOT NULL ^mirror_set PRIMARY KEY T mset_pending # - -- --- ----- -------- ------------- @@ -166,22 +166,22 @@ ## Store Times - Per store the times of last update and change # # Notes on the recorded times: # # - Invariant: changed <= updated - # Because not every update causes a change. + # Because not every update causes a change. - C store INTEGER NOT NULL ^store PRIMARY KEY - C updated INTEGER NOT NULL - C changed INTEGER NOT NULL + C store INTEGER NOT NULL ^store PRIMARY KEY + C updated INTEGER NOT NULL + C changed INTEGER NOT NULL T store_times # - -- --- ----- -------- ------------- ## Rolodex - Short hand references to recently seen repositories I - C repository INTEGER NOT NULL ^repository UNIQUE + C repository INTEGER NOT NULL ^repository UNIQUE T rolodex # - -- --- ----- -------- ------------- return } @@ -203,29 +203,29 @@ # Added column `created` to `store_times` # # Notes on the recorded times: # # - Invariant: changed <= updated - # Because not every update causes a change. + # Because not every update causes a change. # # - Invariant: created <= changed - # Because a change can happen only after we have store + # Because a change can happen only after we have store # # - (created == changed) - # -> Never seen any change for this store. + # -> Never seen any change for this store. # # Overall # created <= changed <= updated D m::db # - -- --- ----- -------- ------------- - C store INTEGER NOT NULL ^store PRIMARY KEY - C created INTEGER NOT NULL - C updated INTEGER NOT NULL - C changed INTEGER NOT NULL + C store INTEGER NOT NULL ^store PRIMARY KEY + C created INTEGER NOT NULL + C updated INTEGER NOT NULL + C changed INTEGER NOT NULL < store_times store updated updated changed - # ^ use last update as fake creation + # ^ use last update as fake creation return } proc ::m::db::SETUP-201810121600 {} { @@ -235,26 +235,26 @@ set h {This is a semi-automated mail by @cmd@, on behalf of @sender@.} D m::db # - -- --- ----- -------- ------------- T^ state - # -- Debugging - > 'mail-debug' '0' ;# Bool. Activates low-level debugging in smtp/mime + # -- Debugging + > 'mail-debug' '0' ;# Bool. Activates low-level debugging in smtp/mime - # -- SMTP configuration + # -- SMTP configuration > 'mail-host' 'localhost' ;# Name of the mail-relay host to talk to - > 'mail-port' '25' ;# Port where the mail-relay host accepts SMTP + > 'mail-port' '25' ;# Port where the mail-relay host accepts SMTP > 'mail-user' 'undefined' ;# account accepted by the mail-relay host - > 'mail-pass' '' ;# and associated credentials - > 'mail-tls' '0' ;# Bool. Activates TLS to secure SMTP transactions + > 'mail-pass' '' ;# and associated credentials + > 'mail-tls' '0' ;# Bool. Activates TLS to secure SMTP transactions - # -- Mail content configuration + # -- Mail content configuration > 'mail-sender' 'undefined' ;# Email address to place into From/Sender headers - > 'mail-header' '$h' ;# Text to place before the generated content - > 'mail-footer' '' ;# Text to place after the generated content - # # Note: Template processing happens after the content - # # is assembled, i.e. affects header and footer. + > 'mail-header' '$h' ;# Text to place before the generated content + > 'mail-footer' '' ;# Text to place after the generated content + # # Note: Template processing happens after the content + # # is assembled, i.e. affects header and footer. return } proc ::m::db::SETUP-201810131603 {} { @@ -263,21 +263,21 @@ # (submission processing) D m::db # - -- --- ----- -------- ------------- I+ - C name TEXT NOT NULL UNIQUE - C automail INTEGER NOT NULL + C name TEXT NOT NULL UNIQUE + C automail INTEGER NOT NULL C isdefault INTEGER NOT NULL - C text TEXT NOT NULL + C text TEXT NOT NULL T reply set sm "It is spam" set om "It is off-topic here" set rm "It was intentionally removed before and we will not add it again" - >+ 'spam' 0 1 '$sm' ;# default reason + >+ 'spam' 0 1 '$sm' ;# default reason >+ 'offtopic' 1 0 '$om' >+ 'removed' 1 0 '$rm' return } @@ -289,14 +289,14 @@ # - rejected submissions (for easy auto-rejection on replication) D m::db # - -- --- ----- -------- ------------- I+ - C url TEXT NOT NULL UNIQUE - C email TEXT NOT NULL + C url TEXT NOT NULL UNIQUE + C email TEXT NOT NULL C submitter TEXT - C sdate INTEGER NOT NULL + C sdate INTEGER NOT NULL T submission X sdate I+ C url TEXT NOT NULL UNIQUE @@ -311,12 +311,12 @@ # Added column `size_kb` for store size to `store`. D m::db # - -- --- ----- -------- ------------- I+ - C vcs INTEGER NOT NULL ^version_control_system - C mset INTEGER NOT NULL ^mirror_set + C vcs INTEGER NOT NULL ^version_control_system + C mset INTEGER NOT NULL ^mirror_set C size_kb INTEGER NOT NULL U vcs mset < store id vcs mset '0' package require m::store @@ -329,17 +329,17 @@ # Added site configuration to the general state table D m::db # - -- --- ----- -------- ------------- T^ state - # -- Debugging - > 'site-active' '0' ;# Site status (active or not) + # -- Debugging + > 'site-active' '0' ;# Site status (active or not) > 'site-store' '~/.mirror/site' ;# Location where website is generated - > 'site-mgr-mail' '' ;# Mail address of the site manager - > 'site-mgr-name' '' ;# Name of the site manager - > 'site-title' 'Mirror' ;# Name of the site - > 'site-url' '' ;# The url the site will be published at + > 'site-mgr-mail' '' ;# Mail address of the site manager + > 'site-mgr-name' '' ;# Name of the site manager + > 'site-title' 'Mirror' ;# Name of the site + > 'site-url' '' ;# The url the site will be published at return } proc ::m::db::SETUP-201811162301 {} { @@ -347,11 +347,11 @@ # Added more site configuration to the general state table D m::db # - -- --- ----- -------- ------------- T^ state - # -- Debugging + # -- Debugging > 'site-logo' '' ;# Path or url to the site logo. return } @@ -361,13 +361,13 @@ # Default: yes. D m::db # - -- --- ----- -------- ------------- I+ - C url TEXT NOT NULL UNIQUE - C vcs INTEGER NOT NULL ^version_control_system - C mset INTEGER NOT NULL ^mirror_set + C url TEXT NOT NULL UNIQUE + C vcs INTEGER NOT NULL ^version_control_system + C mset INTEGER NOT NULL ^mirror_set C active INTEGER NOT NULL < repository id url vcs mset '1' X vcs mset return @@ -393,16 +393,16 @@ # enabling fixing of description, vcode. Added index instead. D m::db # - -- --- ----- -------- ------------- I+ - C url TEXT NOT NULL - C vcode TEXT + C url TEXT NOT NULL + C vcode TEXT C description TEXT - C email TEXT NOT NULL - C submitter TEXT - C sdate INTEGER NOT NULL + C email TEXT NOT NULL + C submitter TEXT + C sdate INTEGER NOT NULL < submission id url '' '' email submitter sdate X sdate X url return @@ -417,17 +417,17 @@ # submissions of other sessions. D m::db # - -- --- ----- -------- ------------- I+ - C session TEXT NOT NULL - C url TEXT NOT NULL - C vcode TEXT + C session TEXT NOT NULL + C url TEXT NOT NULL + C vcode TEXT C description TEXT - C email TEXT NOT NULL - C submitter TEXT - C sdate INTEGER NOT NULL + C email TEXT NOT NULL + C submitter TEXT + C sdate INTEGER NOT NULL U session url < submission id ':lock:' url vcode description email submitter sdate X sdate X url @@ -441,12 +441,12 @@ # for deletion from the CGI site database on next sync. Note that # we only need the key information, i.e. url + session id. D m::db # - -- --- ----- -------- ------------- - C session TEXT NOT NULL - C url TEXT NOT NULL + C session TEXT NOT NULL + C url TEXT NOT NULL U session url T submission_handled return } @@ -457,15 +457,15 @@ # Column records presence of issues in the # last update for the store. D m::db # - -- --- ----- -------- ------------- - C store INTEGER NOT NULL ^store PRIMARY KEY - C created INTEGER NOT NULL - C updated INTEGER NOT NULL - C changed INTEGER NOT NULL - C attend INTEGER NOT NULL + C store INTEGER NOT NULL ^store PRIMARY KEY + C created INTEGER NOT NULL + C updated INTEGER NOT NULL + C changed INTEGER NOT NULL + C attend INTEGER NOT NULL < store_times store updated updated changed '0' # fake "no issues" during creation ...........^ package require m::store m::store::InitialIssues @@ -479,32 +479,32 @@ # track size changes (KB, #revisions) and time statistics for # updates. D m::db # - -- --- ----- -------- ------------- - C store INTEGER NOT NULL ^store PRIMARY KEY - C created INTEGER NOT NULL - C updated INTEGER NOT NULL - C changed INTEGER NOT NULL - C attend INTEGER NOT NULL + C store INTEGER NOT NULL ^store PRIMARY KEY + C created INTEGER NOT NULL + C updated INTEGER NOT NULL + C changed INTEGER NOT NULL + C attend INTEGER NOT NULL C min_seconds INTEGER NOT NULL ;# overall minimum time spent on update C max_seconds INTEGER NOT NULL ;# overall maximum time spent on update C window_seconds STRING NOT NULL ;# time spent on last N updates (list of int) < store_times store updated updated changed attend '-1' '0' '' # Note: A min_seconds value of -1 represents +Infinity. - + T^ state > 'store-window-size' '10' ;# Window size for `store.window_seconds` I+ - C vcs INTEGER NOT NULL ^version_control_system - C mset INTEGER NOT NULL ^mirror_set - C size_kb INTEGER NOT NULL - C size_previous INTEGER NOT NULL - C commits_current INTEGER NOT NULL - C commits_previous INTEGER NOT NULL + C vcs INTEGER NOT NULL ^version_control_system + C mset INTEGER NOT NULL ^mirror_set + C size_kb INTEGER NOT NULL + C size_previous INTEGER NOT NULL + C commits_current INTEGER NOT NULL + C commits_previous INTEGER NOT NULL U vcs mset < store id vcs mset size_kb size_kb '0' '0' package require m::store m::store::InitialCommits @@ -520,12 +520,12 @@ # git repository, the information in the table is derived. Used for # easier access to statistics (size x forks ~?~ update time). D m::db # - -- --- ----- -------- ------------- - C store INTEGER NOT NULL ^store PRIMARY KEY - C nforks INTEGER NOT NULL + C store INTEGER NOT NULL ^store PRIMARY KEY + C nforks INTEGER NOT NULL T store_github_forks package require m::store m::store::InitialForks return @@ -539,11 +539,11 @@ # - -- --- ----- -------- ------------- T^ state > 'start-of-current-cycle' '[clock seconds]' ;# As epoch # Fake start for now, self corrects when it comes around. - + return } proc ::m::db::SETUP-201901252301 {} { debug.m/db {} @@ -567,11 +567,11 @@ T^ state > 'start-of-previous-cycle' '[clock seconds]' ;# As epoch # Fake start for now, self corrects when it comes around # next time. - + return } proc ::m::db::SETUP-201902052301 {} { debug.m/db {} @@ -590,12 +590,12 @@ # Extended mail configuration, width to use for tables. D m::db # - -- --- ----- -------- ------------- T^ state - # -- Mail content configuration - > 'mail-width' '200' ;# Width of tables placed into content + # -- Mail content configuration + > 'mail-width' '200' ;# Width of tables placed into content return } proc ::m::db::SETUP-201910032120 {} { @@ -612,154 +612,15 @@ C name TEXT NOT NULL UNIQUE <= mirror_set { SELECT M.id , N.name - FROM @@ M + FROM @@ M , name N WHERE M.name = N.id } - / name - - return -} - -proc ::m::db::SETUP-202207020000 {} { - debug.m/db {} - - D m::db - # - -- --- ----- -------- ------------- - - # Move to schema V3 - # - The main change is the explicit representation and handling of - # forks. - # - A number of small changes renaming and moving various tables - # and fields. - - # - -- --- ----- -------- ------------- - # Drop `mset_pending`, and replace with proper `repo_pending`. - # - ## Repository Pending - List of repositories waiting for an update - ## to process them - - C repository INTEGER NOT NULL ^repository PRIMARY KEY - T repo_pending - - # - -- --- ----- -------- ------------- - ## Rename `mirror_set` to `project` as a more suitable name. - - R "ALTER TABLE mirror_set RENAME TO project" - - # - -- --- ----- -------- ------------- - ## Redo the repositories - # - ## - Rename `mset` to `project - ## - Add store_times.*_seconds - ## - Add store reference - ## - Add checked stamp - ## - Drop - # - ## ATTENTION -- This is done before updating the store schema - ## because the code to find and link the store requires the mset - ## reference to be dropped. - - I+ - C url TEXT NOT NULL UNIQUE - C project INTEGER NOT NULL ^project - C vcs INTEGER NOT NULL ^version_control_system - C store INTEGER NOT NULL ^store - C fork_origin INTEGER ^repository - C is_active INTEGER NOT NULL - C has_issues INTEGER NOT NULL - C checked INTEGER NOT NULL ;# epoch - C min_duration INTEGER NOT NULL ;# overall minimum time spent on update - C max_duration INTEGER NOT NULL ;# overall maximum time spent on update - C window_duration STRING NOT NULL ;# time spent on last N updates (list of int) - < repository id url mset vcs -1 NULL active 0 0 0 0 '' - # url proj vcs store fork act issu chk min max win - - # Store linkage and store_times related information needs code. - foreach {repo mset vcs url} [R { - SELECT id - , project - , vcs - , url - FROM repository - }] { - # Locate store for repository - set store [R [string map [list :mset $mset :vcs $vcs] { - SELECT id - FROM store - WHERE mset = :mset - AND vcs = :vcs - }]] - - lassign [R [string map [list :store $store] { - SELECT mset, vcs - FROM store - WHERE id = :store - }]] msets vcss - - #puts stderr "XXX repo = $url/$mset/$vcs => S$store/$msets/$vcss" - - # Get time information - lassign [R [string map [list :store $store] { - SELECT min_seconds - , max_seconds - , window_seconds - FROM store_times - WHERE store = :store - }]] min max win - - # update repository with store and times - R [string map [list :id $repo :min $min :max $max :win $win :store $store] { - UPDATE repository - SET store = :store - , min_duration = :min - , max_duration = :max - , window_duration = ':win' - WHERE id = :id - }] - } - - # - -- --- ----- -------- ------------- - ## Redo the stores - ## - Drop project reference, add various store_times fields. - - I+ - C vcs INTEGER NOT NULL ^version_control_system - C size_kb INTEGER NOT NULL - C size_previous INTEGER NOT NULL - C commits_current INTEGER NOT NULL - C commits_previous INTEGER NOT NULL - C created INTEGER NOT NULL - C updated INTEGER NOT NULL - C changed INTEGER NOT NULL - <= store { - SELECT S.id - , S.vcs - , S.size_kb - , S.size_previous - , S.commits_current - , S.commits_previous - , T.created - , T.updated - , T.changed - FROM @@ S - , store_times T - WHERE T.store = S.id - } - - # - -- --- ----- -------- ------------- - ## Drop various tables which became superfluous due to the - ## preceding changes. - - / mset_pending - / store_github_forks - / store_times - return } # # ## ### ##### ######## ############# ##################### return Index: lib/db/site.tcl ================================================================== --- lib/db/site.tcl +++ lib/db/site.tcl @@ -249,43 +249,10 @@ T vcs # No fixed values here. Copy from main table # `version_control_system` on sync. - return -} - -proc ::m::site::SETUP-202207020000 {} { - debug.m/db {} - - D m::site - # - -- --- ----- -------- ------------- - - # Move to schema V3 - # - It is now possible to have multiple stores of the same - # kind for a project. Due to forks of a github repository - # being explicit, with separate stores. - # - # => Drop constraint UNIQUE(name, vcode) - - I+ - C name TEXT NOT NULL - C vcode TEXT NOT NULL - C page TEXT NOT NULL UNIQUE - C remotes TEXT NOT NULL - C status TEXT NOT NULL -- icon name - C size_kb INTEGER NOT NULL - C changed INTEGER NOT NULL - C updated INTEGER NOT NULL - C created INTEGER NOT NULL - - < store_index \ - id name vcode page remotes status size_kb changed updated created - - X name - X remotes - return } # # ## ### ##### ######## ############# ##################### return ADDED lib/logic/mset.tcl Index: lib/logic/mset.tcl ================================================================== --- /dev/null +++ lib/logic/mset.tcl @@ -0,0 +1,341 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ###################### + +# @@ Meta Begin +# Package m::mset 0 +# Meta author {Andreas Kupries} +# Meta category ? +# Meta description ? +# Meta location https://core.tcl-lang.org/akupries/m +# Meta platform tcl +# Meta require ? +# Meta subject ? +# Meta summary ? +# @@ Meta End + +# # ## ### ##### ######## ############# ###################### + +package require Tcl 8.5 +package require m::db +package require m::repo +package require m::rolodex +package require debug +package require debug::caller + +# # ## ### ##### ######## ############# ###################### + +namespace eval ::m { + namespace export mset + namespace ensemble create +} +namespace eval ::m::mset { + namespace export \ + all add remove rename has \ + name used-vcs has-vcs size \ + stores take-pending pending known \ + repos spec id count count-pending + namespace ensemble create +} + +# # ## ### ##### ######## ############# ###################### + +debug level m/mset +debug prefix m/mset {[debug caller] | } + +# # ## ### ##### ######## ############# ###################### + +proc ::m::mset::spec {} { + debug.m/mset {} + + set lines {} + foreach {mset mname} [all] { + foreach repo [repos $mset] { + set ri [m repo get $repo] + dict with ri {} + # -> url : repo url + # vcs : vcs id + # -> vcode : vcs code + # mset : mirror set id + # name : mirror set name + # store : store id, of backing store for + lappend lines [list R $vcode $url] + } + lappend lines [list M $mname] + } + return [join $lines \n] +} + +proc ::m::mset::known {} { + debug.m/mset {} + + # Return map to mirror set ids. + # Keys: + # - rolodex ids (+ '@current', '@', '@prev') + # - repository urls + # - mirror set names + + set map {} + set mid {} + + # Repository and mirror set information in one trip. + m db eval { + SELECT M.id AS id + , M.name AS name + , R.id AS rid + , R.url AS url + FROM repository R + , mirror_set M + WHERE R.mset = M.id + } { + dict set mid $rid $id + dict set map [string tolower $url] $id + dict set map [string tolower $name] $id + } + + # See also m::repo::known + # Note, different ids! mset, not repo. + set c {} + set p {} + set id -1 + foreach r [m rolodex get] { + set p $c ; set c $r ; incr id + dict set map "@$id" [dict get $mid $r] + } + if {$p ne {}} { + set p [dict get $mid $p] + dict set map @prev $p + dict set map @-1 $p + } + if {$c ne {}} { + set c [dict get $mid $c] + dict set map @current $c + dict set map @ $c + } + + return $map +} + +proc ::m::mset::all {} { + debug.m/mset {} + return [m db eval { + SELECT id + , name + FROM mirror_set + ORDER BY name ASC + }] +} + +proc ::m::mset::id {name} { + debug.m/mset {} + return [m db onecolumn { + SELECT id + FROM mirror_set + WHERE name = :name + }] +} + +proc ::m::mset::count {} { + debug.m/mset {} + return [m db onecolumn { + SELECT count (*) + FROM mirror_set + }] +} + +proc ::m::mset::count-pending {} { + debug.m/mset {} + return [m db onecolumn { + SELECT count (*) + FROM mset_pending + }] +} + +proc ::m::mset::add {name} { + debug.m/mset {} + + m db eval { + INSERT + INTO mirror_set + VALUES ( NULL, :name ) + } + + set mset [m db last_insert_rowid] + + m db eval { + INSERT + INTO mset_pending + VALUES ( :mset ) + } + + return $mset +} + +proc ::m::mset::remove {mset} { + debug.m/mset {} + + # TODO FILL mset/remove -- Verify that the mset has no references + # anymore, from neither repositories nor stores + + return [m db eval { + DELETE + FROM mirror_set + WHERE id = :mset + ; + DELETE + FROM mset_pending + WHERE mset = :mset + }] +} + +proc ::m::mset::rename {mset name} { + debug.m/mset {} + m db eval { + UPDATE mirror_set + SET name = :name + WHERE id = :mset + } + return +} + +proc ::m::mset::has {name} { + debug.m/mset {} + return [m db onecolumn { + SELECT count (*) + FROM mirror_set + WHERE name = :name + }] +} + +proc ::m::mset::stores {mset} { + debug.m/mset {} + return [m db eval { + SELECT id + FROM store + WHERE mset = :mset + }] +} + +proc ::m::mset::repos {mset} { + debug.m/mset {} + return [m db eval { + SELECT id + FROM repository + WHERE mset = :mset + }] +} + +proc ::m::mset::used-vcs {mset} { + debug.m/mset {} + return [m db eval { + SELECT DISTINCT vcs + FROM repository + WHERE mset = :mset + }] +} + +proc ::m::mset::size {mset} { + debug.m/mset {} + return [m db onecolumn { + SELECT count (*) + FROM repository + WHERE mset = :mset + }] +} + +proc ::m::mset::has-vcs {mset vcs} { + debug.m/mset {} + return [m db onecolumn { + SELECT count (*) + FROM repository + WHERE mset = :mset + AND vcs = :vcs + }] +} + +proc ::m::mset::name {mset} { + debug.m/mset {} + return [m db onecolumn { + SELECT name + FROM mirror_set + WHERE id = :mset + }] +} + +proc ::m::mset::pending {} { + debug.m/mset {} + return [m db eval { + SELECT name + , (SELECT count (*) + FROM repository R + WHERE R.mset = P.mset + AND R.active) AS arc + FROM mset_pending P + , mirror_set M + WHERE P.mset = M.id + AND arc > 0 + ORDER BY P.ROWID + }] +} + +proc ::m::mset::take-pending {take args} { + debug.m/mset {} + + # Ask for one more than actually request. This will cause a + # short-read (with refill) not only when the table contains less + # than take elements, but also when it contains exactly that many. + # If the read is not short we know that at least one element is + # left. + incr take + + set taken [m db eval { + SELECT P.mset + FROM mset_pending P + WHERE (SELECT count (*) + FROM repository R + WHERE R.mset = P.mset + AND R.active) > 0 + LIMIT :take + }] + if {[llength $taken] < $take} { + # Short read. Clear taken (fast), and refill for next + # invokation. + m db eval { + DELETE + FROM mset_pending + ; + INSERT + INTO mset_pending + SELECT id + FROM mirror_set + } + + if {[llength $args]} { + # Invoke callback to report that the overall cycle just + # came around and started anew. + try { + uplevel 1 $args + } on error {e o} { + # TODO -- Report (internal) error, but do not crash. + } + } + } else { + # Full read. Clear taken, the slow way. Drop the unwanted + # sentinel element from the end of the result. + set taken [lreplace [K $taken [unset taken]] end end] + m db eval [string map [list %% [join $taken ,]] { + DELETE + FROM mset_pending + WHERE mset in (%%) + }] + } + + return $taken +} + +# # ## ### ##### ######## ############# ###################### + +proc ::m::mset::K {x y} { set x } + +# # ## ### ##### ######## ############# ###################### +package provide m::mset 0 +return DELETED lib/logic/project.tcl Index: lib/logic/project.tcl ================================================================== --- lib/logic/project.tcl +++ /dev/null @@ -1,242 +0,0 @@ -## -*- tcl -*- -# # ## ### ##### ######## ############# ###################### - -# @@ Meta Begin -# Package m::project 0 -# Meta author {Andreas Kupries} -# Meta category ? -# Meta description ? -# Meta location https://core.tcl-lang.org/akupries/m -# Meta platform tcl -# Meta require ? -# Meta subject ? -# Meta summary ? -# @@ Meta End - -# # ## ### ##### ######## ############# ###################### - -package require Tcl 8.5 -package require m::db -package require m::repo -package require m::rolodex -package require debug -package require debug::caller - -# # ## ### ##### ######## ############# ###################### - -namespace eval ::m { - namespace export project - namespace ensemble create -} -namespace eval ::m::project { - namespace export \ - all add remove rename has \ - name used-vcs has-vcs size \ - stores known spec id count - namespace ensemble create -} - -# # ## ### ##### ######## ############# ###################### - -debug level m/project -debug prefix m/project {[debug caller] | } - -# # ## ### ##### ######## ############# ###################### - -proc ::m::project::spec {} { - debug.m/project {} - - set lines {} - foreach {project pname} [all] { - foreach repo [m repo for $project] { - set ri [m repo get $repo] - dict with ri {} - # -> url : repo url - # vcs : vcs id - # -> vcode : vcs code - # project: project id - # name : project name - # store : id of backing store for repo - lappend lines [list R $vcode $url] - } - lappend lines [list P $pname] - } - return [join $lines \n] -} - -proc ::m::project::known {} { - debug.m/project {} - - # Return map to project ids. - # Keys: - # - rolodex ids (+ '@current', '@', '@prev') - # - repository urls - # - project names - - set map {} - set mid {} - - # Repository and project information in one trip. - m db eval { - SELECT P.id AS id - , P.name AS name - , R.id AS rid - , R.url AS url - FROM repository R - , project P - WHERE R.project = P.id - } { - dict set mid $rid $id - dict set map [string tolower $url] $id - dict set map [string tolower $name] $id - } - - # See also m::repo::known - # Note, different ids! project, not repo. - set c {} - set p {} - set id -1 - foreach r [m rolodex get] { - set p $c ; set c $r ; incr id - dict set map "@$id" [dict get $mid $r] - } - if {$p ne {}} { - set p [dict get $mid $p] - dict set map @prev $p - dict set map @-1 $p - } - if {$c ne {}} { - set c [dict get $mid $c] - dict set map @current $c - dict set map @ $c - } - - return $map -} - -proc ::m::project::all {} { - debug.m/project {} - return [m db eval { - SELECT id - , name - FROM project - ORDER BY name ASC - }] -} - -proc ::m::project::id {name} { - debug.m/project {} - return [m db onecolumn { - SELECT id - FROM project - WHERE name = :name - }] -} - -proc ::m::project::count {} { - debug.m/project {} - return [m db onecolumn { - SELECT count (*) - FROM project - }] -} - -proc ::m::project::add {name} { - debug.m/project {} - - m db eval { - INSERT - INTO project - VALUES ( NULL, :name ) - } - - return [m db last_insert_rowid] -} - -proc ::m::project::remove {project} { - debug.m/project {} - - # TODO FILL project/remove -- Verify that the project has no references - # anymore, from neither repositories nor stores - - return [m db eval { - DELETE - FROM project - WHERE id = :project - }] -} - -proc ::m::project::rename {project name} { - debug.m/project {} - m db eval { - UPDATE project - SET name = :name - WHERE id = :project - } - return -} - -proc ::m::project::has {name} { - debug.m/project {} - return [m db onecolumn { - SELECT count (*) - FROM project - WHERE name = :name - }] -} - -proc ::m::project::stores {project} { - debug.m/project {} - return [m db eval { - SELECT S.id - FROM store S - , repository R - WHERE S.id = R.store - AND R.project = :project - }] -} - -proc ::m::project::used-vcs {project} { - debug.m/project {} - return [m db eval { - SELECT DISTINCT vcs - FROM repository - WHERE project = :project - }] -} - -proc ::m::project::size {project} { - debug.m/project {} - return [m db onecolumn { - SELECT count (*) - FROM repository - WHERE project = :project - }] -} - -proc ::m::project::has-vcs {project vcs} { - debug.m/project {} - return [m db onecolumn { - SELECT count (*) - FROM repository - WHERE project = :project - AND vcs = :vcs - }] -} - -proc ::m::project::name {project} { - debug.m/project {} - return [m db onecolumn { - SELECT name - FROM project - WHERE id = :project - }] -} - -# # ## ### ##### ######## ############# ###################### - -proc ::m::project::K {x y} { set x } - -# # ## ### ##### ######## ############# ###################### -package provide m::project 0 -return Index: lib/logic/repo.tcl ================================================================== --- lib/logic/repo.tcl +++ lib/logic/repo.tcl @@ -22,11 +22,10 @@ # # ## ### ##### ######## ############# ###################### package require Tcl 8.5 package require m::state package require m::rolodex -package require m::format package require debug package require debug::caller # # ## ### ##### ######## ############# ###################### @@ -34,14 +33,12 @@ namespace export repo namespace ensemble create } namespace eval ::m::repo { namespace export \ - add remove enable move/project move/1 has get name \ - store known get-n for forks project search id count \ - claim count-pending add-pending drop-pending pending \ - take-pending declaim times fork-locations + add remove enable move/mset move/1 has get name \ + known get-n mset search id count namespace ensemble create } # # ## ### ##### ######## ############# ###################### @@ -64,12 +61,12 @@ FROM repository } { dict set map [string tolower $url] $id } - # See also m::project::known - # Note, different ids! repository, not project + # See also m::mset::known + # Note, different ids! repo, not mset set c {} set p {} set id -1 foreach r [m rolodex get] { set p $c ; set c $r ; incr id @@ -87,17 +84,17 @@ return $map } proc ::m::repo::name {repo} { debug.m/repo {} - # TODO MAYBE - in-memory cache of mapping repo -> name + # TODO MAYBE - repo name - cache? return [m db onecolumn { - SELECT R.url || ' (: ' || P.name || ')' + SELECT R.url || ' (: ' || M.name || ')' FROM repository R - , project P + , mirror_set M WHERE R.id = :repo - AND P.id = R.project + AND M.id = R.mset }] } proc ::m::repo::has {url} { debug.m/repo {} @@ -123,184 +120,61 @@ SELECT count (*) FROM repository }] } -proc ::m::repo::times {repo duration now issues} { - debug.m/repo {} - # Read current state - - m db eval { - SELECT min_duration AS mins - , max_duration AS maxs - , window_duration AS window - FROM repository - WHERE id = :repo - } {} - - debug.m/repo {lastr = ($window)} - - # See also ::m::glue::StatsTime, ::m::web::site::Store - - set window [m format win $window] - - debug.m/repo {mins = $mins} - debug.m/repo {maxs = $maxs} - debug.m/repo {lastn = ($window)} - - # Modify based on the incoming duration. - - if {($mins eq {}) || ($mins < 0) || ($duration < $mins)} { set mins $duration } - if { $duration > $maxs} { set maxs $duration } - - lappend window $duration - set window [m format win-trim $window [m state store-window-size]] - debug.m/repo {last' = ($window)} - - set window ,[join $window ,], - debug.m/repo {last. = ($window)} - - # And write the results back - - m db eval { - UPDATE repository - SET min_duration = :mins - , max_duration = :maxs - , window_duration = :window - , checked = :now - , has_issues = :issues - WHERE id = :repo - } - return -} - -proc ::m::repo::add {vcs project store url duration {origin {}}} { - debug.m/repo {} - - set now [clock seconds] - - if {$origin ne {}} { - m db eval { - INSERT - INTO repository - VALUES ( NULL -- id - , :url -- url - , :project -- project - , :vcs -- vcs - , :store -- store - , :origin -- fork_origin - , 1 -- is_active - , 0 -- has_issues - , :now -- checked - , :duration -- min_duration - , :duration -- max_duration - , :duration -- window_duration - ) - } - } else { - m db eval { - INSERT - INTO repository - VALUES ( NULL -- id - , :url -- url - , :project -- project - , :vcs -- vcs - , :store -- store - , NULL -- fork_origin - , 1 -- is_active - , 0 -- has_issues - , :now -- checked - , :duration -- min_duration - , :duration -- max_duration - , :duration -- window_duration - ) - } +proc ::m::repo::add {vcs mset url} { + debug.m/repo {} + + m db eval { + INSERT + INTO repository + VALUES ( NULL, :url, :vcs, :mset, 1 ) } return [m db last_insert_rowid] } -proc ::m::repo::for {project} { - debug.m/project {} - return [m db eval { - SELECT id - FROM repository - WHERE project = :project - }] -} - -proc ::m::repo::forks {repo} { - debug.m/project {} - return [m db eval { - SELECT id - FROM repository - WHERE fork_origin = :repo - }] -} - -proc ::m::repo::fork-locations {repo} { - debug.m/project {} - return [m db eval { - SELECT url - FROM repository - WHERE fork_origin = :repo - }] -} - -proc ::m::repo::project {repo} { - debug.m/repo {} - set project [m db onecolumn { - SELECT project - FROM repository - WHERE id = :repo - }] - debug.m/repo {=> ($project)} - return $project -} - -proc ::m::repo::store {repo} { - debug.m/project {} - return [m db eval { - SELECT store - FROM repository - WHERE id = :repo - }] +proc ::m::repo::mset {repo} { + debug.m/repo {} + set mset [m db onecolumn { + SELECT mset + FROM repository + WHERE id = :repo + }] + debug.m/repo {=> ($mset)} + return $mset } proc ::m::repo::get {repo} { debug.m/repo {} # Given a repository (by id) follow all the links in the database # to retrieve everything related to it # - repository (url) - # - project (id, and name) + # - mirror set (id, and name) # - vcs (id, and code) # - store (id) # - active set details [m db eval { SELECT 'url' , R.url - , 'active' , R.is_active - , 'issues' , R.has_issues + , 'active' , R.active , 'vcs' , R.vcs , 'vcode' , V.code - , 'project', R.project - , 'name' , P.name + , 'mset' , R.mset + , 'name' , M.name , 'store' , S.id - , 'min_sec', min_duration - , 'max_sec', max_duration - , 'win_sec', window_duration - , 'checked', checked - , 'origin' , fork_origin FROM repository R - , project P + , mirror_set M , version_control_system V , store S - WHERE R.id = :repo - AND P.id = R.project - AND V.id = R.vcs - AND S.id = R.store + WHERE R.id = :repo + AND M.id = R.mset + AND V.id = R.vcs + AND S.vcs = R.vcs + AND S.mset = R.mset }] debug.m/repo {=> ($details)} return $details } @@ -309,39 +183,40 @@ debug.m/repo {} set sub [string tolower $substring] set series {} m db eval { - SELECT P.name AS name - , R.fork_origin AS origin + SELECT M.name AS name , R.url AS url , R.id AS rid , V.code AS vcode , S.size_kb AS sizekb - , R.is_active AS active - , R.min_duration AS mins - , R.max_duration AS maxs - , R.window_duration AS lastn + , R.active AS active + , T.min_seconds AS mins + , T.max_seconds AS maxs + , T.window_seconds AS lastn , S.size_previous AS sizep , S.commits_current AS commits , S.commits_previous AS commitp FROM repository R - , project P + , mirror_set M , version_control_system V , store S - WHERE P.id = R.project + , store_times T + WHERE M.id = R.mset AND V.id = R.vcs - AND S.id = R.store - ORDER BY P.name ASC + AND S.mset = R.mset + AND S.vcs = R.vcs + AND S.id = T.store + ORDER BY M.name ASC , R.url ASC } { if { ([string first $sub [string tolower $name]] < 0) && ([string first $sub [string tolower $url ]] < 0) } continue lappend series [dict create \ - primary [expr {$origin eq {}}] \ name $name \ url $url \ id $rid \ vcode $vcode \ sizekb $sizekb \ @@ -373,40 +248,41 @@ lassign $first mname uname set lim [expr {$n + 1}] set replist {} m db eval { - SELECT P.name AS name - , R.fork_origin AS origin + SELECT M.name AS name , R.url AS url , R.id AS rid , V.code AS vcode , S.size_kb AS sizekb - , R.is_active AS active - , R.min_duration AS mins - , R.max_duration AS maxs - , R.window_duration AS lastn + , R.active AS active + , T.min_seconds AS mins + , T.max_seconds AS maxs + , T.window_seconds AS lastn , S.size_previous AS sizep , S.commits_current AS commits , S.commits_previous AS commitp FROM repository R - , project P + , mirror_set M , version_control_system V , store S - WHERE P.id = R.project + , store_times T + WHERE M.id = R.mset AND V.id = R.vcs - AND S.id = R.store + AND S.mset = R.mset + AND S.vcs = R.vcs + AND S.id = T.store -- cursor start clause ... - AND ((P.name > :mname) OR - ((P.name = :mname) AND + AND ((M.name > :mname) OR + ((M.name = :mname) AND (R.url >= :uname))) - ORDER BY P.name ASC + ORDER BY M.name ASC , R.url ASC LIMIT :lim } { lappend replist [dict create \ - primary [expr {$origin eq {}}] \ name $name \ url $url \ id $rid \ vcode $vcode \ sizekb $sizekb \ @@ -445,189 +321,59 @@ debug.m/repo {} return [m db eval { DELETE FROM repository WHERE id = :repo - ; -- - - -- --- ----- clear origin links in forks - UPDATE repository - SET fork_origin = NULL - WHERE fork_origin = :repo }] } proc ::m::repo::enable {repo {flag 1}} { debug.m/repo {} return [m db eval { UPDATE repository - SET is_active = :flag - WHERE id = :repo - }] -} - -proc ::m::repo::declaim {repo} { - debug.m/repo {} - m db eval { - UPDATE repository - SET fork_origin = NULL - WHERE id = :repo - } - return -} - -proc ::m::repo::claim {origin fork} { - debug.m/repo {} - m db eval { - UPDATE repository - SET fork_origin = :origin - WHERE id = :fork - } - return -} - -proc ::m::repo::move/project {projectold projectnew} { - debug.m/repo {} - m db eval { - UPDATE repository - SET project = :projectnew - WHERE project = :projectold - } - return -} - -proc ::m::repo::move/1 {repo projectnew} { - debug.m/repo {} - m db eval { - UPDATE repository - SET project = :projectnew - WHERE id = :repo - } - return -} - -# # ## ### ##### ######## ############# ###################### -## Management of pending repositories - -proc ::m::repo::count-pending {} { - debug.m/repo {} - return [m db onecolumn { - SELECT count (*) - FROM repo_pending - }] -} - -proc ::m::repo::add-pending {repo} { - debug.m/repo {} - m db eval { - INSERT - INTO repo_pending - VALUES ( :repo ) - } - return -} - -proc ::m::repo::drop-pending {repo} { - debug.m/repo {} - return [m db eval { - DELETE - FROM repo_pending - WHERE repository = :repo - }] - return -} - -proc ::m::repo::pending {} { - debug.m/repo {} - return [m db eval { - SELECT P.name AS name - , R.url AS url - , R.fork_origin AS origin - , (SELECT count (*) - FROM repository X - WHERE fork_origin = R.id) AS nforks - FROM repository R - , project P - WHERE R.project = P.id - AND R.is_active - ORDER BY R.ROWID - }] -} - -proc ::m::repo::take-pending {take args} { - debug.m/repo {} - - # Ask for one more than actually requested by the - # configuration. This will cause a short-read (with refill) not - # only when the table contains less than `take` elements, but also - # when it contains exactly that many. If the read is not short we - # know that at least one element is left. - incr take - - set taken [m db eval { - SELECT P.repository - FROM repo_pending P - , repository R - WHERE R.id = P.repository - AND R.is_active - LIMIT :take - }] - if {[llength $taken] < $take} { - # Short read. Clear taken (fast), and refill for next - # invokation. - m db eval { - DELETE - FROM repo_pending - ; - INSERT - INTO repo_pending - SELECT id - FROM repository - } - - if {[llength $args]} { - # Invoke callback to report that the overall cycle just - # came around and started anew. - try { - uplevel 1 $args - } on error {e o} { - # TODO -- Report (internal) error, but do not crash. - } - } - } else { - # Full read. Clear taken, the slow way. Drop the unwanted - # sentinel element from the end of the result. - set taken [lreplace [K $taken [unset taken]] end end] - m db eval [string map [list %% [join $taken ,]] { - DELETE - FROM repo_pending - WHERE repository in (%%) - }] - } - - return $taken + SET active = :flag + WHERE id = :repo + }] +} + +proc ::m::repo::move/mset {msetold msetnew} { + debug.m/repo {} + m db eval { + UPDATE repository + SET mset = :msetnew + WHERE mset = :msetold + } + return +} + +proc ::m::repo::move/1 {repo msetnew} { + debug.m/repo {} + m db eval { + UPDATE repository + SET mset = :msetnew + WHERE id = :repo + } + return } # # ## ### ##### ######## ############# ###################### proc ::m::repo::FIRST {} { debug.m/repo {} # First known repository. - # Ordered by project name, then url + # Ordered by mirror set name, then url return [m db eval { - SELECT P.name + SELECT M.name , R.url FROM repository R - , project P - WHERE R.project = P.id - ORDER BY P.name ASC + , mirror_set M + WHERE R.mset = M.id + ORDER BY M.name ASC , R.url ASC LIMIT 1 }] } -# # ## ### ##### ######## ############# ###################### - -proc ::m::repo::K {x y} { set x } - # # ## ### ##### ######## ############# ###################### package provide m::repo 0 return Index: lib/logic/store.tcl ================================================================== --- lib/logic/store.tcl +++ lib/logic/store.tcl @@ -32,14 +32,13 @@ namespace export store namespace ensemble create } namespace eval ::m::store { namespace export \ - add remove move rename merge cleave update has check path \ + add remove move rename merge cleave update has check \ id vcs-name updates by-name by-size by-vcs move-location \ - get getx repos remotes total-size count search issues disabled \ - has-issues + get remotes total-size count search issues disabled path namespace ensemble create } # # ## ### ##### ######## ############# ###################### @@ -46,29 +45,39 @@ debug level m/store debug prefix m/store {[debug caller] | } # # ## ### ##### ######## ############# ###################### -proc ::m::store::add {vcs name url} { +proc ::m::store::add {vcs mset name url} { debug.m/store {} - - set store [Add $vcs] - set state [m vcs setup $store $vcs $name $url] - dict with state {} - # commits, size, forks, duration - - Size $store $size - Commits $store $commits - - return [list $store $duration $commits $size $forks] + + set store [Add $vcs $mset] + + set started [clock seconds] + set counts [m vcs setup $store $vcs $name $url] + set spent [expr {[clock seconds] - $started}] + lassign $counts _ after forks + + Spent $store $spent + Size $store + Commits $store $after + if {$forks ne {}} { + ForksSetNew $store [llength $forks] + } + + return [list $store $spent $forks] } proc ::m::store::remove {store} { debug.m/store {} set vcs [VCS $store] m db eval { + DELETE + FROM store_times + WHERE store = :store + ; DELETE FROM store WHERE id = :store } @@ -93,32 +102,50 @@ m vcs cleave $vcs $store $new $name Size $new return } -proc ::m::store::has-issues {store} { - return [expr {[lindex [m vcs caps $store] 1] ne {}}] -} - -proc ::m::store::update {primary url store cycle now before} { +proc ::m::store::update {store cycle now} { debug.m/store {} - set vcs [VCS $store] - set state [m vcs update $store $vcs $url $primary] - dict with state {} - # ok, commits, size, forks, duration - if {!$primary} { set forks {} } - - debug.m/store {update = ($state)} - - if {!$ok} { - Size $store $size - Commits $store $commits - Times $store $cycle $now [expr {$commits != $before}] - } - - return [list $ok $duration $commits $size $forks] + set vcs [VCS $store] + + # Get all repositories for this store (same VCS, same mirror set), + # then feed everything to the vcs layer. + + set remotes [Remotes $store 1] + + set started [clock seconds] + set counts [m vcs update $store $vcs $remotes] + set spent [expr {[clock seconds] - $started}] + + lassign $counts before after forks + debug.m/store {update = ($counts)} + + Attend $store + Spent $store $spent + Size $store + Commits $store $after + if {$forks ne {}} { + ForksSet $store [llength $forks] + } + + if {$after != $before} { + m db eval { + UPDATE store_times + SET updated = :cycle + , changed = :now + WHERE store = :store + } + } else { + m db eval { + UPDATE store_times + SET updated = :cycle + WHERE store = :store + } + } + return [linsert $counts end $remotes $spent] } proc ::m::store::move {store msetnew} { debug.m/store {} # copy of `m mset name` - outline? check for dependency circles @@ -169,87 +196,51 @@ proc ::m::store::path {store} { debug.m/store {} return [m vcs path $store] } -proc ::m::store::getx {repos} { ;# XXX REWORK move to repo package - debug.m/store {} - - lappend map @@ [join $repos ,] - set series {} - m db eval [string map $map { - SELECT S.id AS store - , P.name AS mname - , V.code AS vcode - , S.changed AS changed - , S.updated AS updated - , S.created AS created - , R.has_issues AS attend - , S.size_kb AS size - , 1 AS remote - , R.is_active AS active - , R.fork_origin AS origin - , R.url AS url - , R.id AS rid - FROM repository R - , store S - , project P - , version_control_system V - WHERE R.store = S.id - AND R.project = P.id - AND R.vcs = V.id - AND R.id IN (@@) - ORDER BY mname ASC - , vcode ASC - , size ASC - }] { - Srow series ;# upvar column variables - } - return $series -} - proc ::m::store::get {store} { debug.m/store {} - set details [m db eval { + m db eval { SELECT 'size' , S.size_kb + , 'mset' , S.mset , 'vcs' , S.vcs , 'sizep' , S.size_previous , 'commits' , S.commits_current , 'commitp' , S.commits_previous , 'vcsname' , V.name - , 'updated' , S.updated - , 'changed' , S.changed - , 'created' , S.created - , 'attend' , (SELECT sum (R.has_issues) FROM repository R WHERE R.store = S.id) - , 'min_sec' , (SELECT min (R.min_duration) FROM repository R WHERE R.store = S.id) - , 'max_sec' , (SELECT max (R.max_duration) FROM repository R WHERE R.store = S.id) - , 'win_sec' , (SELECT group_concat (R.window_duration) FROM repository R WHERE R.store = S.id) - , 'remote' , (SELECT count (*) FROM repository R WHERE R.store = S.id) - , 'active' , (SELECT sum (is_active) FROM repository R WHERE R.store = S.id) + , 'updated' , T.updated + , 'changed' , T.changed + , 'created' , T.created + , 'attend' , T.attend + , 'min_sec' , T.min_seconds + , 'max_sec' , T.max_seconds + , 'win_sec' , T.window_seconds + , 'remote' , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs) AS remote + , 'active' , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs + AND R.active) AS active FROM store S + , store_times T , version_control_system V WHERE S.id = :store - AND S.vcs = V.id - }] - debug.m/store {=> ($details)} - return $details + AND T.store = S.id + AND V.id = S.vcs + } } proc ::m::store::remotes {store} { debug.m/store {} - return [Remotes $store] -} - -proc ::m::store::repos {store} { - debug.m/store {} - return [m db eval { - SELECT R.id - FROM repository R - , store S - WHERE S.id = :store - AND R.store = S.id - }] + set vcs [VCS $store] + lappend r [Remotes $store] ;# Database + lappend r [m vcs remotes $vcs $store] ;# Plugin supplied + return $r } proc ::m::store::vcs-name {store} { debug.m/store {} return [m db onecolumn { @@ -276,36 +267,40 @@ return [m db onecolumn { SELECT count (*) FROM store }] } - proc ::m::store::search {substring} { debug.m/store {} - # List stores ... - set sub [string tolower $substring] set series {} m db eval { - SELECT S.id AS store - , P.name AS mname - , V.code AS vcode - , S.changed AS changed - , S.updated AS updated - , S.created AS created - , R.has_issues AS attend - , S.size_kb AS size - , 1 AS remote - , R.is_active AS active - , R.fork_origin AS origin - , R.url AS url - , R.id AS rid - FROM repository R + SELECT S.id AS store + , M.name AS mname + , V.code AS vcode + , T.changed AS changed + , T.updated AS updated + , T.created AS created + , T.attend AS attend + , S.size_kb AS size + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs) AS remote + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs + AND R.active) AS active + FROM store_times T , store S - , project P + , mirror_set M , version_control_system V + WHERE T.store = S.id + AND S.mset = M.id + AND S.vcs = V.id ORDER BY mname ASC , vcode ASC , size ASC } { if { @@ -314,114 +309,119 @@ Srow series ;# upvar column variables } return $series } -proc ::m::store::issues {} { ;# XXX REWORK move to repo package +proc ::m::store::issues {} { debug.m/store {} - # List repositories ... - set series {} set last {} m db eval { - SELECT S.id AS store - , P.name AS mname - , V.code AS vcode - , S.changed AS changed - , S.updated AS updated - , S.created AS created - , R.has_issues AS attend - , S.size_kb AS size - , 1 AS remote - , R.is_active AS active - , R.fork_origin AS origin - , R.url AS url - , R.id AS rid - FROM repository R + SELECT S.id AS store + , M.name AS mname + , V.code AS vcode + , T.changed AS changed + , T.updated AS updated + , T.created AS created + , T.attend AS attend + , S.size_kb AS size + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs) AS remote + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs + AND R.active) AS active + FROM store_times T , store S - , project P + , mirror_set M , version_control_system V - WHERE R.store = S.id - AND R.has_issues = 1 -- Flag for "has issues" - AND R.is_active > 0 -- Flag for "not completely disabled" - AND R.project = P.id - AND R.vcs = V.id + WHERE T.store = S.id + AND T.attend = 1 -- Flag for "has issues" + AND active > 0 -- Flag for "not completely disabled" + AND S.mset = M.id + AND S.vcs = V.id ORDER BY mname ASC , vcode ASC , size ASC } { - Srow+origin series ;# upvar column variables + Srow series ;# upvar column variables } return $series } -proc ::m::store::disabled {} { ;# XXX REWORK move to repo package +proc ::m::store::disabled {} { debug.m/store {} - # List repositories ... - set series {} set last {} m db eval { - SELECT S.id AS store - , P.name AS mname - , V.code AS vcode - , S.changed AS changed - , S.updated AS updated - , S.created AS created - , R.has_issues AS attend - , S.size_kb AS size - , 1 AS remote - , 0 AS active - , R.id AS rid - , R.url AS url - , R.fork_origin AS origin - FROM repository R + SELECT S.id AS store + , M.name AS mname + , V.code AS vcode + , T.changed AS changed + , T.updated AS updated + , T.created AS created + , T.attend AS attend + , S.size_kb AS size + , 1 AS remote + , 0 AS active + , R.id AS rid + , R.url AS url + FROM store_times T , store S - , project P + , mirror_set M , version_control_system V - WHERE R.store = S.id - AND R.is_active = 0 -- Flag for disabled - AND R.project = P.id - AND R.vcs = V.id + , repository R + WHERE T.store = S.id + AND R.active = 0 -- Flag for disabled + AND S.mset = M.id + AND S.vcs = V.id + AND R.mset = S.mset + AND R.vcs = S.vcs ORDER BY mname ASC , vcode ASC , size ASC } { Srow+rid+url series ;# upvar column variables } return $series } -proc ::m::store::by-name {} { ;# XXX REWORK move to repo package +proc ::m::store::by-name {} { debug.m/store {} - # List stores ... - set series {} set last {} m db eval { - SELECT S.id AS store - , P.name AS mname - , V.code AS vcode - , S.changed AS changed - , S.updated AS updated - , S.created AS created - , R.has_issues AS attend - , S.size_kb AS size - , 1 AS remote - , R.is_active AS active - , R.fork_origin AS origin - , R.url AS url - FROM repository R + SELECT S.id AS store + , M.name AS mname + , V.code AS vcode + , T.changed AS changed + , T.updated AS updated + , T.created AS created + , T.attend AS attend + , S.size_kb AS size + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs) AS remote + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs + AND R.active) AS active + FROM store_times T , store S - , project P + , mirror_set M , version_control_system V - WHERE R.store = S.id - AND R.project = P.id - AND R.vcs = V.id + WHERE T.store = S.id + AND S.mset = M.id + AND S.vcs = V.id ORDER BY mname ASC , vcode ASC , size ASC } { if {($last ne {}) && ($last ne $mname)} { @@ -433,86 +433,90 @@ set last $saved } return $series } -proc ::m::store::by-vcs {} { ;# XXX REWORK move to repo package +proc ::m::store::by-vcs {} { debug.m/store {} - # List repositories ... - set series {} m db eval { - SELECT S.id AS store - , P.name AS mname - , V.code AS vcode - , S.changed AS changed - , S.updated AS updated - , S.created AS created - , R.has_issues AS attend - , S.size_kb AS size - , 1 AS remote - , R.is_active AS active - , R.fork_origin AS origin - , R.url AS url - FROM repository R + SELECT S.id AS store + , M.name AS mname + , V.code AS vcode + , T.changed AS changed + , T.updated AS updated + , T.created AS created + , T.attend AS attend + , S.size_kb AS size + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs) AS remote + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs + AND R.active) AS active + FROM store_times T , store S - , project P + , mirror_set M , version_control_system V - WHERE R.store = S.id - AND R.project = P.id - AND R.vcs = V.id + WHERE T.store = S.id + AND S.mset = M.id + AND S.vcs = V.id ORDER BY vcode ASC , mname ASC , size ASC } { Srow series } return $series } -proc ::m::store::by-size {} { ;# XXX REWORK move to repo package +proc ::m::store::by-size {} { debug.m/store {} - # List repositories ... - set series {} m db eval { - SELECT S.id AS store - , P.name AS mname - , V.code AS vcode - , S.changed AS changed - , S.updated AS updated - , S.created AS created - , R.has_issues AS attend - , S.size_kb AS size - , 1 AS remote - , R.is_active AS active - , R.fork_origin AS origin - , R.url AS url - FROM repository R + SELECT S.id AS store + , M.name AS mname + , V.code AS vcode + , T.changed AS changed + , T.updated AS updated + , T.created AS created + , T.attend AS attend + , S.size_kb AS size + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs) AS remote + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs + AND R.active) AS active + FROM store_times T , store S - , project P + , mirror_set M , version_control_system V - WHERE R.store = S.id - AND R.project = P.id - AND R.vcs = V.id + WHERE T.store = S.id + AND S.mset = M.id + AND S.vcs = V.id ORDER BY size DESC , mname ASC , vcode ASC } { Srow series } return $series } -proc ::m::store::updates {} { ;# XXX REWORK move to repo package +proc ::m::store::updates {} { debug.m/store {} - # List repositories ... - - # From the db.tcl notes on store times + # From the db.tcl notes on store_times # # 1. created <= changed <= updated # 2. (created == changed) -> never changed. set series {} @@ -519,37 +523,42 @@ # Block 1: Changed stores, changed order descending # Insert separators when `updated` changes. set last {} m db eval { - SELECT S.id AS store - , P.name AS mname - , V.code AS vcode - , S.changed AS changed - , S.updated AS updated - , S.created AS created - , R.has_issues AS attend - , S.size_kb AS size - , 1 AS remote - , R.is_active AS active - , R.min_duration AS mins - , R.max_duration AS maxs - , R.window_duration AS lastn + SELECT S.id AS store + , M.name AS mname + , V.code AS vcode + , T.changed AS changed + , T.updated AS updated + , T.created AS created + , T.attend AS attend + , S.size_kb AS size + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs) AS remote + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs + AND R.active) AS active + , T.min_seconds AS mins + , T.max_seconds AS maxs + , T.window_seconds AS lastn , S.size_previous AS sizep , S.commits_current AS commits , S.commits_previous AS commitp - , R.fork_origin AS origin - , R.url AS url - FROM repository R + FROM store_times T , store S - , project P + , mirror_set M , version_control_system V - WHERE R.store = S.id - AND R.project = P.id - AND R.vcs = V.id - AND S.created != S.changed - ORDER BY S.changed DESC + WHERE T.store = S.id + AND S.mset = M.id + AND S.vcs = V.id + AND T.created != T.changed + ORDER BY T.changed DESC } { if {($last ne {}) && ($last != $updated)} { Sep series } Srow+delta series @@ -560,37 +569,42 @@ set first [llength $series] # Block 2: All unchanged stores, creation order descending, # i.e. last created top/first. m db eval { - SELECT S.id AS store - , P.name AS mname - , V.code AS vcode - , S.changed AS changed - , S.updated AS updated - , S.created AS created - , R.has_issues AS attend - , S.size_kb AS size - , 1 AS remote - , R.is_active AS active - , R.min_duration AS mins - , R.max_duration AS maxs - , R.window_duration AS lastn + SELECT S.id AS store + , M.name AS mname + , V.code AS vcode + , T.changed AS changed + , T.updated AS updated + , T.created AS created + , T.attend AS attend + , S.size_kb AS size + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs) AS remote + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs + AND R.active) AS active + , T.min_seconds AS mins + , T.max_seconds AS maxs + , T.window_seconds AS lastn , S.size_previous AS sizep , S.commits_current AS commits , S.commits_previous AS commitp - , R.fork_origin AS origin - , R.url AS url - FROM repository R + FROM store_times T , store S - , project P + , mirror_set M , version_control_system V - WHERE R.store = S.id - AND R.project = P.id - AND R.vcs = V.id - AND S.created = S.changed - ORDER BY S.created DESC + WHERE T.store = S.id + AND S.mset = M.id + AND S.vcs = V.id + AND T.created = T.changed + ORDER BY T.created DESC } { if {$first} { Sep series } set changed {} set updated {} Srow+delta series @@ -607,81 +621,46 @@ return } # # ## ### ##### ######## ############# ###################### -proc ::m::store::Srow {sv} { ;# XXX REWORK move to repo package +proc ::m::store::Srow {sv} { debug.m/store {} upvar 1 \ $sv series store store mname mname vcode vcode \ changed changed updated updated created created \ - size size active active remote remote attend attend \ - origin origin url url + size size active active remote remote attend attend - debug.m/store {s=$store, m=$mname, v=$vcode, ch=$changed, up=$updated, cr=$created, sz=$size, r=$remote/$active, trouble=$attend, oring=4origin, url=$url} + debug.m/store {s=$store, m=$mname, v=$vcode, ch=$changed, up=$updated, cr=$created, sz=$size, r=$remote/$active, trouble=$attend} set row [dict create \ - url $url \ - origin $origin \ store $store \ mname $mname \ vcode $vcode \ changed $changed \ updated $updated \ created $created \ size $size \ remote $remote \ active $active \ - attend $attend \ - ] - lappend series $row - return -} - -proc ::m::store::Srow+origin {sv} { ;# XXX REWORK move to repo package - debug.m/store {} - upvar 1 \ - $sv series store store mname mname vcode vcode \ - changed changed updated updated created created \ - size size active active remote remote attend attend \ - origin origin url url rid rid - - debug.m/store {s=$store, m=$mname, v=$vcode, ch=$changed, up=$updated, cr=$created, sz=$size, r=$remote/$active, trouble=$attend, origin=$origin, url=$url, rid=$rid} - - set row [dict create \ - rid $rid \ - url $url \ - store $store \ - mname $mname \ - vcode $vcode \ - changed $changed \ - updated $updated \ - created $created \ - size $size \ - remote $remote \ - active $active \ - attend $attend \ - origin $origin - ] - lappend series $row - return -} - -proc ::m::store::Srow+delta {sv} { ;# XXX REWORK move to repo package + attend $attend] + lappend series $row + return +} + +proc ::m::store::Srow+delta {sv} { debug.m/store {} upvar 1 \ $sv series store store mname mname vcode vcode \ changed changed updated updated created created \ size size active active remote remote attend attend \ sizep sizep commits commits commitp commitp mins mins \ - maxs maxs lastn lastn origin origin url url + maxs maxs lastn lastn debug.m/store {s=$store, m=$mname, v=$vcode, ch=$changed, up=$updated, cr=$created, sz=$size, r=$remote/$active, trouble=$attend} set row [dict create \ - url $url \ - origin $origin \ store $store \ mname $mname \ vcode $vcode \ changed $changed \ updated $updated \ @@ -699,19 +678,19 @@ ] lappend series $row return } -proc ::m::store::Srow+rid+url {sv} { ;# XXX REWORK move to repo package +proc ::m::store::Srow+rid+url {sv} { debug.m/store {} upvar 1 \ $sv series store store mname mname vcode vcode \ changed changed updated updated created created \ size size active active remote remote attend attend \ - rid rid url url origin origin + rid rid url url - debug.m/store {s=$store, m=$mname, v=$vcode, ch=$changed, up=$updated, cr=$created, sz=$size, r=$remote/$active, trouble=$attend, rid=$rid, url=$url, origin=$origin} + debug.m/store {s=$store, m=$mname, v=$vcode, ch=$changed, up=$updated, cr=$created, sz=$size, r=$remote/$active, trouble=$attend} set row [dict create \ store $store \ mname $mname \ vcode $vcode \ @@ -721,17 +700,16 @@ size $size \ remote $remote \ active $active \ attend $attend \ rid $rid \ - url $url \ - origin $origin ] + url $url ] lappend series $row return } -proc ::m::store::Sep {sv} { ;# XXX REWORK move to repo package +proc ::m::store::Sep {sv} { debug.m/store {} upvar 1 $sv series lappend series { store . mname . vcode . changed . updated . created . size . active . @@ -747,62 +725,59 @@ if {$onlyactive} { return [m db eval { SELECT R.url FROM repository R , store S - WHERE S.id = :store - AND R.store = S.id - AND R.is_active + WHERE S.id = :store + AND R.vcs = S.vcs + AND R.mset = S.mset + AND R.active }] } return [m db eval { SELECT R.url FROM repository R , store S - WHERE S.id = :store - AND R.store = S.id + WHERE S.id = :store + AND R.vcs = S.vcs + AND R.mset = S.mset }] } -proc ::m::store::Times {store cycle now haschanged} { - if {$haschanged} { - m db eval { - UPDATE store - SET updated = :cycle - , changed = :now - WHERE store = :store - } - return - } - - m db eval { - UPDATE store - SET updated = :cycle - WHERE store = :store - } - return -} - -proc ::m::store::Size {store new} { +proc ::m::store::Size {store} { debug.m/store {} + set new [m vcs size $store] set current [m db onecolumn { SELECT size_kb FROM store WHERE id = :store }] if {$new == $current} return - + m db eval { UPDATE store SET size_previous = size_kb -- Parallel assignment , size_kb = :new -- Shift values. WHERE id = :store } + return +} + +proc ::m::store::InitialCommit {store} { + debug.m/store {} + set vcs [VCS $store] + set revs [m vcs revs $store $vcs] + m db eval { + UPDATE store + SET commits_current = :revs + , commits_previous = :revs + WHERE id = :store + } return } proc ::m::store::Commits {store new} { debug.m/store {} @@ -822,30 +797,101 @@ WHERE id = :store } return } -proc ::m::store::Add {vcs} { +proc ::m::store::Spent {store new} { + debug.m/store {} + + m db eval { + SELECT min_seconds AS mins + , max_seconds AS maxs + , window_seconds AS window + FROM store_times + WHERE store = :store + } {} + + debug.m/store {mins = $mins} + debug.m/store {maxs = $maxs} + debug.m/store {lastn = ($window)} + + if {($mins < 0) || ($new < $mins)} { set mins $new } + if { $new > $maxs} { set maxs $new } + + set window [split [string trim $window ,] ,] + + debug.m/store {lastn'= ($window)} + + if {[llength $window]} { + lappend window $new + set maxlen [m state store-window-size] + set len [llength $window] + if {$len > $maxlen} { + set over [expr {$len - $maxlen}] + set window [lreplace $window 0 ${over}-1] + } + set new [join $window ,] + } + set window ,${new}, + + debug.m/store {lastn.= ($window)} + + m db eval { + UPDATE store_times + SET min_seconds = :mins + , max_seconds = :maxs + , window_seconds = :window + WHERE store = :store + } + + return +} + +proc ::m::store::Attend {store} { debug.m/store {} - set now [clock seconds] + + set attend [expr {[lindex [m vcs caps $store] 1] ne {}}] + m db eval { + UPDATE store_times + SET attend = :attend + WHERE store = :store + } + return +} +proc ::m::store::Add {vcs mset} { + debug.m/store {} m db eval { INSERT INTO store VALUES ( NULL -- id , :vcs -- vcs + , :mset -- mset , 0 -- size_kb , 0 -- size_previous , 0 -- commits_current , 0 -- commits_previous - , :now -- created - , :now -- updated - , :now -- changed + ) + } + + set store [m db last_insert_rowid] + set now [clock seconds] + + m db eval { + INSERT + INTO store_times + VALUES ( :store -- ^store + , :now -- created + , :now -- updated + , :now -- changed + , 0 -- attend + , -1 -- min_seconds (+Infinity) + , 0 -- max_seconds + , '' -- window_seconds ) } - - return [m db last_insert_rowid] + return $store } proc ::m::store::VCS {store} { debug.m/store {} return [m db onecolumn { @@ -853,27 +899,19 @@ FROM store WHERE id = :store }] } -proc ::m::store::MSName {project} { +proc ::m::store::MSName {mset} { debug.m/store {} return [m db onecolumn { SELECT name - FROM project - WHERE id = :project + FROM mirror_set + WHERE id = :mset }] } -## -# # ## ### ##### ######## ############# ###################### -## ATTENTION -## These commands are part of the database migration step. -## Their use of old tables and columns is intentional! -## At the point they are called by the migration these are -## the current tables and columns - proc ::m::store::InitialCommits {} { debug.m/store {} m db eval { SELECT id FROM store @@ -881,52 +919,17 @@ InitialCommit $id } return } -proc ::m::store::InitialCommit {store} { - debug.m/store {} - - set vcs [VCS $store] - set revs [m vcs revs $store $vcs] - m db eval { - UPDATE store - SET commits_current = :revs - , commits_previous = :revs - WHERE id = :store - } - return -} - proc ::m::store::InitialSizes {} { debug.m/store {} m db eval { SELECT id FROM store } { - InitialSize $id - } - return -} - -proc ::m::store::InitialSize {store} { - debug.m/store {} - - set new [m vcs size $store] - set current [m db onecolumn { - SELECT size_kb - FROM store - WHERE id = :store - }] - - if {$new == $current} return - - m db eval { - UPDATE store - SET size_previous = size_kb -- Parallel assignment - , size_kb = :new -- Shift values. - WHERE id = :store + Size $id } return } proc ::m::store::InitialIssues {} { @@ -935,22 +938,10 @@ SELECT id FROM store } { Attend $id } - return -} - -proc ::m::store::Attend {store} { - debug.m/store {} - - set attend [expr {[lindex [m vcs caps $store] 1] ne {}}] - m db eval { - UPDATE store_times - SET attend = :attend - WHERE store = :store - } return } proc ::m::store::InitialForks {} { debug.m/store {} @@ -976,9 +967,32 @@ VALUES ( :store , :forks ) } return } + +proc ::m::store::ForksSetNew {store forks} { + debug.m/store {} + # assert: vcs == github + m db eval { + INSERT + INTO store_github_forks + VALUES ( :store + , :forks ) + } + return +} + +proc ::m::store::ForksSet {store forks} { + debug.m/store {} + # assert: vcs == github + m db eval { + UPDATE store_github_forks + SET nforks = :forks + WHERE store = :store + } + return +} # # ## ### ##### ######## ############# ###################### package provide m::store 0 return ADDED lib/logic/vt_mirrorset.tcl Index: lib/logic/vt_mirrorset.tcl ================================================================== --- /dev/null +++ lib/logic/vt_mirrorset.tcl @@ -0,0 +1,85 @@ +## -*- tcl -*- +# # ## ### ##### ######## ############# ##################### +## Repositories - Validation + +# @@ Meta Begin +# Package m::validate::mset 0 +# Meta author {Andreas Kupries} +# Meta location https://core.tcl.tk/akupries/???? +# Meta platform tcl +# Meta summary mirror set validation +# Meta description mirror set validation +# Meta subject {mirror set - validation} +# Meta require {Tcl 8.5-} +# @@ Meta End + +package provide m::validate::mset 0 + +# # ## ### ##### ######## ############# ##################### +## Requisites + +package require Tcl 8.5 +package require cmdr::validate::common 1.2 +package require try +package require m::mset +package require m::repo +package require m::rolodex +package require m::match +package require debug +package require debug::caller + +# # ## ### ##### ######## ############# ###################### + +debug level m/validate/mset +debug prefix m/validate/mset {[debug caller] | } + +# # ## ### ##### ######## ############# ##################### +## Definition + +namespace eval ::m { + namespace export validate + namespace ensemble create +} +namespace eval ::m::validate { + namespace export mset + namespace ensemble create +} +namespace eval ::m::validate::mset { + namespace export default validate complete release + namespace ensemble create + + namespace import ::cmdr::validate::common::fail + namespace import ::cmdr::validate::common::complete-enum +} +# # ## ### ##### ######## ############# ##################### + +debug define m/validate/mset +debug level m/validate/mset +debug prefix m/validate/mset {[debug caller] | } + +# # ## ### ##### ######## ############# ##################### + +proc ::m::validate::mset::release {p x} { return } +proc ::m::validate::mset::default {p} { + return [m repo mset [m rolodex top]] +} +proc ::m::validate::mset::complete {p x} { + debug.m/validate/mset {} 10 + return [complete-enum [dict keys [m mset known]] 0 $x] +} +proc ::m::validate::mset::validate {p x} { + debug.m/validate/mset {} + + set known [m mset known] + set match [m match substring id $known nocase $x] + + switch -exact -- $match { + ok { return $id } + fail { fail $p MSET "a mirror set" $x } + ambiguous { fail $p MSET "an unambiguous mirror set" $x } + } +} + +# # ## ### ##### ######## ############# ##################### +## Ready +return DELETED lib/logic/vt_project.tcl Index: lib/logic/vt_project.tcl ================================================================== --- lib/logic/vt_project.tcl +++ /dev/null @@ -1,85 +0,0 @@ -## -*- tcl -*- -# # ## ### ##### ######## ############# ##################### -## Repositories - Validation - -# @@ Meta Begin -# Package m::validate::project 0 -# Meta author {Andreas Kupries} -# Meta location https://core.tcl.tk/akupries/???? -# Meta platform tcl -# Meta summary mirror set validation -# Meta description mirror set validation -# Meta subject {mirror set - validation} -# Meta require {Tcl 8.5-} -# @@ Meta End - -package provide m::validate::project 0 - -# # ## ### ##### ######## ############# ##################### -## Requisites - -package require Tcl 8.5 -package require cmdr::validate::common 1.2 -package require try -package require m::project -package require m::repo -package require m::rolodex -package require m::match -package require debug -package require debug::caller - -# # ## ### ##### ######## ############# ###################### - -debug level m/validate/project -debug prefix m/validate/project {[debug caller] | } - -# # ## ### ##### ######## ############# ##################### -## Definition - -namespace eval ::m { - namespace export validate - namespace ensemble create -} -namespace eval ::m::validate { - namespace export project - namespace ensemble create -} -namespace eval ::m::validate::project { - namespace export default validate complete release - namespace ensemble create - - namespace import ::cmdr::validate::common::fail - namespace import ::cmdr::validate::common::complete-enum -} -# # ## ### ##### ######## ############# ##################### - -debug define m/validate/project -debug level m/validate/project -debug prefix m/validate/project {[debug caller] | } - -# # ## ### ##### ######## ############# ##################### - -proc ::m::validate::project::release {p x} { return } -proc ::m::validate::project::default {p} { - return [m repo mset [m rolodex top]] -} -proc ::m::validate::project::complete {p x} { - debug.m/validate/project {} 10 - return [complete-enum [dict keys [m project known]] 0 $x] -} -proc ::m::validate::project::validate {p x} { - debug.m/validate/project {} - - set known [m project known] - set match [m match substring id $known nocase $x] - - switch -exact -- $match { - ok { return $id } - fail { fail $p PROJECT "a project" $x } - ambiguous { fail $p PROJECT "an unambiguous project" $x } - } -} - -# # ## ### ##### ######## ############# ##################### -## Ready -return Index: lib/mail/sender.tcl ================================================================== --- lib/mail/sender.tcl +++ lib/mail/sender.tcl @@ -55,16 +55,13 @@ m msg* " To: [color name $receiver] ... " try { set res [smtp::sendmessage $token -header [list To $receiver] {*}[Config]] - # XXX REVISIT This may exit on issues, instead of throwing an error ?! foreach item $res { m msg " ERR $item" } - } on error {e o} { - m msg [color bad $e] } finally { } mime::finalize $token m msg [color good OK] Index: lib/utils/format.tcl ================================================================== --- lib/utils/format.tcl +++ lib/utils/format.tcl @@ -29,41 +29,21 @@ # # ## ### ##### ######## ############# ##################### ## Definition namespace eval m::format { - namespace export size epoch epoch/short interval win win-trim + namespace export size epoch epoch/short interval namespace ensemble create } namespace eval m { namespace export format namespace ensemble create } # # ## ### ##### ######## ############# ###################### -proc m::format::win {lastn} { - # CSV to list, remove bubbles (empty elements) - return [lmap x [split $lastn ,] { if {$x eq {}} continue ; set x }] -} - -proc m::format::win-trim {lastn max} { - set len [llength $lastn] - # As new entries are added at the end trimming is done from the front. - # This is a naive trimmer, removing elements one by one. - # Considered ok because we usually need only remove one element anyway. - while {$len > $max} { - set lastn [lrange $lastn 1 end] - set len [llength $lastn] - } - return $lastn -} - -# # ## ### ##### ######## ############# ###################### - proc m::format::size {x} { - # x is in [KB]. debug.m/format {} if {$x < 1024} { return ${x}K } set x [expr {$x/1024.}] ; if {$x < 1024} { return [format %.1f $x]M } set x [expr {$x/1024.}] ; if {$x < 1024} { return [format %.1f $x]G } set x [expr {$x/1024.}] ; if {$x < 1024} { return [format %.1f $x]T } Index: lib/utils/ops.tcl ================================================================== --- lib/utils/ops.tcl +++ lib/utils/ops.tcl @@ -40,11 +40,11 @@ namespace export set client namespace ensemble create } namespace eval m::ops::client { namespace export set main \ - info note warn err fatal \ + info note warn err fatal \ result ok fail commits fork size \ ok? namespace ensemble create } @@ -98,23 +98,10 @@ global argv if {[llength $argv] < 3} { Usage "Not enough arguments" } set argv [lassign $argv vcs logfile operation] - - # All issues, including syntax errors, bad arguments, etc are - # reported through the log and stdout. This is in an internal - # support application the user normally will not invoke directly. - # Thus the log has to be initialized before anything other checks. - if {[catch { - LogTo $logfile - } msg]} { - err $msg - fail - return 0 - } - set ops { setup {Store Url} cleanup {Store} update {Store Url Bool} mergable? {Store Store} @@ -131,10 +118,17 @@ if {[llength $argv] != [llength $types]} { Usage "Wrong # Args for $operation" } foreach a $argv t $types { if {![$t $a]} { Usage "Expected $t, got '$a'" } + } + if {[catch { + LogTo $logfile + } msg]} { + err $msg + fail + return 0 } upvar 1 $v cmd set cmd [linsert $argv 0 $vcs $operation] return 1 } Index: lib/utils/setup.tcl ================================================================== --- lib/utils/setup.tcl +++ lib/utils/setup.tcl @@ -2,14 +2,14 @@ # # ## ### ##### ######## ############# ##################### ## Database utilities - Setup, migration processing, schema management # @@ Meta Begin # Package db::setup 0 -# Meta author {Andreas Kupries} +# Meta author {Andreas Kupries} # Meta location https://core.tcl.tk/akupries/???? # Meta platform tcl -# Meta summary Database setup, migration management +# Meta summary Database setup, migration management # Meta description Database setup, migration management # Meta subject {database setup} {migration processing} {schema management} # Meta require {Tcl 8.5-} # @@ Meta End @@ -31,11 +31,11 @@ # # ## ### ##### ######## ############# ##################### ## Definition namespace eval db::setup { namespace import ::db::track::it ; rename it track - namespace export D C U T T^ I I+ > >+ X < <= / R + namespace export D C U T T^ I I+ > >+ X < <= / } namespace eval db { namespace export setup namespace ensemble create @@ -164,13 +164,13 @@ proc db::setup::<= {table select} { debug.db/setup {} T new_${table} - # constraint: to not lose rows in the change we count before, then count again after + # constraint: do no lose rows. count, then count again. set old [lindex [R "SELECT count (*) FROM $table"] 0] - + lappend map @@ $table set select [string map $map $select] lappend sql "INSERT INTO new_${table} $select" lappend sql "DROP TABLE $table" lappend sql "ALTER TABLE new_${table} RENAME TO $table" @@ -238,11 +238,11 @@ proc db::setup::InitializeAndGetVersion {db} { debug.db/setup {} return [$db eval [string map [list \t {}] { CREATE TABLE IF NOT EXISTS schema - ( key TEXT NOT NULL PRIMARY KEY + ( key TEXT NOT NULL PRIMARY KEY , version INTEGER NOT NULL ) ; INSERT OR IGNORE INTO schema Index: lib/vcs/github.tcl ================================================================== --- lib/vcs/github.tcl +++ lib/vcs/github.tcl @@ -219,12 +219,11 @@ # # ## ### ##### ######## ############# ##################### ## Helpers proc ::m::vcs::github::ReportForks {url} { debug.m/vcs/github {} - upvar 1 path path - # for `git::Get` - TODO - redesign with proper state in the low-level code. + upvar 1 path path ;# for `git::Get` - TODO - redesign with proper state in the low-level code. set origin [join [lrange [file split $url] end-1 end] /] set forks [lsort -dict [m::vcs::git::Get hub forks --raw $origin]] if {[m exec err-last-get]} { @@ -231,12 +230,12 @@ m ops client fail ; return } foreach fork $forks { # unverified estimate (saved) - m ops client fork https://github.com/$fork + m ops client fork $fork } return } # # ## ### ##### ######## ############# ##################### return Index: lib/vcs/vcs.tcl ================================================================== --- lib/vcs/vcs.tcl +++ lib/vcs/vcs.tcl @@ -54,11 +54,11 @@ namespace eval ::m::vcs { namespace export \ setup cleanup update check cleave merge \ rename id supported all code name \ detect url-norm name-from-url version \ - move size caps export path revs + move size caps remotes export path revs namespace ensemble create namespace import ::cmdr::color # Operation state: Id counter, and state per operation. @@ -102,20 +102,20 @@ proc ::m::vcs::setup {store vcs name url} { debug.m/vcs {} # store id -> Using for path. # vcs id -> Decode to plugin name - # name - project name + # name - mset name # url - repo url set path [Path $store] set vcode [code $vcs] # Ensure clean new environment file delete -force -- $path file mkdir $path - m futil write $path/%name $name ;# Project + m futil write $path/%name $name ;# Mirror set m futil write $path/%vcs $vcode ;# Manager # Redirect through an external command. This command is currently # always `mirror-vcs VCS LOG setup STORE URL`. @@ -137,63 +137,86 @@ if {!$ok} { # Roll back filesystem changes file delete -force -- $path # Rethrow as something more distinguished for trapping - E $msg CHILD + return -code error -errorcode {M VCS CHILD} $msg } dict unset state results dict unset state msg - dict unset state ok - # commits, size, forks, duration return $state } -proc ::m::vcs::update {store vcs url primary} { +proc ::m::vcs::update {store vcs urls} { debug.m/vcs {} # store id -> Using for path. # vcs id -> Decode to plugin name # urls - repo urls to use as sources set path [Path $store] set vcode [code $vcs] - # Validate the url to ensure that it is still present. No need to - # go for the vcs client when we know that it must fail. That said, - # we store our failure as a pseudo error log for other parts to - # pick up on. + # Validate incoming urls to ensure that they are still present. No + # need to go for the vcs client when we know that it must + # fail. That said, we store our failure as a pseudo error log for + # other parts to pick up on. m futil write $path/%stderr "" - m futil write $path/%stdout "Verifying url ...\n" - debug.m/vcs {Verifying $url ...} - set ok [m url ok $url xr] - if {!$ok} { + m futil write $path/%stdout "Verifying urls ...\n" + set failed 0 + foreach u $urls { + debug.m/vcs {Verifying $u ...} + if {[m url ok $u xr]} continue m futil append $path/%stderr " Bad url: $u\n" - m futil append $path/%stderr "Unable to reach remote\n" - # Fake an error state ... - return {ok 0 commits 0 size 0 forks {} results {} msg {Invalid url} duration 0} + set failed 1 + } + if {$failed} { + m futil append $path/%stderr "Unable to reach remotes\n" + # Fake 'no changes', and error + return {-1 -1 {}} } # Ask plugin to update the store. # Redirect through an external command. This command is currently # always `mirror-vcs VCS LOG setup STORE URL`. Operation ::m::vcs::OpComplete $vcode update \ - {*}[OpCmd $vcode $path $url $primary] + {*}[OpCmd $vcode $path $urls 0] set state [OpWait] - return $state - dict with state {} # [x] ok # [x] commits # [x] size # [x] forks # [ ] results # [x] msg # [x] duration + + if {!$ok} { + # Fake 'no changes', and error. + # Note, CAP already saved the errorInfo into %stderr + return {-1 -1 {}} + } + + + + + + try { + CAP $path { + set counts [$vcode update $path $urls 0] + } + } on error {e o} { + # Fake 'no changes', and error. + # Note, CAP already saved the errorInfo into %stderr + return {-1 -1 {}} + } + if {[llength $counts] < 3} { lappend counts {} } + debug.m/vcs {==> ($counts)} + return $counts } proc ::m::vcs::rename {store name} { debug.m/vcs {} # store id -> Using for path. @@ -230,11 +253,11 @@ # [ ] duration if {!$ok} { # Do not perform any filesystem changes. # Rethrow as something more distinguished for trapping - E $msg CHILD + return -code error -errorcode {M VCS CHILD} $msg } # ... and the store directory file delete -force -- $path return @@ -274,10 +297,13 @@ proc ::m::vcs::check {vcs storea storeb} { debug.m/vcs {} set patha [Path $storea] set pathb [Path $storeb] set vcode [code $vcs] + + upvar 1 $iv issues + set issues {} # Redirect through an external command. This command is currently # always `mirror-vcs VCS LOG mergable?`. Operation ::m::vcs::OpComplete $vcode mergable? \ @@ -294,11 +320,11 @@ # [ ] duration if {!$ok} { if {[llength $msg]} { lappend issues {*}$msg } if {[llength $results]} { lappend issues {*}$results } - E [join $issues \n] CHILD + return } else { set flag [lindex $results 0] debug.m/vcs {--> $flag} return $flag } @@ -307,10 +333,13 @@ proc ::m::vcs::merge {vcs target origin} { debug.m/vcs {} set ptarget [Path $target] set porigin [Path $origin] set vcode [code $vcs] + + upvar 1 $iv issues + set issues {} # Redirect through an external command. This command is currently # always `mirror-vcs VCS LOG merge`. Operation ::m::vcs::OpComplete $vcode merge \ @@ -327,11 +356,11 @@ # [ ] duration if {!$ok} { if {[llength $msg]} { lappend issues {*}$msg } if {[llength $results]} { lappend issues {*}$results } - E [join $issues \n] CHILD + return } # Destroy the merged store cleanup $origin $vcs return @@ -349,10 +378,13 @@ # Inlined rename of origin's new copy m futil write $pdst/%name $dstname # Split/create vcs specific special resources, if any ... + + upvar 1 $iv issues + set issues {} # Redirect through an external command. This command is currently # always `mirror-vcs VCS LOG split`. Operation ::m::vcs::OpComplete $vcode split \ @@ -369,19 +401,27 @@ # [ ] duration if {!$ok} { if {[llength $msg]} { lappend issues {*}$msg } if {[llength $results]} { lappend issues {*}$results } - E [join $issues \n] CHILD } return } proc ::m::vcs::path {store} { debug.m/vcs {} return [Path $store] } + +proc ::m::vcs::remotes {vcs store} { + debug.m/vcs {} + set path [Path $store] + set vcode [code $vcs] + + # Ask plugin for remotes it may have. + return [$vcode remotes $path] +} proc ::m::vcs::export {vcs store} { debug.m/vcs {} set path [Path $store] set vcode [code $vcs] @@ -392,11 +432,11 @@ # Ask plugin for CGI script to access the store. Operation ::m::vcs::OpComplete $vcode export \ {*}[OpCmd $vcode $path] set state [OpWait] - + dict with state {} # [x] ok # [ ] commits # [ ] size # [ ] forks @@ -404,13 +444,13 @@ # [ ] msg # [ ] duration if {!$ok} { if {![llength $results]} { - lappend results "Failed to retrieve export script for $vcode on $path" + lappend results "Failed to retrieve export script for $vcs on $path" } - E [join $results \n] EXPORT + return -errorcode {MIRROR VCS EXPORT} -code error [join $results \n] } else { set script [join $results \n] debug.m/vcs {--> $script} return $script } @@ -418,11 +458,10 @@ # # ## ### ##### ######## ############# ##################### proc ::m::vcs::version {vcode iv} { debug.m/vcs {} - upvar 1 $iv issues set issues {} # Redirect through an external command. This command is currently # always `mirror-vcs VCS LOG version`. @@ -462,11 +501,11 @@ git detect $url hg detect $url svn detect $url fossil detect $url - E "Unable to determine vcs for $url" DETECT + return -code error "Unable to determine vcs for $url" } proc ::m::vcs::url-norm {vcode url} { debug.m/vcs {} # Normalize the incoming url @@ -494,10 +533,12 @@ return [string map $map $url] } proc ::m::vcs::name-from-url {vcode url} { debug.m/vcs {} + upvar 1 $iv issues + set issues {} # Redirect through an external command. This command is currently # always `mirror-vcs VCS LOG url-to-name`. Operation ::m::vcs::OpComplete $vcode url-to-name \ @@ -514,11 +555,11 @@ # [ ] duration if {!$ok} { if {[llength $msg]} { lappend issues {*}$msg } if {[llength $results]} { lappend issues {*}$results } - E [join $issues \n] CHILD + return } else { set name [lindex $results 0] debug.m/vcs {--> $name} return $name } @@ -582,11 +623,11 @@ WHERE name = :x }] } if {$id eq {}} { - E "Invalid vcs code or name" INTERNAL + return -code error "Invalid vcs code or name" } return $id } @@ -617,14 +658,10 @@ set path [file normalize [file join [m state store] $dir]] debug.m/vcs {=> $path} return $path } -proc ::m::vcs::E {msg args} { - return -code error -errorcode [linsert $args 0 MIRROR VCS] $msg -} - # # ## ### ##### ######## ############# ##################### ## Background operations. Based on jobs. # ## Caller side # - Operation DONE VCS OP ... @@ -638,13 +675,10 @@ } proc ::m::vcs::OpWait {} { debug.m/vcs {} vwait ::m::vcs::opsresult - - #array set __ $::m::vcs::opsresult ; parray __ - return $::m::vcs::opsresult } proc ::m::vcs::OpCmd {vcs args} { debug.m/vcs {} Index: lib/web/site.tcl ================================================================== --- lib/web/site.tcl +++ lib/web/site.tcl @@ -24,11 +24,11 @@ package require m::asset package require m::db package require m::exec package require m::format package require m::futil -package require m::project +package require m::mset package require m::site package require m::state package require m::store package require m::vcs @@ -76,36 +76,25 @@ Export ;# (See `export`) Search Submit Stores - # Statistics page - # - cycle information (start, end, duration, last duration) - # - number of projects, repos, stores - # - min, max, average, median n.commits, size.kb - # Project list - # repos, link to details - # Project details - repo list, store links! - - # constrained lists -- - # -- just primaries, no forks - # -- per VCS, just managed by such - set bytime [m store updates] set byname [m store by-name] set bysize [m store by-size] set byvcs [m store by-vcs] set issues [m store issues] ;# excludes disabled set disabled [m store disabled] - dict set stats issues [llength $issues] - dict set stats disabled [llength $disabled] - dict set stats size [m store total-size] - dict set stats nrepos [m repo count] - dict set stats nprojects [m project count] - dict set stats nstores [m store count] - dict set stats ccycle [m state start-of-current-cycle] - dict set stats pcycle [m state start-of-previous-cycle] + dict set stats issues [llength $issues] + dict set stats disabled [llength $disabled] + dict set stats size [m store total-size] + dict set stats nrepos [m repo count] + dict set stats nmsets [m mset count] + dict set stats nstores [m store count] + dict set stats ccycle [m state start-of-current-cycle] + dict set stats pcycle [m state start-of-previous-cycle] List "By Last Change" index.md $bytime $stats List "By Name, VCS, Size" index_name.md $byname $stats List "By Size, Name, VCS" index_size.md $bysize $stats List "By VCS, Name, Size" index_vcs.md $byvcs $stats @@ -131,134 +120,28 @@ return } proc ::m::web::site::Stores {} { debug.m/web/site {} - - foreach {project name} [m project all] { - foreach store [m project stores $project] { - Store $project $name $store + foreach {mset mname} [m mset all] { + foreach store [m mset stores $mset] { + Store $mset $mname $store } } return } -proc ::m::web::site::RLink {repo {follow 1}} { - debug.m/web/site {} - - set ri [m repo get $repo] - dict with ri {} - # active, issues, url, store - - set active [expr {$active ? "" : "[I images/off.svg "Offline"]"}] - set issues [expr {!$issues ? "" : "[I images/bad.svg "Attend"]"}] - if {!$follow} { set origin {} } - if {$origin ne {}} { - set origin " a [ForkLogo] from [OLink $origin]" - } - set label $active$issues$url - - return [LB $url $label]$origin -} - -proc ::m::web::site::OLink {repo} { - debug.m/web/site {} - - set ri [m repo get $repo] - dict with ri {} - # active, issues, url, store - - set active [expr {$active ? "" : "[I images/off.svg "Offline"]"}] - set issues [expr {!$issues ? "" : "[I images/bad.svg "Attend"]"}] - set label $active$issues$url - - return [LB store_${store}.html $label] -} - -proc ::m::web::site::StatsTime {min_sec max_sec win_sec} { - debug.m/web/site {} - - # See also ::m::repo::times, ::m::glue::StatsTime - - set min_sec [expr {$min_sec < 0 ? "+Inf" : [m format interval $min_sec]}] - set max_sec [m format interval $max_sec] - set spent "$min_sec ... $max_sec" - set win_sec [m format win $win_sec] - set n [llength $win_sec] - if {$n} { - set win_sec [m format win-trim $win_sec [m state store-window-size]] - set total [expr [join $win_sec +]] - set avg [m format interval [format %.0f [expr {double($total)/$n}]]] - append spent " \[avg $avg (over $n)]" - } - return $spent -} - -proc ::m::web::site::Commits {commits commitp} { - debug.m/web/site {} - - if {$commitp != $commits} { - set delta [expr {$commits - $commitp}] - if {$delta > 0} { - set delta +$delta - } - append commits " ($commitp ($delta))" - } - return $commits -} - -proc ::m::web::site::Size {size sizep} { - debug.m/web/site {} - - set dsize [m format size $size] - if {$sizep != $size} { - set dsizep [m format size $sizep] - if {$size < $sizep} { - # shrink - set delta -[m format size [expr {$sizep - $size}]] - } else { - # grow - set delta +[m format size [expr {$size - $sizep}]] - } - append dsize " ($dsizep ($delta))" - } - return $dsize -} - -proc ::m::web::site::ExportStore {vcs store} { - debug.m/web/site {} - - set export [m vcs export $vcs $store] - if {$export ne {}} { - set path external/local_${store} - WX static/$path $export - set export [LB $path {Local Site}] - } - - return $export -} - -proc ::m::web::site::StoreForks {pname url store serial forks} { - debug.m/web/site {} - - set series [m store getx $forks] - set page store_${store}_forks_${serial} - set up [LB store_${store}.html $url] - set title "[llength $forks] [ForkLogo] of $up" - - ListSimple $pname $title $page.md $series - return ${page}.html -} - -proc ::m::web::site::Store {project pname store} { +proc ::m::web::site::Store {mset mname store} { debug.m/web/site {} # Get page pieces ... - - set urls [m store remotes $store] - set repos [lmap u $urls { m repo id $u }] - set links [lmap r $repos { RLink $r }] + + lassign [m store remotes $store] remotes plugin + lappend r Remotes $remotes + if {[llength $plugin]} { + lappend r {*}$plugin + } set sd [m store get $store] dict with sd {} # -> size, sizep # commits, commitp @@ -270,59 +153,70 @@ # attend # active # remote # min_sec, max_sec, win_sec - set spent [StatsTime $min_sec $max_sec $win_sec] + set min_sec [expr {$min_sec < 0 ? "+Inf" : [m format interval $min_sec]}] + set max_sec [m format interval $max_sec] + + set spent "$min_sec ... $max_sec" + + set win_sec [split [string trim $win_sec ,] ,] + set n [llength $win_sec] + if {$n} { + set maxn [m state store-window-size] + if {$n > $maxn} { + set over [expr {$n - $maxn}] + set win_sec [lreplace $win_sec 0 ${over}-1] + set n [llength $win_sec] + } + set total [expr [join $win_sec +]] + set avg [m format interval [format %.0f [expr {double($total)/$n}]]] + append spent " ($avg * $n)" + } + + set simg [StatusRefs $attend $active $remote] lassign [m vcs caps $store] stdout stderr set logo [T "Operation" $stdout] set loge [T "Notes & Errors" $stderr] - set commits [Commits $commits $commitp] - set dsize [Size $size $sizep] - set export [ExportStore $vcs $store] - set vcslogo [VCSLogo [m vcs code $vcs] $vcsname] - + if {$commitp != $commits} { + set delta [expr {$commits - $commitp}] + if {$delta > 0} { + set delta +$delta + } + append commits " ($commitp ($delta))" + } + + set dsize [m format size $size] + if {$sizep != $size} { + set dsizep [m format size $sizep] + if {$size < $sizep} { + # shrink + set delta -[m format size [expr {$sizep - $size}]] + } else { + # grow + set delta +[m format size [expr {$size - $sizep}]] + } + append dsize " ($dsizep ($delta))" + } + + set export [m vcs export $vcs $store] + if {$export ne {}} { + set f external/local_${store} + WX static/$f $export + set export [LB $f {Local Site}] + } + # Assemble page ... - append text [H $pname] + append text [H $mname] append text |||| \n - append text |---|---:|---| \n - - if {![llength $urls]} { - R $vcslogo {} {} - } else { - set threshold 5 - - set left $vcslogo - foreach r $repos l $links u $urls { - R $left {} $l - set left {} - - # For each repo show the forks, up to a threshold. If - # there are more than that a separate page is created for - # the list and linked. - - set forks [m repo forks $r] - set nforks [llength $forks] - if {$nforks} { - incr m - set links [lmap f $forks { OLink $f }] - foreach link $links { - R {} [ForkLogo] $link - incr k - if {$k < $threshold} continue - set more [expr {$nforks - $threshold}] - R {} {} [LB [StoreForks $pname $u $store $m $forks] "+ $more more"] - break - } - unset k - } - } - } - + append text |---|---|---| \n + + R $simg {} "[IH 32 images/logo/[m vcs code $vcs].svg $vcsname] $vcsname" R Size {} $dsize R Commits {} $commits if {$export ne {}} { R {} {} $export } @@ -329,18 +223,37 @@ R {Update Stats} {} $spent R {Last Change} {} [m format epoch $changed] R {Last Check} {} [set lc [m format epoch $updated]] R Created {} [m format epoch $created] + set active 1 + foreach {label urls} $r { + R $label {} + foreach url [lsort -dict $urls] { + incr id + set u [LB $url $url] + set a {} + if {$active} { + set a [dict get [m repo get [m repo id $url]] active] + if {$a} { + set a "" ;#[I images/ok.svg " "] + } else { + set a [I images/off.svg "-"] + } + } + R ${id}. $a $u + } + unset -nocomplain id + incr active -1 + } append text \n append text "## Messages as of last check on $lc" \n\n append text $logo \n append text $loge \n append text \n append text [F] - W pages/store_${store}.md $text return } proc ::m::web::site::Contact {} { @@ -349,125 +262,64 @@ append text [F] W pages/contact.md $text return } -proc ::m::web::site::ListSimple {title subtitle page series} { - # A cut down form of `List`. No sorting. No other stats. - - debug.m/web/site {} - - set hvcs VCS - set hsize Size - set hname Project - set hchan Changed - - append text [H $title] - append text $subtitle \n - append text \n - - append text "||$hname|Repository||$hvcs|$hsize|$hchan|Updated|Created|" \n - append text "|---|---|---|---|---|---:|---|---|---|" \n - - set fork [ForkLogo] - - set mname {} - set last {} - foreach row $series { - dict with row {} - - # store mname vcode changed updated created size active remote attend - # -- origin url - set tag {} - - if {$created eq "."} { - append text "||||||||||" \n - continue - } - - set img [StatusRefs $attend $active $remote] - set size [m format size $size] - set changed [m format epoch $changed] - set updated [m format epoch $updated] - set created [m format epoch $created] - - set vcode [VCSLogo $vcode $vcode] - set vcode [LB store_${store}.html $vcode] - - if {$mname ne {}} { set mname [LB store_${store}.html $mname] } - set url [LB store_${store}.html $url] - if {$origin ne {}} { append tag $fork } - - append text "|$img|$mname|$url|$tag|$vcode|$size|$changed|$updated|$created|" \n - set last $mname - } - append text \n\n - - append text [F] - W pages/$page $text - return -} - proc ::m::web::site::List {suffix page series stats} { debug.m/web/site {} - + dict with stats {} # issues # disabled # size # nrepos - # nprojects + # nmsets # nstores # ccycle # pcycle append text [H "Index ($suffix)"] - set hvcs [L index_vcs.html VCS ] - set hsize [L index_size.html Size ] - set hname [L index_name.html Project ] - set hchan [L index.html Changed ] - set issues [L index_issues.html "Issues: $issues" ] + set hvcs [L index_vcs.html VCS ] + set hsize [L index_size.html Size ] + set hname [L index_name.html {Mirror Set} ] + set hchan [L index.html Changed ] + set issues [L index_issues.html "Issues: $issues" ] set disabled [L index_disabled.html "Disabled: $disabled" ] - + set ccf [m format epoch $ccycle] set pcf [m format epoch $pcycle] set dt [expr {$ccycle - $pcycle}] set dtf [m format interval $dt] - append text "Projects: " $nprojects , + append text "Sets: " $nmsets , append text " Repos: " $nrepos , append text " Stores: " $nstores , append text " Size: " [m format size $size] , append text " " $issues , \n append text " " $disabled \n append text \n append text "Cycles: Current began __" $ccf "__, " append text "Last began __" $pcf "__, taking __" $dtf "__" \n append text \n - append text "||$hname|Repository||$hvcs|$hsize|$hchan|Updated|Created|" \n - append text "|---|---|---|---|---|---:|---|---|---|" \n + append text "||$hname|$hvcs|$hsize|$hchan|Updated|Created|" \n + append text "|---|---|---|---:|---|---|---|" \n # Disable insertion of cycle flags for all tables but sorted by change. if {$page ne "index.md"} { set pcycle -1 set ccycle -1 } - - set fork [ForkLogo] - + set mname {} set last {} foreach row $series { dict with row {} - # store mname vcode changed updated created size active remote attend - # -- origin url - set tag {} if {$created eq "."} { - append text "||||||||||" \n + append text "||||||||" \n continue } if {$changed ne {}} { if {$changed < $ccycle} { @@ -484,40 +336,29 @@ set size [m format size $size] set changed [m format epoch $changed] set updated [m format epoch $updated] set created [m format epoch $created] - set vcode [VCSLogo $vcode $vcode] + set vcode "[IH 32 images/logo/${vcode}.svg $vcode] $vcode" set vcode [LB store_${store}.html $vcode] - if {$mname ne {}} { set mname [LB store_${store}.html $mname] } - set url [LB store_${store}.html $url] - if {$origin ne {}} { append tag $fork } - - append text "|$img|$mname|$url|$tag|$vcode|$size|$changed|$updated|$created|" \n + if {$mname ne {}} { + set mname [LB store_${store}.html $mname] + } + append text "|$img|$mname|$vcode|$size|$changed|$updated|$created|" \n set last $mname } append text \n\n append text [F] W pages/$page $text return } -proc ::m::web::site::VCSLogo {vcode vcsname} { - debug.m/web/site {} - return "[IH 32 images/logo/$vcode.svg $vcsname] $vcsname" -} - -proc ::m::web::site::ForkLogo {} { - debug.m/web/site {} - IH 32 images/fork.svg Fork -} - proc ::m::web::site::Export {} { debug.m/web/site {} - W static/spec.txt [m project spec] + W static/spec.txt [m mset spec] return } proc ::m::web::site::Search {} { debug.m/web/site {} @@ -606,18 +447,20 @@ proc ::m::web::site::Sync {} { debug.m/web/site {} # Data flows # - Main - # - repo_pending local, no sync + # - mset_pending local, no sync # - reply local, no sync # - rolodex local, no sync # - schema local, no sync # - # - project [1] join/view pushed to site - # - repository [1] store_index, total replacement + # - mirror_set [1] join/view pushed to site + # - name [1] store_index, total replacement + # - repository [1] # - store [1] + # - store_times [1] # - version_control_system [1], plus copy to vcs # # - rejected push to site rejected, total replacement # - submission pull from site (insert or update) # - submission_handled push to site, deletions in submission @@ -778,65 +621,68 @@ m site eval { DELETE FROM store_index } # m store search '' (inlined, simply all) m db eval { SELECT S.id AS store - , (SELECT max (P.name) FROM project P, repository R WHERE P.id = R.project AND R.store = S.id) AS pname + , N.name AS mname , V.code AS vcode - , S.changed AS changed - , S.updated AS updated - , S.created AS created - , (SELECT sum (has_issues) FROM repository R WHERE R.store = S.id) AS attend + , T.changed AS changed + , T.updated AS updated + , T.created AS created + , T.attend AS attend , S.size_kb AS size - , (SELECT count (*) FROM repository R WHERE R.store = S.id) AS remote - , (SELECT sum (is_active) FROM repository R WHERE R.store = S.id) AS active - FROM store S + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs) AS remote + , (SELECT count (*) + FROM repository R + WHERE R.mset = S.mset + AND R.vcs = S.vcs + AND R.active) AS active + FROM store_times T + , store S + , mirror_set M , version_control_system V - WHERE S.vcs = V.id + , name N + WHERE T.store = S.id + AND S.mset = M.id + AND S.vcs = V.id + AND M.name = N.id } { - # store, pname, vcode, changed, updated, created, size, remote, active, attend + # store, mname, vcode, changed, updated, created, size, remote, active, attend set page store_${store}.html set status [StatusIcons $attend $active $remote] set remotes [m db eval { SELECT R.url FROM repository R , store S WHERE S.id = :store - AND S.id = R.store + AND S.vcs = R.vcs + AND S.mset = R.mset }] - lappend remotes $pname + lappend remotes $mname set remotes [string tolower [join $remotes { }]] # We are using the remotes field for the entire text we can # search over. Should rename the field, not bothering until # we need a larger schema change it can be folded into. m site eval { INSERT INTO store_index VALUES ( NULL, - :pname, :vcode, :page, :remotes, :status, + :mname, :vcode, :page, :remotes, :status, :size, :changed, :updated, :created ) } } # Copy the VCS information - # Logically this ... - if 0 {m site eval { - DELETE FROM vcs - ; - INSERT INTO VCS - SELECT id, code, name - FROM version_control_system - }} - - # It is done like below because we are operating on two databases - # here. And it is simpler than to attach/detach one of the - # databases into the other connection. m site eval { DELETE FROM vcs } + m db eval { SELECT id , code , name FROM version_control_system @@ -1300,9 +1146,5 @@ static/images/ok.svg static/images/bad.svg static/images/off.svg static/images/yellow.svg -static/images/fork.svg - - -