modified on local at 2026-07-12 23:13:01
| 1 | 1 | #!/usr/bin/perl |
| 2 | 2 | #====================================================================== |
| 3 | 3 | # DriftSense -- /named_releases.cgi |
| 4 | 4 | # |
| 5 | 5 | # List + create named releases. Each release is a bookmark that pins |
| 6 | 6 | # every blob referenced by FILE_CHANGES rows in a chosen scope. A |
| 7 | 7 | # release can be portfolio-wide (scope_monitor_id NULL) or scoped to |
| 8 | 8 | # a single site (scope_monitor_id set). Pinned blobs are exempt from |
| 9 | 9 | # auto-purge. |
| 10 | 10 | #====================================================================== |
| 11 | 11 | use strict; |
| 12 | 12 | use warnings; |
| 13 | 13 | use CGI (); |
| 14 | 14 | use MODS::Config; use MODS::DBConnect; use MODS::Template; use MODS::PageWrapper; |
| 15 | 15 | use MODS::Webhook; |
| 16 | 16 | use JSON::PP (); |
| 17 | 17 | my $cgi = CGI->new; my $db = MODS::DBConnect->new; my $tpl = MODS::Template->new; |
| 18 | 18 | $|=1; |
| 19 | 19 | |
| 20 | 20 | my $dbh = $db->db_connect or die "DB connect failed\n"; |
| 21 | 21 | |
| 22 | 22 | # ---- POST: create --------------------------------------------------- |
| 23 | 23 | if (($ENV{REQUEST_METHOD} || '') eq 'POST' && $cgi->param('save')) { |
| 24 | 24 | my $name = $cgi->param('name') || ''; |
| 25 | 25 | my $desc = $cgi->param('description') || ''; |
| 26 | 26 | my $by = $cgi->param('released_by') || 'Operator'; |
| 27 | 27 | my $scope_mid = int($cgi->param('scope_monitor_id') || 0); |
| 28 | 28 | my $scope_sid = int($cgi->param('scope_server_id') || 0); |
| 29 | 29 | my $dkind = $cgi->param('alert_delivery_kind') || 'none'; |
| 30 | 30 | $dkind = 'none' unless $dkind =~ /^(none|generic_webhook|slack|discord)$/; |
| 31 | 31 | my $durl = $cgi->param('alert_delivery_url') || ''; |
| 32 | 32 | my $tier = $cgi->param('tier') || 'draft'; |
| 33 | 33 | $tier = 'draft' unless $tier =~ /^(draft|working|stable)$/; |
| 34 | 34 | my $vlabel = $cgi->param('version_label') || ''; |
| 35 | 35 | my $apdays = int($cgi->param('auto_promote_stable_days') || 0); |
| 36 | 36 | $apdays = 0 if $apdays < 0 || $apdays > 365; |
| 37 | my $ann = $cgi->param('annotation') // ''; | |
| 38 | $ann = substr($ann, 0, 4000) if length($ann) > 4000; | |
| 37 | 39 | |
| 38 | 40 | if (length $name) { |
| 39 | 41 | my $q_name = $dbh->quote($name); |
| 40 | 42 | my $q_desc = $dbh->quote($desc); |
| 41 | 43 | my $q_by = $dbh->quote($by); |
| 42 | 44 | my $q_dk = $dbh->quote($dkind); |
| 43 | 45 | my $q_du = $dbh->quote($durl); |
| 44 | 46 | my $q_tier = $dbh->quote($tier); |
| 45 | 47 | my $q_vl = $dbh->quote($vlabel); |
| 46 | 48 | my $mid_expr = $scope_mid ? $scope_mid : 'NULL'; |
| 47 | 49 | my $sid_expr = $scope_sid ? $scope_sid : 'NULL'; |
| 48 | my $has_ap = _has_col($dbh, 'NAMED_RELEASES', 'auto_promote_stable_days'); | |
| 49 | my $cols = "(name, description, released_at, released_by, is_locked, created_at, | |
| 50 | my $has_ap = _has_col($dbh, 'NAMED_RELEASES', 'auto_promote_stable_days'); | |
| 51 | my $has_ann = _has_col($dbh, 'NAMED_RELEASES', 'annotation'); | |
| 52 | my $q_ann = $dbh->quote($ann); | |
| 53 | my $cols = "(name, description, released_at, released_by, is_locked, created_at, | |
| 50 | 54 | scope_monitor_id, scope_server_id, |
| 51 | 55 | alert_delivery_kind, alert_delivery_url, |
| 52 | tier, version_label" . ($has_ap ? ', auto_promote_stable_days' : '') . ")"; | |
| 53 | my $vals = "($q_name, $q_desc, NOW(), $q_by, 1, NOW(), | |
| 56 | tier, version_label" | |
| 57 | . ($has_ap ? ', auto_promote_stable_days' : '') | |
| 58 | . ($has_ann ? ', annotation' : '') . ")"; | |
| 59 | my $vals = "($q_name, $q_desc, NOW(), $q_by, 1, NOW(), | |
| 54 | 60 | $mid_expr, $sid_expr, |
| 55 | 61 | $q_dk, $q_du, |
| 56 | $q_tier, $q_vl" . ($has_ap ? ", $apdays" : '') . ")"; | |
| 62 | $q_tier, $q_vl" | |
| 63 | . ($has_ap ? ", $apdays" : '') | |
| 64 | . ($has_ann ? ", $q_ann" : '') . ")"; | |
| 57 | 65 | $db->db_readwrite($dbh, "INSERT INTO NAMED_RELEASES $cols VALUES $vals", |
| 58 | 66 | __FILE__, __LINE__); |
| 59 | 67 | # Extra scopes for cross-scope releases (Wave 5 F5): multi-select |
| 60 | 68 | # scope_monitor_ids[] additive |
| 61 | 69 | my $new_rel = $db->db_readwrite($dbh, "SELECT LAST_INSERT_ID() AS id", __FILE__, __LINE__); |
| 62 | 70 | my $rid = $new_rel && $new_rel->{id}; |
| 63 | 71 | if ($rid) { |
| 64 | 72 | foreach my $extra ($cgi->param('extra_monitor_ids')) { |
| 65 | 73 | my $eid = int($extra || 0); |
| 66 | 74 | next unless $eid && $eid != $scope_mid; |
| 67 | 75 | $db->db_readwrite($dbh, qq~ |
| 68 | 76 | INSERT INTO NAMED_RELEASE_SCOPES |
| 69 | 77 | (named_release_id, file_monitor_list_id) |
| 70 | 78 | VALUES ($rid, $eid) |
| 71 | 79 | ~, __FILE__, __LINE__); |
| 72 | 80 | } |
| 73 | 81 | } |
| 74 | 82 | } |
| 75 | 83 | print "Status: 302 Found\nLocation: /named_releases.cgi\n\n"; exit; |
| 76 | 84 | } |
| 77 | 85 | |
| 78 | 86 | # ---- AJAX: test alert delivery ------------------------------------ |
| 79 | 87 | if ($cgi->param('op') && $cgi->param('op') eq 'test_alert') { |
| 80 | 88 | my $rid = int($cgi->param('release_id') || 0); |
| 81 | 89 | print "Content-Type: application/json\nCache-Control: no-cache\n\n"; |
| 82 | 90 | my $r = $db->db_readwrite($dbh, qq~ |
| 83 | 91 | SELECT name, alert_delivery_kind, alert_delivery_url |
| 84 | 92 | FROM NAMED_RELEASES WHERE named_release_id = $rid LIMIT 1 |
| 85 | 93 | ~, __FILE__, __LINE__); |
| 86 | 94 | unless ($r && $r->{alert_delivery_url}) { |
| 87 | 95 | print JSON::PP::encode_json({ ok => \0, message => 'no delivery URL configured' }); |
| 88 | 96 | exit; |
| 89 | 97 | } |
| 90 | 98 | my $summary = "TEST alert from DriftSense -- release '$r->{name}' -- ignore me"; |
| 91 | 99 | my $body = ($r->{alert_delivery_kind} eq 'slack') ? { |
| 92 | 100 | text => "*DriftSense TEST*: $summary", |
| 93 | 101 | attachments => [{ color => '#f59e0b', text => 'This is a synthetic drift payload. No files actually drifted.' }], |
| 94 | 102 | } : ($r->{alert_delivery_kind} eq 'discord') ? { |
| 95 | 103 | content => "**DriftSense TEST**: $summary", |
| 96 | 104 | } : { |
| 97 | 105 | source => 'drift_sense', alert_type => 'test', |
| 98 | 106 | release_name => $r->{name}, summary => $summary, |
| 99 | 107 | }; |
| 100 | 108 | my ($code, $rbody, $err) = MODS::Webhook::post_json( |
| 101 | 109 | $r->{alert_delivery_url}, $body, |
| 102 | 110 | timeout => 8, |
| 103 | 111 | user_agent => 'DriftSense/1.0 (test-alert)', |
| 104 | 112 | ); |
| 105 | 113 | my $ok = (!$err && $code >= 200 && $code < 400) ? \1 : \0; |
| 106 | 114 | print JSON::PP::encode_json({ |
| 107 | 115 | ok => $ok, http_code => $code, message => $err ? $err : "HTTP $code", |
| 108 | 116 | }); |
| 109 | 117 | exit; |
| 110 | 118 | } |
| 111 | 119 | |
| 112 | 120 | # ---- POST: promote / demote tier ----------------------------------- |
| 113 | 121 | if (($ENV{REQUEST_METHOD} || '') eq 'POST' && $cgi->param('promote')) { |
| 114 | 122 | my $rid = int($cgi->param('release_id') || 0); |
| 115 | 123 | my $tier = $cgi->param('to_tier') || 'stable'; |
| 116 | 124 | $tier = 'draft' unless $tier =~ /^(draft|working|stable)$/; |
| 117 | 125 | my $q_tier = $dbh->quote($tier); |
| 118 | 126 | $db->db_readwrite($dbh, |
| 119 | 127 | "UPDATE NAMED_RELEASES SET tier = $q_tier WHERE named_release_id = $rid", |
| 120 | 128 | __FILE__, __LINE__); |
| 121 | 129 | print "Status: 302 Found\nLocation: /named_releases.cgi\n\n"; exit; |
| 122 | 130 | } |
| 123 | 131 | |
| 124 | 132 | print "Content-Type: text/html; charset=utf-8\nCache-Control: no-cache\n\n"; |
| 125 | 133 | |
| 126 | 134 | # ---- Existing releases + count how many blobs each pins ------------- |
| 127 | 135 | my $has_ap = _has_col($dbh, 'NAMED_RELEASES', 'auto_promote_stable_days'); |
| 128 | my $ap_expr = $has_ap ? 'nr.auto_promote_stable_days' : '0'; | |
| 136 | my $has_ann = _has_col($dbh, 'NAMED_RELEASES', 'annotation'); | |
| 137 | my $ap_expr = $has_ap ? 'nr.auto_promote_stable_days' : '0'; | |
| 138 | my $ann_expr = $has_ann ? 'nr.annotation' : 'NULL'; | |
| 129 | 139 | my @rows = $db->db_readwrite_multiple($dbh, qq~ |
| 130 | 140 | SELECT nr.named_release_id AS id, nr.name, nr.description, nr.tier, nr.version_label, |
| 131 | 141 | DATE_FORMAT(nr.released_at, '%b %d, %Y %H:%i') AS released_h, |
| 132 | 142 | UNIX_TIMESTAMP(nr.released_at) AS released_epoch, |
| 133 | 143 | nr.released_by, nr.is_locked, |
| 134 | 144 | nr.scope_monitor_id, nr.scope_server_id, |
| 135 | 145 | $ap_expr AS auto_promote_days, |
| 146 | $ann_expr AS annotation, | |
| 136 | 147 | TIMESTAMPDIFF(DAY, nr.released_at, NOW()) AS age_days, |
| 137 | 148 | m.scan_name, s.server_name |
| 138 | 149 | FROM NAMED_RELEASES nr |
| 139 | 150 | LEFT JOIN FILE_MONITOR_SETTINGS m ON m.file_monitor_list_id = nr.scope_monitor_id |
| 140 | 151 | LEFT JOIN SERVERS s ON s.server_id = nr.scope_server_id |
| 141 | 152 | ORDER BY (nr.tier = 'stable') DESC, |
| 142 | 153 | (nr.tier = 'working') DESC, |
| 143 | 154 | nr.released_at DESC |
| 144 | 155 | LIMIT 100 |
| 145 | 156 | ~, __FILE__, __LINE__); |
| 146 | 157 | foreach my $r (@rows) { |
| 147 | 158 | $r->{lock_pill} = $r->{is_locked} ? 'pill-ok' : 'pill-mute'; |
| 148 | 159 | $r->{lock_lbl} = $r->{is_locked} ? 'PROTECTED' : 'UNLOCKED'; |
| 149 | 160 | $r->{released_epoch} //= 0; |
| 150 | 161 | $r->{auto_promote_days} //= 0; |
| 151 | 162 | $r->{age_days} //= 0; |
| 152 | 163 | $r->{has_auto_promote} = ($r->{auto_promote_days} > 0) ? 1 : 0; |
| 153 | 164 | $r->{ap_ready} = ($r->{has_auto_promote} && $r->{tier} eq 'working' |
| 154 | 165 | && $r->{age_days} >= $r->{auto_promote_days}) ? 1 : 0; |
| 155 | 166 | $r->{ap_days_left} = $r->{has_auto_promote} |
| 156 | 167 | ? ($r->{auto_promote_days} - $r->{age_days}) |
| 157 | 168 | : 0; |
| 169 | $r->{annotation} //= ''; | |
| 170 | $r->{has_annotation} = length($r->{annotation}) ? 1 : 0; | |
| 158 | 171 | $r->{tier} //= 'draft'; |
| 159 | 172 | $r->{tier_pill} = $r->{tier} eq 'stable' ? 'pill-ok' |
| 160 | 173 | : $r->{tier} eq 'working' ? 'pill-info' |
| 161 | 174 | : 'pill-mute'; |
| 162 | 175 | $r->{tier_lbl} = uc($r->{tier}); |
| 163 | 176 | $r->{display_label} = $r->{version_label} || $r->{name}; |
| 164 | 177 | $r->{is_stable} = $r->{tier} eq 'stable' ? 1 : 0; |
| 165 | 178 | $r->{is_draft} = $r->{tier} eq 'draft' ? 1 : 0; |
| 166 | 179 | $r->{is_working} = $r->{tier} eq 'working'? 1 : 0; |
| 167 | 180 | $r->{restore_url} = "/restore_release.cgi?release_id=$r->{id}"; |
| 168 | 181 | if ($r->{scope_monitor_id}) { |
| 169 | 182 | $r->{scope_pill} = 'pill-info'; |
| 170 | 183 | $r->{scope_lbl} = 'per-site'; |
| 171 | 184 | $r->{scope_h} = $r->{scan_name} || "monitor #$r->{scope_monitor_id}"; |
| 172 | 185 | } elsif ($r->{scope_server_id}) { |
| 173 | 186 | $r->{scope_pill} = 'pill-info'; |
| 174 | 187 | $r->{scope_lbl} = 'per-server'; |
| 175 | 188 | $r->{scope_h} = $r->{server_name} || "server #$r->{scope_server_id}"; |
| 176 | 189 | } else { |
| 177 | 190 | $r->{scope_pill} = 'pill-mute'; |
| 178 | 191 | $r->{scope_lbl} = 'portfolio'; |
| 179 | 192 | $r->{scope_h} = 'All monitored sites'; |
| 180 | 193 | } |
| 181 | 194 | } |
| 182 | 195 | |
| 183 | 196 | # ---- All monitors + servers for scope picker ------------------------ |
| 184 | 197 | my @monitors = $db->db_readwrite_multiple($dbh, q~ |
| 185 | 198 | SELECT m.file_monitor_list_id AS mid, m.scan_name, s.server_name |
| 186 | 199 | FROM FILE_MONITOR_SETTINGS m |
| 187 | 200 | LEFT JOIN SERVERS s ON s.server_id = m.server_id |
| 188 | 201 | WHERE m.status = 1 |
| 189 | 202 | ORDER BY s.server_id ASC, m.file_monitor_list_id ASC |
| 190 | 203 | ~, __FILE__, __LINE__); |
| 191 | 204 | foreach my $m (@monitors) { |
| 192 | 205 | $m->{label} = ($m->{scan_name} // '?') . ' (on ' . ($m->{server_name} // '?') . ')'; |
| 193 | 206 | } |
| 194 | 207 | |
| 195 | 208 | my $total = scalar @rows; |
| 196 | 209 | $db->db_disconnect($dbh); |
| 197 | 210 | |
| 198 | 211 | my $tvars = { |
| 199 | 212 | rows => \@rows, |
| 200 | 213 | has_rows => $total ? 1 : 0, |
| 201 | 214 | total => $total, |
| 202 | 215 | monitors => \@monitors, |
| 203 | 216 | has_monitors=> scalar(@monitors) ? 1 : 0, |
| 204 | 217 | }; |
| 205 | 218 | my @body = $tpl->template('named_releases.html', $tvars); |
| 206 | 219 | MODS::PageWrapper->new->wrapper( |
| 207 | 220 | page_title => 'Named releases', page_key => 'named_releases', |
| 208 | 221 | body_html => join('', @body), userinfo => { display_name => 'Operator' }, |
| 209 | 222 | ); |
| 210 | 223 | |
| 211 | 224 | #--------------------------------------------------------------------- |
| 212 | 225 | # _has_col($dbh, $table, $col) -- schema probe cached per-process |
| 213 | 226 | #--------------------------------------------------------------------- |
| 214 | 227 | my %_COL_CACHE; |
| 215 | 228 | sub _has_col { |
| 216 | 229 | my ($dbh, $table, $col) = @_; |
| 217 | 230 | my $k = "$table/$col"; |
| 218 | 231 | return $_COL_CACHE{$k} if exists $_COL_CACHE{$k}; |
| 219 | 232 | my $q_tab = $dbh->quote($table); |
| 220 | 233 | my $q_col = $dbh->quote($col); |
| 221 | 234 | my $r = $db->db_readwrite($dbh, qq~ |
| 222 | 235 | SELECT 1 AS ok FROM INFORMATION_SCHEMA.COLUMNS |
| 223 | 236 | WHERE TABLE_SCHEMA = DATABASE() |
| 224 | 237 | AND TABLE_NAME = $q_tab AND COLUMN_NAME = $q_col |
| 225 | 238 | ~, __FILE__, __LINE__); |
| 226 | 239 | return $_COL_CACHE{$k} = ($r && $r->{ok}) ? 1 : 0; |
| 227 | 240 | } |