ADDED TODO.md Index: TODO.md ================================================================== --- /dev/null +++ TODO.md @@ -0,0 +1,45 @@ + +--- + +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,8 +1,9 @@ #!/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,8 +1,9 @@ #!/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,49 +1,48 @@ - -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) ADDED doc/schema-v2-issues.md Index: doc/schema-v2-issues.md ================================================================== --- /dev/null +++ doc/schema-v2-issues.md @@ -0,0 +1,36 @@ + +# 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. ADDED doc/schema-v2.md Index: doc/schema-v2.md ================================================================== --- /dev/null +++ doc/schema-v2.md @@ -0,0 +1,175 @@ +# 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 | ADDED doc/schema-v3.md Index: doc/schema-v3.md ================================================================== --- /dev/null +++ doc/schema-v3.md @@ -0,0 +1,240 @@ +# 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 | DELETED doc/schema.md Index: doc/schema.md ================================================================== --- doc/schema.md +++ /dev/null @@ -1,247 +0,0 @@ -# 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-mirror-set { - input mirror-set { - The mirror set to operate on. + common .optional-project { + input project { + The project to operate on. } { optional - validate [m::cmdr::vt mset] - generate [m::cmdr::call glue gen_current_mset] + validate [m::cmdr::vt project] + generate [m::cmdr::call glue gen_current_project] } } - common .list-optional-mirror-set { - input mirror-sets { - Repositories to operate on. - } { list ; optional ; validate [m::cmdr::vt mset] } + common .list-optional-project { + input projects { + Projects to operate on. + } { list ; optional ; validate [m::cmdr::vt project] } } 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 mirror sets processed per + Query/change the number of repositories processed per update cycle. } input take { - New number of mirror sets to process in one update. + New number of projects to process in one update. } { optional ; validate cmdr::validate::posint } } [m::cmdr::call glue cmd_take] private report { description { @@ -382,14 +382,17 @@ private add { use .cms description { Add repository. The new repository is placed into its own - mirror set. Command tries to auto-detect vcs type if not + project. 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] @@ -402,11 +405,11 @@ } input url { Location of the repository to add. } { validate [m::cmdr::vt url] } option name { - Name for the mirror set to hold the repository. + Name for the project to hold the repository. } { alias N validate str generate [m::cmdr::call glue gen_name] } @@ -413,46 +416,46 @@ } [m::cmdr::call glue cmd_add] private rename { use .cms description { - Change the name of the specified mirror set, or the mirror - set indicated by the current repository. + Change the name of the specified project, or + the project indicated by the current repository. The rolodex does not change. } - use .optional-mirror-set + use .optional-project input name { - New name for the mirror set. + New name for the project. } { validate str } } [m::cmdr::call glue cmd_rename] private merge { use .cms description { - Merges the specified mirror sets into a single mirror - set. When only one mirror set is specified the set of the + Merges the specified projects into a single project. + When only one project is specified the set of the current repository is used as the merge target. When no - mirror sets are specified at all the mirror sets of + projects are specified at all the projects of current and previous repositories are merged, using - the mirror set of current as merge target + the prooject of current as merge target - The name of the primary mirror set becomes the name of the + The name of the primary project becomes the name of the merge. The rolodex does not change. } - use .list-optional-mirror-set + use .list-optional-project } [m::cmdr::call glue cmd_merge] private split { use .cms description { - 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. + 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. If the referenced repository is a standalone already then nothing is done. } use .optional-repository @@ -467,27 +470,27 @@ alias @ private export { use .cms.ex description { - Write the known set of repositories and mirror sets to + Write the known set of repositories and projects 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 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. + 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. } option dated { - Add datestamp to the generated mirror sets. + Add datestamp to the generated projects. } { 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 } @@ -512,17 +515,17 @@ } [m::cmdr::call glue cmd_swap_current] private update { use .cms description { - 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. + 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. } - use .list-optional-mirror-set + use .list-optional-repository } [m::cmdr::call glue cmd_update] private updates { use .cms.in description { @@ -533,13 +536,13 @@ } [m::cmdr::call glue cmd_updates] private pending { use .cms.in description { - 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. + 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. } } [m::cmdr::call glue cmd_pending] private issues { use .cms.in @@ -576,11 +579,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 mirror set names. A search overrides + repository urls and project 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] @@ -641,11 +644,11 @@ Internal code, derived from the option value (database id). } { generate [m::cmdr::call glue gen_vcs_code] } option name { - Name for the future mirror set to hold the submitted repository. + Name for the future project to hold the submitted repository. } { alias N validate str generate [m::cmdr::call glue gen_name] } @@ -667,10 +670,13 @@ 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. @@ -682,11 +688,11 @@ Location of the repository. Taken from the submission. } { validate str generate [m::cmdr::call glue gen_submit_url] } option name { - Name for the mirror set to hold the repository. + Name for the project to hold the repository. Overrides the name from the submission. } { alias N validate str generate [m::cmdr::call glue gen_submit_name] @@ -952,15 +958,15 @@ description { Show the knowledge map used by the repository validator. } } [m::cmdr::call glue cmd_test_vt_repository] - private test-vt-mset { + private test-vt-project { description { - Show the knowledge map used by the mirror-set validator. + Show the knowledge map used by the project validator. } - } [m::cmdr::call glue cmd_test_vt_mset] + } [m::cmdr::call glue cmd_test_vt_project] 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::mset + package require m::project 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_mset {p} { +proc ::m::glue::gen_current_project {p} { debug.m/glue {[debug caller] | } - # Provide current as mirror set for operation when not specified + # Provide current as project 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 m [m repo mset $r] - if {$m ne {}} { - debug.m/glue {[debug caller] | --> $m } - return $m + set project [m repo project $r] + if {$project ne {}} { + debug.m/glue {[debug caller] | --> $project } + return $project } } 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::mset + package require m::project 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::mset + package require m::project package require m::repo - m msg [m mset spec] + m msg [m project 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::mset + package require m::repo 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 mset count-pending] pending/[m mset count] total)" + $t add Take "[m state take] ([m repo count-pending] pending/[m repo 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 ? "mirror set" : "mirror sets"}] + set g [expr {$n == 1 ? "project" : "projects"}] 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::mset + package require m::project package require m::repo package require m::rolodex package require m::store m db transaction { @@ -599,44 +599,51 @@ OK } proc ::m::glue::cmd_remove {config} { debug.m/glue {[debug caller] | } - package require m::mset + package require m::project package require m::repo package require m::rolodex package require m::store m db transaction { set repo [$config @repository] - 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 - + + 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 repo remove $repo - # 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 ..." + set siblings [m store remotes $store] + set nsiblings [llength $siblings] + if {!$nsiblings} { + m msg "- Removing unshared $vcode store $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 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 + # 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" } m rolodex drop $repo m rolodex commit } @@ -656,139 +663,211 @@ lappend r $line } join $r \n } -proc ::m::glue::cmd_details {config} { +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 debug.m/glue {[debug caller] | } - package require m::mset + package require m::project 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 {} - # -> 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 + #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 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] - - [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 + + 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 {}} { - $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 - } + $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]] + set nelines [llength [split $stderr \n]] + set nllines [llength [split $stdout \n]] - $t add Operation $nllines + 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 {}} { - $t add "Notes & Errors" [color bad $nelines] + $s add "Notes & Errors" [color bad $nelines] } else { - $t add "Notes & Errors" $nelines + $s add "Notes & Errors" $nelines } } else { - if {$stdout ne {}} { $t add Operation [L $stdout] } - if {$stderr ne {}} { $t add "Notes & Errors" [L $stderr] } + 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)" } + }] show } OK } proc ::m::glue::SI {stderr} { - if {$stderr eq {}} { - return [color good OK] - } else { - set status images/bad.svg - return [color bad ATTEND] - } + SIB [expr {$stderr eq {}}] +} + +proc ::m::glue::SIB {ok} { + color {*}[dict get { + 0 {bad ATTEND} + 1 {good OK} + } $ok] } proc ::m::glue::cmd_enable {flag config} { debug.m/glue {[debug caller] | } - package require m::mset + package require m::project package require m::repo package require m::rolodex package require m::store set op [expr {$flag ? "Enabling" : "Disabling"}] @@ -800,22 +879,21 @@ 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 - + # project: project id + # name : project name + # store : id of backing store for repo + m repo enable $repo $flag - # 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. + # 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. } } ShowCurrent $config SiteRegen @@ -822,64 +900,64 @@ OK } proc ::m::glue::cmd_rename {config} { debug.m/glue {[debug caller] | } - package require m::mset + package require m::project package require m::store m db transaction { - 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] + 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] 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 mset has $newname]} { + if {[m project has $newname]} { m::cmdr::error \ "New name [color note $newname] already present" \ HAVE_ALREADY NAME } - Rename $mset $newname + Rename $project $newname } ShowCurrent $config SiteRegen OK } proc ::m::glue::cmd_merge {config} { debug.m/glue {[debug caller] | } - package require m::mset + package require m::project package require m::repo package require m::rolodex package require m::store package require m::vcs m db transaction { - set msets [Dedup [MergeFill [$config @mirror-sets]]] + set msets [Dedup [MergeFill [$config @projects]]] # __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 mirror set." \ + "All repositories are already in the same project." \ NOP } set secondaries [lassign $msets primary] - m msg "Target: [color note [m mset name $primary]]" + m msg "Target: [color note [m project name $primary]]" foreach secondary $secondaries { - m msg "Merging: [color note [m mset name $secondary]]" + m msg "Merging: [color note [m project name $secondary]]" Merge $primary $secondary } } ShowCurrent $config @@ -887,62 +965,62 @@ OK } proc ::m::glue::cmd_split {config} { debug.m/glue {[debug caller] | } - package require m::mset + package require m::project 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 - # mset : mirror set id - # name : mirror set name - # store : store id, of backing store for the repo + # -> url : repo url + # vcs : vcs id + # vcode : vcs code + # project: project id + # name : project name + # store : id of backing store for 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 " Mirror set [color note $name]" + m msg " Project [color note $name]" - if {[m mset size $mset] < 2} { + if {[m project size $mset] < 2} { m::cmdr::error \ - "The mirror set is to small for splitting" \ + "The project is to small for splitting" \ ATOMIC } - set newname [MakeName $name] - set msetnew [m mset add $newname] + set newname [MakeName $name] + set projectnew [m project add $newname] m msg "New" - m msg " Mirror set [color note $newname]" + m msg " Project [color note $newname]" - m repo move/1 $repo $msetnew + m repo move/1 $repo $projectnew - if {![m mset has-vcs $mset $vcs]} { + if {![m project has-vcs $mset $vcs]} { # The moved repository was the last user of its vcs in the - # original mirror set. We can simply move its store over + # original project. We can simply move its store over # to the new holder to be ok. m msg " Move store ..." - m store move $store $msetnew + m store move $store $projectnew } 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 $msetnew + m store cleave $store $projectnew } } ShowCurrent $config SiteRegen @@ -984,71 +1062,109 @@ OK } proc ::m::glue::cmd_update {config} { debug.m/glue {[debug caller] | } - package require m::mset + package require m::project 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 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" - } + 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 } } } SiteRegen @@ -1058,38 +1174,47 @@ 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 + # store mname vcode changed updated created size active + # remote sizep commits commitp mins maxs lastn url origin + 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] - lappend series [list $mname $vcode $dsize $dcommit $lastn $changed $updated $created] + if {$origin eq {}} { set url [color bg-cyan $url] } + + lappend series [list $url $vcode $dsize $dcommit $lastn $changed $updated $created] } } lassign [TruncW \ - {{Mirror Set} VCS Size Commits Time Changed Updated Created} \ - {1 0 0 0 0 0 0 0} \ + {Project 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 { @@ -1099,39 +1224,44 @@ OK } proc ::m::glue::cmd_pending {config} { debug.m/glue {[debug caller] | } - package require m::mset + package require m::project package require m::state set tw [$config @tw] set th [$config @th] ; incr th -1 ;# Additional line before the table (counts). - set nmset [m mset count] - set npending [m mset count-pending] - + set nrepo [m repo count] + set npending [m repo count-pending] + m db transaction { set series {} set take [m state take] - foreach {mname numrepo} [m mset pending] { + + foreach {pname url origin nforks} [m repo pending] { + if {$origin eq {}} { set url [color bg-cyan $url] } + set row {} if {$take} { - lappend series [list * $mname $numrepo] + lappend row * incr take -1 } else { - lappend series [list {} $mname $numrepo] + lappend row {} } + lappend row $url $nforks $pname + lappend series $row } } lassign [TruncW \ - {{} {Mirror Set} #Repositories} \ - {0 1 0} \ + {{} Repository Forks Project} \ + {0 0 0 1} \ [TruncH $series $th] $tw] \ titles series - puts @[color note $npending]/$nmset + puts @[color note $npending]/$nrepo [table t $titles { foreach row $series { $t add {*}$row } }] show @@ -1138,31 +1268,28 @@ OK } proc ::m::glue::cmd_issues {config} { debug.m/glue {[debug caller] | } - package require m::mset + package require m::project package require m::repo package require m::rolodex package require m::store m db transaction { set series {} - foreach row [m store issues] { + foreach row [m store issues] { ;# XXX rework actually repo issues dict with row {} - # store mname vcode changed updated created size active remote + # store mname vcode changed updated created size active remote rid url set size [m format size $size] - # 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 - } - } + 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] set table {} foreach row $series { @@ -1174,12 +1301,12 @@ if {$n == 0} { lappend tag @c } lappend table [list $tag {*}$row] } } lassign [TruncW \ - {Tag Repository Set VCS Size} \ - {0 1 3 0 0} \ + {Tag Repository Project VCS Size} \ + {0 0 1 0 0} \ $table [$config @tw]] \ titles series [table t $titles { foreach row $series { $t add {*}[C $row 1 note] ;# 1 => url @@ -1188,22 +1315,24 @@ OK } proc ::m::glue::cmd_disabled {config} { debug.m/glue {[debug caller] | } - package require m::mset + package require m::project package require m::repo package require m::rolodex package require m::store m db transaction { set series {} - foreach row [m store disabled] { + foreach row [m store disabled] { # XXX REWORK actually repo state dict with row {} - # store mname vcode changed updated created size active remote attend rid url + # store mname vcode changed updated created size active remote attend rid url origin 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] @@ -1218,12 +1347,12 @@ if {$n == 0} { lappend tag @c } lappend table [list $tag {*}$row] } } lassign [TruncW \ - {Tag Repository Set VCS Size} \ - {0 1 3 0 0} \ + {Tag Repository Project VCS Size} \ + {0 0 1 0 0} \ $table [$config @tw]] \ titles series [table t $titles { foreach row $series { $t add {*}[C $row 1 note] ;# 1 => url @@ -1247,13 +1376,19 @@ # 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 + unset name url vcs vcode store ri project } else { set first [m state top] debug.m/glue {from state: $first} } set limit [$config @limit] @@ -1264,48 +1399,50 @@ lassign [m repo get-n $first $limit] next series debug.m/glue {next ($next)} m state top $next } - # series = list (dict (mset url rid vcode sizekb active sizep commits commitp mins maxs lastn)) + # series = list (dict (primary name 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 {} - # name url id vcode sizekb active sizep commits commitp mins maxs lastn + # primary 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 Set VCS Size Commits Time} \ - {0 0 1 2 0 -1 -1 0} \ + {Tag {} Repository Project VCS Size Commits Time} \ + {0 0 0 1 0 -1 -1 0} \ $table [$config @tw]] \ titles series [table t $titles { foreach row $series { $t add {*}[C $row 2 note] ;# 2 => url @@ -1369,11 +1506,11 @@ lappend series [list $id $when $url $vcode $desc $email $submitter] } } lassign [TruncW \ {{} When Url VCS Description Email Submitter} \ - {0 0 2 0 3 0 1} \ + {0 0 0 0 3 0 1} \ $series [$config @tw]] \ titles series [table t $titles { foreach row $series { $t add {*}[C $row 2 note] ;# 2 => url @@ -1392,11 +1529,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 @@ -1410,11 +1547,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] @@ -1452,11 +1589,11 @@ OK } proc ::m::glue::cmd_accept {config} { debug.m/glue {[debug caller] | } - package require m::mset + package require m::project package require m::repo package require m::rolodex package require m::store package require m::submission package require m::mail::generator @@ -1607,20 +1744,25 @@ 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 - m mailer to [$config @destination] [m mail generator test] - OK + try { + m mailer to [$config @destination] [m mail generator test] + } on error {e o} { + m msg [color bad $e] + exit + } + OK } proc ::m::glue::cmd_test_vt_repository {config} { debug.m/glue {[debug caller] | } package require m::repo @@ -1627,25 +1769,25 @@ set map [m repo known] [table/d t { foreach k [lsort -dict [dict keys $map]] { set v [dict get $map $k] - $t add $k $v + $t add $v $k } }] show OK } -proc ::m::glue::cmd_test_vt_mset {config} { +proc ::m::glue::cmd_test_vt_project {config} { debug.m/glue {[debug caller] | } - package require m::mset + package require m::project - set map [m mset known] + set map [m project known] [table/d t { foreach k [lsort -dict [dict keys $map]] { set v [dict get $map $k] - $t add $k $v + $t add $v $k } }] show OK } @@ -1655,11 +1797,11 @@ set map [m reply known] [table/d t { foreach k [lsort -dict [dict keys $map]] { set v [dict get $map $k] - $t add $k $v + $t add $v $k } }] show OK } @@ -1669,11 +1811,11 @@ set map [m submission known] [table/d t { foreach k [lsort -dict [dict keys $map]] { set v [dict get $map $k] - $t add $k $v + $t add $v $k } }] show OK } @@ -1743,18 +1885,20 @@ 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) + # command :: list ('M' name) - old: 'M'irrorset + # | list ('P' name) - new: 'P'roject # | list ('R' vcode url) } proc ::m::glue::ImportVerify {commands} { debug.m/glue {} # commands :: list (command) - # command :: list ('M' name) + # command :: list ('M' name) - old: 'M'irrorset + # | list ('P' name) - new: 'P'roject # | list ('R' vcode url) m msg "Verifying ..." foreach {code name} [m vcs all] { @@ -1778,11 +1922,12 @@ # skip empty lines if {$command eq {}} continue lassign $command cmd a b switch -exact -- $cmd { - M { + M - + P { Ping " $command" # M name --> a = name, b = ((empty string)) if {[llength $command] != 2} { lappend msg "Line [format $lfmt $lno]: Bad syntax: $command" } @@ -1873,11 +2018,11 @@ lappend x $resolved lappend repo $vcs $resolved } M { if {![llength $repo]} { - m msg "Line $lno: [color warning Skip] empty mirror set [color note $vcs]" + m msg "Line $lno: [color warning Skip] empty project [color note $vcs]" set repo {} continue } foreach r $x { dict lappend seen $r $vcs } ;# vcs = mname unset x @@ -1926,28 +2071,28 @@ proc ::m::glue::Import1 {date mname repos} { debug.m/glue {[debug caller] | } # repos = list (vcode url ...) - m msg "Handling [color note $mname] ..." + m msg "Handling project [color note $mname] ..." if {[llength $repos] == 2} { lassign $repos vcode url - # The mirror set contains only a single repository. + # The project contains only a single repository. # We might be able to skip the merge - if {![m mset has $mname]} { - # No mirror set of the given name exists. + if {![m project has $mname]} { + # No project 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 mset remove $mset + m project 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. } @@ -1954,27 +2099,27 @@ return } } # More than a single repository in this set, or the destination - # mirror set exists. Merging is needed. And the untrusted nature + # project 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 mirror set, like for `add`. - # Set names are of the form `import_`, plus a serial number. - # Comes with associated store. + # - 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. # # - 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 mirror set and its + # because each round finalizes at least one project and its # repositories of the finite supply. At the end of this phase we - # 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. + # 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. set serial 0 set r {} foreach {vcode url} $repos { try { @@ -1985,11 +2130,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 mset remove $mset + m project 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. } @@ -2000,13 +2145,13 @@ m msg "[color bad {Unable to import}] [color note $mname]: No repositories" return } set rename 1 - if {[m mset has $mname]} { - # Targeted mirror set exists. Make it first in the merge list. - set mset [m mset id $mname] + if {[m project has $mname]} { + # Targeted project exists. Make it first in the merge list. + set mset [m project id $mname] set repos [linsert $repos 0 dummy_vcode @$mname] dict set r @$mname [list dummy_vcs $mset dummy_store] set rename 0 } @@ -2039,12 +2184,12 @@ } if {![llength $unmatched]} break # Retry to merge the leftovers. Note, each iteration - # finalizes at least one mirror set, ensuring termination of - # the loop. + # finalizes at least one project, ensuring termination of the + # loop. set repos $unmatched set rename 1 } m rolodex commit @@ -2053,26 +2198,32 @@ proc ::m::glue::ImportMake1 {vcode url base} { debug.m/glue {[debug caller] | } set vcs [m vcs id $vcode] set tmpname [MakeName $base] - set mset [m mset add $tmpname] + set project [m project add $tmpname] set url [m vcs url-norm $vcode $url] - - 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] + 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] } proc ::m::glue::Add {config} { debug.m/glue {[debug caller] | } set url [Url $config] @@ -2088,42 +2239,123 @@ 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 " Mirror set [color note $name]" + m msg " Project [color note $name]" if {[m repo has $url]} { m::cmdr::error \ "Repository already present" \ HAVE_ALREADY REPOSITORY } - if {[m mset has $name]} { + if 0 {if {[m project 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" } - # 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]]" + lassign [AddStoreRepo $vcs $vcode $name $url $project] repo forks + + # ---------------------------------- Forks if {$forks ne {}} { - m msg " Github: Currently tracking [color note [llength $forks]] additional forks" - foreach f $forks { - m msg " - [color note $f]" + 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] +} proc ::m::glue::InvalE {label key} { set v [m state $key] return [list [Inval $label {$v ne {}}] $v] } @@ -2156,17 +2388,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 - # mset : mirror set id - # name : mirror set name - # store : store id, of backing store for the repo - + # -> url : repo url + # vcs : vcs id + # -> vcode : vcs code + # project: project id + # -> name : project name + # store : id of backing store for 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 @@ -2174,11 +2406,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 @@ -2193,16 +2425,21 @@ proc ::m::glue::OK {} { 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 mset has $prefix]} { return $prefix } + if {![m project has $prefix]} { return $prefix } set n 1 - while {[m mset has ${prefix}#$n]} { incr n } + while {[m project has ${prefix}#$n]} { incr n } return "${prefix}#$n" } proc ::m::glue::ComeAroundMail {width current newcycle} { debug.m/glue {[debug caller] | } @@ -2211,11 +2448,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 @@ -2226,51 +2463,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 {Mirror Set} Time Size Commits} \ - {0 0 1 0 0 0} \ + {Changed VCS Project 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 mirror sets which where + # Creates a mail reporting on all the projects 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 @@ -2279,38 +2516,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::UpdateSets {start now msets} { +proc ::m::glue::UpdateRepos {start now repos} { debug.m/glue {[debug caller] | } - set n [llength $msets] + set n [llength $repos] if {$n} { # The note below is not shown when the user explicitly - # specifies the mirror sets to process. Because that is + # specifies the repositories to process. Because that is # outside any cycle. - return $msets + return $repos } set take [m state take] - set nmset [m mset count] - set npending [m mset count-pending] + set nrepo [m repo count] + set npending [m repo count-pending] - m msg "In cycle started on [m format epoch $start]: $take/$npending/$nmset" + m msg "In cycle started on [m format epoch $start]: $take/$npending/$nrepo" # No repositories specified. - # Pull mirror sets directly from pending - return [m mset take-pending $take \ + # Pull repositories directly from pending + return [m repo take-pending $take \ ::m::glue::ComeAround $now] } proc ::m::glue::Dedup {values} { debug.m/glue {[debug caller] | } @@ -2328,11 +2565,11 @@ proc ::m::glue::MergeFill {msets} { debug.m/glue {[debug caller] | } set n [llength $msets] if {!$n} { - # No mirror sets. Use the mirror sets for current and previous + # No project. Use the projects for current and previous # repository as merge target and source set target [m rolodex top] if {$target eq {}} { m::cmdr::error \ @@ -2347,12 +2584,12 @@ } lappend msets [m repo mset $target] [m repo mset $origin] return $msets } if {$n == 1} { - # A single mirror set is the merge origin. Use the mirror set - # of the current repository as merge target. + # A single project is the merge origin. Use the project 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 @@ -2362,32 +2599,32 @@ return $msets } proc ::m::glue::Rename {mset newname} { debug.m/glue {[debug caller] | } - m mset rename $mset $newname + m project rename $mset $newname # TODO MAYBE: stuff cascading logic into `mset rename` ? - foreach store [m mset stores $mset] { + foreach store [m project stores $mset] { m store rename $store $newname } return } proc ::m::glue::Merge {target origin} { debug.m/glue {[debug caller] | } - # Target and origin are mirror sets. + # Target and origin are projects # # - 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 mset used-vcs $origin] + set vcss [m project 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. @@ -2412,12 +2649,12 @@ m store merge [m store id $vcs $target] $ostore } } # Move the repositories, drop the origin set, empty after the move - m repo move/mset $origin $target - m mset remove $origin + m repo move/project $origin $target + m project remove $origin return } proc ::m::glue::MailConfigShow {t {prefix {}}} { debug.m/glue {[debug caller] | } @@ -2555,12 +2792,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) @@ -2578,11 +2815,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 ?) } @@ -2594,21 +2831,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 } @@ -2615,47 +2852,53 @@ 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} continue + if {$w <= 0} { + debug.m/glue { ($col): skip } + 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 much chracters behind. + # Rounding may cause removed < over, leaving too many characters 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. @@ -2668,19 +2911,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 @@ -2702,11 +2945,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 @@ -2758,27 +3001,24 @@ 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 [split [string trim $lastn ,] ,] - set n [llength $lastn] - + set lastn [m format win $lastn] + set n [llength $lastn] if {!$n} { return $text } - - set maxn [m state store-window-size] - if {$n > $maxn} { - set over [expr {$n - $maxn}] - set lastn [lreplace $lastn 0 ${over}-1] - } + + set lastn [m format win-trim $lastn [m state store-window-size]] set n [llength $lastn] set total [expr [join $lastn +]] set avg [m format interval [format %.0f [expr {double($total)/$n}]]] - - append text " ($avg * $n)" + + append text " \[avg $avg (over $n)]" return $text } proc ::m::glue::DeltaSizeFull {current previous} { append text [m format size $current] @@ -2826,11 +3066,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} { @@ -2842,12 +3082,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,15 +612,154 @@ 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,10 +249,43 @@ 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 DELETED lib/logic/mset.tcl Index: lib/logic/mset.tcl ================================================================== --- lib/logic/mset.tcl +++ /dev/null @@ -1,341 +0,0 @@ -## -*- 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 ADDED lib/logic/project.tcl Index: lib/logic/project.tcl ================================================================== --- /dev/null +++ lib/logic/project.tcl @@ -0,0 +1,242 @@ +## -*- 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,10 +22,11 @@ # # ## ### ##### ######## ############# ###################### package require Tcl 8.5 package require m::state package require m::rolodex +package require m::format package require debug package require debug::caller # # ## ### ##### ######## ############# ###################### @@ -33,12 +34,14 @@ namespace export repo namespace ensemble create } namespace eval ::m::repo { namespace export \ - add remove enable move/mset move/1 has get name \ - known get-n mset search id count + 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 namespace ensemble create } # # ## ### ##### ######## ############# ###################### @@ -61,12 +64,12 @@ FROM repository } { dict set map [string tolower $url] $id } - # See also m::mset::known - # Note, different ids! repo, not mset + # See also m::project::known + # Note, different ids! repository, not project set c {} set p {} set id -1 foreach r [m rolodex get] { set p $c ; set c $r ; incr id @@ -84,17 +87,17 @@ return $map } proc ::m::repo::name {repo} { debug.m/repo {} - # TODO MAYBE - repo name - cache? + # TODO MAYBE - in-memory cache of mapping repo -> name return [m db onecolumn { - SELECT R.url || ' (: ' || M.name || ')' + SELECT R.url || ' (: ' || P.name || ')' FROM repository R - , mirror_set M + , project P WHERE R.id = :repo - AND M.id = R.mset + AND P.id = R.project }] } proc ::m::repo::has {url} { debug.m/repo {} @@ -120,61 +123,184 @@ SELECT count (*) FROM repository }] } -proc ::m::repo::add {vcs mset url} { +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 {} - m db eval { - INSERT - INTO repository - VALUES ( NULL, :url, :vcs, :mset, 1 ) + 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 + ) + } } return [m db last_insert_rowid] } -proc ::m::repo::mset {repo} { +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 mset [m db onecolumn { - SELECT mset + 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 }] - 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) - # - mirror set (id, and name) + # - project (id, and name) # - vcs (id, and code) # - store (id) # - active set details [m db eval { SELECT 'url' , R.url - , 'active' , R.active + , 'active' , R.is_active + , 'issues' , R.has_issues , 'vcs' , R.vcs , 'vcode' , V.code - , 'mset' , R.mset - , 'name' , M.name + , 'project', R.project + , 'name' , P.name , 'store' , S.id + , 'min_sec', min_duration + , 'max_sec', max_duration + , 'win_sec', window_duration + , 'checked', checked + , 'origin' , fork_origin FROM repository R - , mirror_set M + , project P , version_control_system V , store S - WHERE R.id = :repo - AND M.id = R.mset - AND V.id = R.vcs - AND S.vcs = R.vcs - AND S.mset = R.mset + WHERE R.id = :repo + AND P.id = R.project + AND V.id = R.vcs + AND S.id = R.store }] debug.m/repo {=> ($details)} return $details } @@ -183,40 +309,39 @@ debug.m/repo {} set sub [string tolower $substring] set series {} m db eval { - SELECT M.name AS name + SELECT P.name AS name + , R.fork_origin AS origin , R.url AS url , R.id AS rid , V.code AS vcode , S.size_kb AS sizekb - , R.active AS active - , T.min_seconds AS mins - , T.max_seconds AS maxs - , T.window_seconds AS lastn + , R.is_active AS active + , R.min_duration AS mins + , R.max_duration AS maxs + , R.window_duration AS lastn , S.size_previous AS sizep , S.commits_current AS commits , S.commits_previous AS commitp FROM repository R - , mirror_set M + , project P , version_control_system V , store S - , store_times T - WHERE M.id = R.mset + WHERE P.id = R.project AND V.id = R.vcs - AND S.mset = R.mset - AND S.vcs = R.vcs - AND S.id = T.store - ORDER BY M.name ASC + AND S.id = R.store + ORDER BY P.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 \ @@ -248,41 +373,40 @@ lassign $first mname uname set lim [expr {$n + 1}] set replist {} m db eval { - SELECT M.name AS name + SELECT P.name AS name + , R.fork_origin AS origin , R.url AS url , R.id AS rid , V.code AS vcode , S.size_kb AS sizekb - , R.active AS active - , T.min_seconds AS mins - , T.max_seconds AS maxs - , T.window_seconds AS lastn + , R.is_active AS active + , R.min_duration AS mins + , R.max_duration AS maxs + , R.window_duration AS lastn , S.size_previous AS sizep , S.commits_current AS commits , S.commits_previous AS commitp FROM repository R - , mirror_set M + , project P , version_control_system V , store S - , store_times T - WHERE M.id = R.mset + WHERE P.id = R.project AND V.id = R.vcs - AND S.mset = R.mset - AND S.vcs = R.vcs - AND S.id = T.store + AND S.id = R.store -- cursor start clause ... - AND ((M.name > :mname) OR - ((M.name = :mname) AND + AND ((P.name > :mname) OR + ((P.name = :mname) AND (R.url >= :uname))) - ORDER BY M.name ASC + ORDER BY P.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 \ @@ -321,59 +445,189 @@ 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 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 + 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 } # # ## ### ##### ######## ############# ###################### proc ::m::repo::FIRST {} { debug.m/repo {} # First known repository. - # Ordered by mirror set name, then url + # Ordered by project name, then url return [m db eval { - SELECT M.name + SELECT P.name , R.url FROM repository R - , mirror_set M - WHERE R.mset = M.id - ORDER BY M.name ASC + , project P + WHERE R.project = P.id + ORDER BY P.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,13 +32,14 @@ namespace export store namespace ensemble create } namespace eval ::m::store { namespace export \ - add remove move rename merge cleave update has check \ + add remove move rename merge cleave update has check path \ id vcs-name updates by-name by-size by-vcs move-location \ - get remotes total-size count search issues disabled path + get getx repos remotes total-size count search issues disabled \ + has-issues namespace ensemble create } # # ## ### ##### ######## ############# ###################### @@ -45,39 +46,29 @@ debug level m/store debug prefix m/store {[debug caller] | } # # ## ### ##### ######## ############# ###################### -proc ::m::store::add {vcs mset name url} { +proc ::m::store::add {vcs name url} { debug.m/store {} - - 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] + + 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] } 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 } @@ -102,50 +93,32 @@ m vcs cleave $vcs $store $new $name Size $new return } -proc ::m::store::update {store cycle now} { - debug.m/store {} - - 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::has-issues {store} { + return [expr {[lindex [m vcs caps $store] 1] ne {}}] +} + +proc ::m::store::update {primary url store cycle now before} { + 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] } proc ::m::store::move {store msetnew} { debug.m/store {} # copy of `m mset name` - outline? check for dependency circles @@ -196,51 +169,87 @@ 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 {} - m db eval { + set details [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' , 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 + , '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) FROM store S - , store_times T , version_control_system V WHERE S.id = :store - AND T.store = S.id - AND V.id = S.vcs - } + AND S.vcs = V.id + }] + debug.m/store {=> ($details)} + return $details } proc ::m::store::remotes {store} { debug.m/store {} - set vcs [VCS $store] - lappend r [Remotes $store] ;# Database - lappend r [m vcs remotes $vcs $store] ;# Plugin supplied - return $r + 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 + }] } proc ::m::store::vcs-name {store} { debug.m/store {} return [m db onecolumn { @@ -267,40 +276,36 @@ 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 - , 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 + 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 - , mirror_set M + , project P , 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 { @@ -309,119 +314,114 @@ Srow series ;# upvar column variables } return $series } -proc ::m::store::issues {} { +proc ::m::store::issues {} { ;# XXX REWORK move to repo package debug.m/store {} + # List repositories ... + set series {} set last {} m db eval { - 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 + 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 - , mirror_set M + , project P , version_control_system V - 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 + 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 ORDER BY mname ASC , vcode ASC , size ASC } { - Srow series ;# upvar column variables + Srow+origin series ;# upvar column variables } return $series } -proc ::m::store::disabled {} { +proc ::m::store::disabled {} { ;# XXX REWORK move to repo package debug.m/store {} + # List repositories ... + set series {} set last {} m db eval { - 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 + 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 , store S - , mirror_set M + , project P , version_control_system V - , 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 + WHERE R.store = S.id + AND R.is_active = 0 -- Flag for disabled + AND R.project = P.id + AND R.vcs = V.id ORDER BY mname ASC , vcode ASC , size ASC } { Srow+rid+url series ;# upvar column variables } return $series } -proc ::m::store::by-name {} { +proc ::m::store::by-name {} { ;# XXX REWORK move to repo package debug.m/store {} + # List stores ... + set series {} set last {} m db eval { - 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 + 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 , store S - , mirror_set M + , project P , version_control_system V - WHERE T.store = S.id - AND S.mset = M.id - AND S.vcs = V.id + WHERE R.store = S.id + AND R.project = P.id + AND R.vcs = V.id ORDER BY mname ASC , vcode ASC , size ASC } { if {($last ne {}) && ($last ne $mname)} { @@ -433,90 +433,86 @@ set last $saved } return $series } -proc ::m::store::by-vcs {} { +proc ::m::store::by-vcs {} { ;# XXX REWORK move to repo package debug.m/store {} + # List repositories ... + set series {} m db eval { - 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 + 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 , store S - , mirror_set M + , project P , version_control_system V - WHERE T.store = S.id - AND S.mset = M.id - AND S.vcs = V.id + WHERE R.store = S.id + AND R.project = P.id + AND R.vcs = V.id ORDER BY vcode ASC , mname ASC , size ASC } { Srow series } return $series } -proc ::m::store::by-size {} { +proc ::m::store::by-size {} { ;# XXX REWORK move to repo package debug.m/store {} + # List repositories ... + set series {} m db eval { - 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 + 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 , store S - , mirror_set M + , project P , version_control_system V - WHERE T.store = S.id - AND S.mset = M.id - AND S.vcs = V.id + WHERE R.store = S.id + AND R.project = P.id + AND R.vcs = V.id ORDER BY size DESC , mname ASC , vcode ASC } { Srow series } return $series } -proc ::m::store::updates {} { +proc ::m::store::updates {} { ;# XXX REWORK move to repo package debug.m/store {} - # From the db.tcl notes on store_times + # List repositories ... + + # From the db.tcl notes on store times # # 1. created <= changed <= updated # 2. (created == changed) -> never changed. set series {} @@ -523,42 +519,37 @@ # Block 1: Changed stores, changed order descending # Insert separators when `updated` changes. set last {} m db eval { - 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 + 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 , S.size_previous AS sizep , S.commits_current AS commits , S.commits_previous AS commitp - FROM store_times T + , R.fork_origin AS origin + , R.url AS url + FROM repository R , store S - , mirror_set M + , project P , version_control_system V - 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 + 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 } { if {($last ne {}) && ($last != $updated)} { Sep series } Srow+delta series @@ -569,42 +560,37 @@ 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 - , 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 + 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 , S.size_previous AS sizep , S.commits_current AS commits , S.commits_previous AS commitp - FROM store_times T + , R.fork_origin AS origin + , R.url AS url + FROM repository R , store S - , mirror_set M + , project P , version_control_system V - 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 + 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 } { if {$first} { Sep series } set changed {} set updated {} Srow+delta series @@ -621,46 +607,81 @@ return } # # ## ### ##### ######## ############# ###################### -proc ::m::store::Srow {sv} { +proc ::m::store::Srow {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 + + 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} + + 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 + 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} + 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] + attend $attend \ + origin $origin + ] lappend series $row return } -proc ::m::store::Srow+delta {sv} { +proc ::m::store::Srow+delta {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 \ sizep sizep commits commits commitp commitp mins mins \ - maxs maxs lastn lastn + maxs maxs lastn lastn origin origin 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 \ @@ -678,19 +699,19 @@ ] lappend series $row return } -proc ::m::store::Srow+rid+url {sv} { +proc ::m::store::Srow+rid+url {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 \ - rid rid url url + 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} + 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} set row [dict create \ store $store \ mname $mname \ vcode $vcode \ @@ -700,16 +721,17 @@ size $size \ remote $remote \ active $active \ attend $attend \ rid $rid \ - url $url ] + url $url \ + origin $origin ] lappend series $row return } -proc ::m::store::Sep {sv} { +proc ::m::store::Sep {sv} { ;# XXX REWORK move to repo package debug.m/store {} upvar 1 $sv series lappend series { store . mname . vcode . changed . updated . created . size . active . @@ -725,59 +747,62 @@ if {$onlyactive} { return [m db eval { SELECT R.url FROM repository R , store S - WHERE S.id = :store - AND R.vcs = S.vcs - AND R.mset = S.mset - AND R.active + WHERE S.id = :store + AND R.store = S.id + AND R.is_active }] } return [m db eval { SELECT R.url FROM repository R , store S - WHERE S.id = :store - AND R.vcs = S.vcs - AND R.mset = S.mset + WHERE S.id = :store + AND R.store = S.id }] } -proc ::m::store::Size {store} { +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} { 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 {} @@ -797,101 +822,30 @@ WHERE id = :store } return } -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 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 {} +proc ::m::store::Add {vcs} { + debug.m/store {} + set now [clock seconds] + 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 $store + return [m db last_insert_rowid] } proc ::m::store::VCS {store} { debug.m/store {} return [m db onecolumn { @@ -899,19 +853,27 @@ FROM store WHERE id = :store }] } -proc ::m::store::MSName {mset} { +proc ::m::store::MSName {project} { debug.m/store {} return [m db onecolumn { SELECT name - FROM mirror_set - WHERE id = :mset + FROM project + WHERE id = :project }] } +## +# # ## ### ##### ######## ############# ###################### +## 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 @@ -918,18 +880,53 @@ } { 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 } { - Size $id + 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 } return } proc ::m::store::InitialIssues {} { @@ -940,10 +937,22 @@ } { 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 {} m db eval { SELECT S.id AS store @@ -965,34 +974,11 @@ INSERT INTO store_github_forks 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 DELETED lib/logic/vt_mirrorset.tcl Index: lib/logic/vt_mirrorset.tcl ================================================================== --- lib/logic/vt_mirrorset.tcl +++ /dev/null @@ -1,85 +0,0 @@ -## -*- 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 ADDED lib/logic/vt_project.tcl Index: lib/logic/vt_project.tcl ================================================================== --- /dev/null +++ lib/logic/vt_project.tcl @@ -0,0 +1,85 @@ +## -*- 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,13 +55,16 @@ 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,21 +29,41 @@ # # ## ### ##### ######## ############# ##################### ## Definition namespace eval m::format { - namespace export size epoch epoch/short interval + namespace export size epoch epoch/short interval win win-trim 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,10 +98,23 @@ 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} @@ -119,17 +132,10 @@ 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 < <= / + namespace export D C U T T^ I I+ > >+ X < <= / R } 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: do no lose rows. count, then count again. + # constraint: to not lose rows in the change we count before, then count again after 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,11 +219,12 @@ # # ## ### ##### ######## ############# ##################### ## 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]} { @@ -230,12 +231,12 @@ m ops client fail ; return } foreach fork $forks { # unverified estimate (saved) - m ops client fork $fork + m ops client fork https://github.com/$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 remotes export path revs + move size caps 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 - mset name + # name - project 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 ;# Mirror set + m futil write $path/%name $name ;# Project 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,86 +137,63 @@ if {!$ok} { # Roll back filesystem changes file delete -force -- $path # Rethrow as something more distinguished for trapping - return -code error -errorcode {M VCS CHILD} $msg + E $msg CHILD } dict unset state results dict unset state msg + dict unset state ok + # commits, size, forks, duration return $state } -proc ::m::vcs::update {store vcs urls} { +proc ::m::vcs::update {store vcs url primary} { 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 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. + # 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. m futil write $path/%stderr "" - 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 write $path/%stdout "Verifying url ...\n" + debug.m/vcs {Verifying $url ...} + set ok [m url ok $url xr] + if {!$ok} { m futil append $path/%stderr " Bad url: $u\n" - set failed 1 - } - if {$failed} { - m futil append $path/%stderr "Unable to reach remotes\n" - # Fake 'no changes', and error - return {-1 -1 {}} + 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} } # 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 $urls 0] + {*}[OpCmd $vcode $path $url $primary] 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. @@ -253,11 +230,11 @@ # [ ] duration if {!$ok} { # Do not perform any filesystem changes. # Rethrow as something more distinguished for trapping - return -code error -errorcode {M VCS CHILD} $msg + E $msg CHILD } # ... and the store directory file delete -force -- $path return @@ -298,13 +275,10 @@ 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? \ {*}[OpCmd $vcode $patha $pathb] @@ -320,11 +294,11 @@ # [ ] duration if {!$ok} { if {[llength $msg]} { lappend issues {*}$msg } if {[llength $results]} { lappend issues {*}$results } - return + E [join $issues \n] CHILD } else { set flag [lindex $results 0] debug.m/vcs {--> $flag} return $flag } @@ -334,13 +308,10 @@ 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 \ {*}[OpCmd $vcode $ptarget $porigin] @@ -356,11 +327,11 @@ # [ ] duration if {!$ok} { if {[llength $msg]} { lappend issues {*}$msg } if {[llength $results]} { lappend issues {*}$results } - return + E [join $issues \n] CHILD } # Destroy the merged store cleanup $origin $vcs return @@ -379,13 +350,10 @@ # 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 \ {*}[OpCmd $vcode $porigin $pdst] @@ -401,28 +369,20 @@ # [ ] 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] @@ -432,11 +392,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 @@ -444,13 +404,13 @@ # [ ] msg # [ ] duration if {!$ok} { if {![llength $results]} { - lappend results "Failed to retrieve export script for $vcs on $path" + lappend results "Failed to retrieve export script for $vcode on $path" } - return -errorcode {MIRROR VCS EXPORT} -code error [join $results \n] + E [join $results \n] EXPORT } else { set script [join $results \n] debug.m/vcs {--> $script} return $script } @@ -458,10 +418,11 @@ # # ## ### ##### ######## ############# ##################### 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`. @@ -501,11 +462,11 @@ git detect $url hg detect $url svn detect $url fossil detect $url - return -code error "Unable to determine vcs for $url" + E "Unable to determine vcs for $url" DETECT } proc ::m::vcs::url-norm {vcode url} { debug.m/vcs {} # Normalize the incoming url @@ -533,12 +494,10 @@ 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 \ @@ -555,11 +514,11 @@ # [ ] duration if {!$ok} { if {[llength $msg]} { lappend issues {*}$msg } if {[llength $results]} { lappend issues {*}$results } - return + E [join $issues \n] CHILD } else { set name [lindex $results 0] debug.m/vcs {--> $name} return $name } @@ -623,11 +582,11 @@ WHERE name = :x }] } if {$id eq {}} { - return -code error "Invalid vcs code or name" + E "Invalid vcs code or name" INTERNAL } return $id } @@ -657,10 +616,14 @@ debug.m/vcs {} 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 @@ -675,10 +638,13 @@ } 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::mset +package require m::project package require m::site package require m::state package require m::store package require m::vcs @@ -76,25 +76,36 @@ 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 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] + 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] 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 @@ -120,28 +131,134 @@ return } proc ::m::web::site::Stores {} { debug.m/web/site {} - foreach {mset mname} [m mset all] { - foreach store [m mset stores $mset] { - Store $mset $mname $store - } - } - return -} - -proc ::m::web::site::Store {mset mname store} { + + foreach {project name} [m project all] { + foreach store [m project stores $project] { + Store $project $name $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} { debug.m/web/site {} # Get page pieces ... - - lassign [m store remotes $store] remotes plugin - lappend r Remotes $remotes - if {[llength $plugin]} { - lappend r {*}$plugin - } + + set urls [m store remotes $store] + set repos [lmap u $urls { m repo id $u }] + set links [lmap r $repos { RLink $r }] set sd [m store get $store] dict with sd {} # -> size, sizep # commits, commitp @@ -153,70 +270,59 @@ # attend # active # remote # 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] + set spent [StatsTime $min_sec $max_sec $win_sec] lassign [m vcs caps $store] stdout stderr set logo [T "Operation" $stdout] set loge [T "Notes & Errors" $stderr] - 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}] - } - + set commits [Commits $commits $commitp] + set dsize [Size $size $sizep] + set export [ExportStore $vcs $store] + set vcslogo [VCSLogo [m vcs code $vcs] $vcsname] + # Assemble page ... - append text [H $mname] + append text [H $pname] append text |||| \n - append text |---|---|---| \n + append text |---|---:|---| \n - R $simg {} "[IH 32 images/logo/[m vcs code $vcs].svg $vcsname] $vcsname" + 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 + } + } + } + R Size {} $dsize R Commits {} $commits if {$export ne {}} { R {} {} $export } @@ -223,37 +329,18 @@ 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 {} { @@ -261,65 +348,126 @@ append text [H Contact] 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 - # nmsets + # nprojects # 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 {Mirror Set} ] - 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 Project ] + 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 "Sets: " $nmsets , + append text "Projects: " $nprojects , 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|$hvcs|$hsize|$hchan|Updated|Created|" \n - append text "|---|---|---|---:|---|---|---|" \n + append text "||$hname|Repository||$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} { @@ -336,29 +484,40 @@ 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 "[IH 32 images/logo/${vcode}.svg $vcode] $vcode" + set vcode [VCSLogo $vcode $vcode] set vcode [LB store_${store}.html $vcode] - if {$mname ne {}} { - set mname [LB store_${store}.html $mname] - } - append text "|$img|$mname|$vcode|$size|$changed|$updated|$created|" \n + 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::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 mset spec] + W static/spec.txt [m project spec] return } proc ::m::web::site::Search {} { debug.m/web/site {} @@ -447,20 +606,18 @@ proc ::m::web::site::Sync {} { debug.m/web/site {} # Data flows # - Main - # - mset_pending local, no sync + # - repo_pending local, no sync # - reply local, no sync # - rolodex local, no sync # - schema local, no sync # - # - mirror_set [1] join/view pushed to site - # - name [1] store_index, total replacement - # - repository [1] + # - project [1] join/view pushed to site + # - repository [1] store_index, total replacement # - 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 @@ -621,68 +778,65 @@ m site eval { DELETE FROM store_index } # m store search '' (inlined, simply all) m db eval { SELECT S.id AS store - , N.name AS mname + , (SELECT max (P.name) FROM project P, repository R WHERE P.id = R.project AND R.store = S.id) AS pname , V.code AS vcode - , T.changed AS changed - , T.updated AS updated - , T.created AS created - , T.attend AS attend + , 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 , 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 - , mirror_set M + , (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 , version_control_system V - , name N - WHERE T.store = S.id - AND S.mset = M.id - AND S.vcs = V.id - AND M.name = N.id + WHERE S.vcs = V.id } { - # store, mname, vcode, changed, updated, created, size, remote, active, attend + # store, pname, 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.vcs = R.vcs - AND S.mset = R.mset + AND S.id = R.store }] - lappend remotes $mname + lappend remotes $pname 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, - :mname, :vcode, :page, :remotes, :status, + :pname, :vcode, :page, :remotes, :status, :size, :changed, :updated, :created ) } } # Copy the VCS information - m site eval { DELETE FROM vcs } + # 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 @@ -1146,5 +1300,9 @@ static/images/ok.svg static/images/bad.svg static/images/off.svg static/images/yellow.svg +static/images/fork.svg + + +