added on local at 2026-07-12 22:38:30
| 1 | #!/usr/bin/perl | |
| 2 | #====================================================================== | |
| 3 | # DriftSense -- /search.cgi | |
| 4 | # | |
| 5 | # Grep the captured blob store for text matches. This is content search, | |
| 6 | # not filename search -- for filename search use /file_changes.cgi?q=... | |
| 7 | # | |
| 8 | # Cheap implementation: pull recent blobs whose file extension is known- | |
| 9 | # text, uncompress, scan for the query string, return the first match | |
| 10 | # with surrounding context. | |
| 11 | # | |
| 12 | # Limits: | |
| 13 | # * blob size cap 512 KB (skip larger) | |
| 14 | # * scans up to 5000 most-recently-referenced unique blobs | |
| 15 | # * returns at most 200 hits | |
| 16 | #====================================================================== | |
| 17 | use strict; | |
| 18 | use warnings; | |
| 19 | use CGI (); | |
| 20 | use Compress::Zlib qw(uncompress); | |
| 21 | use MODS::Config; use MODS::DBConnect; use MODS::Template; use MODS::PageWrapper; | |
| 22 | ||
| 23 | my $cgi = CGI->new; my $db = MODS::DBConnect->new; my $tpl = MODS::Template->new; | |
| 24 | $|=1; print "Content-Type: text/html; charset=utf-8\nCache-Control: no-cache\n\n"; | |
| 25 | ||
| 26 | my $dbh = $db->db_connect or die "DB connect failed\n"; | |
| 27 | ||
| 28 | my $q = $cgi->param('q') // ''; | |
| 29 | my $mid_filter = int($cgi->param('mid') || 0); | |
| 30 | my $case_sens = $cgi->param('case') ? 1 : 0; | |
| 31 | my $regex_mode = $cgi->param('regex') ? 1 : 0; | |
| 32 | ||
| 33 | my @text_exts = qw(pl pm cgi t js mjs css html htm xml json yaml yml txt md sh | |
| 34 | bash py rb pp conf cnf ini toml sql tpl tt env); | |
| 35 | my $ext_re = join('|', @text_exts); | |
| 36 | ||
| 37 | my (@hits, $scanned, $matched_blobs, $error); | |
| 38 | $scanned = 0; $matched_blobs = 0; | |
| 39 | ||
| 40 | if (length $q) { | |
| 41 | # Compile the search pattern first (cheap error check) | |
| 42 | my $pat = $q; | |
| 43 | my $regex; | |
| 44 | if ($regex_mode) { | |
| 45 | $regex = eval { $case_sens ? qr/$pat/ : qr/$pat/i }; | |
| 46 | $error = "invalid regex: $@" if $@; | |
| 47 | } else { | |
| 48 | $regex = $case_sens ? qr/\Q$pat\E/ : qr/\Q$pat\E/i; | |
| 49 | } | |
| 50 | ||
| 51 | unless ($error) { | |
| 52 | # Get the newest 5000 unique (file_name, blob_sha) pairs | |
| 53 | my $where_mid = $mid_filter ? " AND fc.file_monitor_list_id = $mid_filter" : ""; | |
| 54 | my @rows = $db->db_readwrite_multiple($dbh, qq~ | |
| 55 | SELECT fc.file_name, fc.blob_sha, | |
| 56 | MAX(fc.file_changes_id) AS latest_id, | |
| 57 | MAX(UNIX_TIMESTAMP(fc.date_time)) AS latest_epoch, | |
| 58 | fc.file_monitor_list_id | |
| 59 | FROM FILE_CHANGES fc | |
| 60 | WHERE fc.blob_sha IS NOT NULL | |
| 61 | AND fc.file_name REGEXP CONCAT('\\\\.($ext_re)\$') | |
| 62 | $where_mid | |
| 63 | GROUP BY fc.blob_sha, fc.file_name, fc.file_monitor_list_id | |
| 64 | ORDER BY latest_id DESC | |
| 65 | LIMIT 5000 | |
| 66 | ~, __FILE__, __LINE__); | |
| 67 | ||
| 68 | my $seen_blob = {}; | |
| 69 | my $sth_blob = $dbh->prepare("SELECT content_gz, LENGTH(content_gz) AS gzlen FROM BLOB_STORE WHERE blob_sha = ?"); | |
| 70 | ||
| 71 | foreach my $r (@rows) { | |
| 72 | last if scalar(@hits) >= 200; | |
| 73 | $scanned++; | |
| 74 | next if $seen_blob->{$r->{blob_sha}}++; | |
| 75 | ||
| 76 | $sth_blob->execute($r->{blob_sha}) or next; | |
| 77 | my $brow = $sth_blob->fetchrow_hashref; | |
| 78 | $sth_blob->finish; | |
| 79 | next unless $brow && $brow->{content_gz}; | |
| 80 | next if $brow->{gzlen} > 512_000; # skip huge blobs | |
| 81 | ||
| 82 | my $content = eval { uncompress($brow->{content_gz}) }; | |
| 83 | next unless defined $content; | |
| 84 | next if length($content) > 2_000_000; | |
| 85 | ||
| 86 | # Skip likely-binary (byte 0 in first 1KB) | |
| 87 | next if index(substr($content, 0, 1024), "\x00") >= 0; | |
| 88 | ||
| 89 | if ($content =~ $regex) { | |
| 90 | $matched_blobs++; | |
| 91 | # Grab first ~3 matching lines with context | |
| 92 | my @lines = split /\n/, $content; | |
| 93 | my $hit_count = 0; | |
| 94 | for (my $i = 0; $i < @lines; $i++) { | |
| 95 | last if $hit_count >= 3; | |
| 96 | if ($lines[$i] =~ $regex) { | |
| 97 | $hit_count++; | |
| 98 | my $ctx_before = $i > 0 ? $lines[$i-1] : ''; | |
| 99 | my $ctx_after = $i < $#lines ? $lines[$i+1] : ''; | |
| 100 | my $line = $lines[$i]; | |
| 101 | my @out_lines; | |
| 102 | push @out_lines, { ln => $i, op => 'ctx', text => _trim_line($ctx_before) } if length $ctx_before; | |
| 103 | push @out_lines, { ln => $i+1, op => 'hit', text => _highlight($line, $regex) }; | |
| 104 | push @out_lines, { ln => $i+2, op => 'ctx', text => _trim_line($ctx_after) } if length $ctx_after; | |
| 105 | push @hits, { | |
| 106 | file_name => $r->{file_name}, | |
| 107 | file_name_h=> length($r->{file_name}) > 80 ? '...' . substr($r->{file_name}, -77) : $r->{file_name}, | |
| 108 | blob_sha => $r->{blob_sha}, | |
| 109 | blob_short => substr($r->{blob_sha}, 0, 8), | |
| 110 | latest_id => $r->{latest_id}, | |
| 111 | latest_epoch => $r->{latest_epoch} // 0, | |
| 112 | mid => $r->{file_monitor_list_id}, | |
| 113 | hit_lines => \@out_lines, | |
| 114 | file_url => "/diff.cgi?kind=file&id=$r->{latest_id}", | |
| 115 | restore_url=> "/restore.cgi?id=$r->{latest_id}", | |
| 116 | }; | |
| 117 | last if scalar(@hits) >= 200; | |
| 118 | } | |
| 119 | } | |
| 120 | } | |
| 121 | } | |
| 122 | } | |
| 123 | } | |
| 124 | ||
| 125 | # Monitors for the filter dropdown | |
| 126 | my @monitors = $db->db_readwrite_multiple($dbh, q~ | |
| 127 | SELECT m.file_monitor_list_id AS mid, m.scan_name, s.server_name | |
| 128 | FROM FILE_MONITOR_SETTINGS m | |
| 129 | LEFT JOIN SERVERS s ON s.server_id = m.server_id | |
| 130 | WHERE m.status = 1 | |
| 131 | ORDER BY s.server_id ASC, m.file_monitor_list_id ASC | |
| 132 | ~, __FILE__, __LINE__); | |
| 133 | foreach my $m (@monitors) { | |
| 134 | $m->{label} = ($m->{scan_name} // '?') . ' (on ' . ($m->{server_name} // '?') . ')'; | |
| 135 | $m->{selected} = ($mid_filter && $m->{mid} == $mid_filter) ? 1 : 0; | |
| 136 | } | |
| 137 | ||
| 138 | $db->db_disconnect($dbh); | |
| 139 | ||
| 140 | my $tvars = { | |
| 141 | q => $q, | |
| 142 | q_h => _html_escape($q), | |
| 143 | has_query => length($q) ? 1 : 0, | |
| 144 | hits => \@hits, | |
| 145 | has_hits => scalar(@hits) ? 1 : 0, | |
| 146 | hit_count => scalar(@hits), | |
| 147 | scanned => $scanned, | |
| 148 | matched_blobs => $matched_blobs, | |
| 149 | case_sens => $case_sens, | |
| 150 | regex_mode => $regex_mode, | |
| 151 | monitors => \@monitors, | |
| 152 | has_monitors => scalar(@monitors) ? 1 : 0, | |
| 153 | mid_filter => $mid_filter, | |
| 154 | error_msg => $error // '', | |
| 155 | has_error => $error ? 1 : 0, | |
| 156 | }; | |
| 157 | my @body = $tpl->template('search.html', $tvars); | |
| 158 | MODS::PageWrapper->new->wrapper( | |
| 159 | page_title => 'Search captures', page_key => 'search', | |
| 160 | body_html => join('', @body), userinfo => { display_name => 'Operator' }, | |
| 161 | ); | |
| 162 | ||
| 163 | #--------------------------------------------------------------------- | |
| 164 | sub _highlight { | |
| 165 | my ($line, $regex) = @_; | |
| 166 | my $t = _trim_line($line); | |
| 167 | # HTML-escape first | |
| 168 | $t = _html_escape($t); | |
| 169 | # Highlight matches -- do it on the escaped string with the same regex | |
| 170 | # (won't handle regex against html entities perfectly, but usable) | |
| 171 | $t =~ s{($regex)}{<mark>$1</mark>}g; | |
| 172 | return $t; | |
| 173 | } | |
| 174 | ||
| 175 | sub _trim_line { | |
| 176 | my ($s) = @_; | |
| 177 | return '' unless defined $s; | |
| 178 | $s =~ s/^\s+//; | |
| 179 | $s =~ s/\s+$//; | |
| 180 | return length($s) > 200 ? substr($s, 0, 200) . '...' : $s; | |
| 181 | } | |
| 182 | ||
| 183 | sub _html_escape { | |
| 184 | my ($s) = @_; | |
| 185 | return '' unless defined $s; | |
| 186 | $s =~ s/&/&/g; $s =~ s/</</g; $s =~ s/>/>/g; | |
| 187 | $s =~ s/"/"/g; | |
| 188 | return $s; | |
| 189 | } |