Diff -- /var/www/vhosts/3dshawn.com/site1/_agent_scan.pl
Diff
/var/www/vhosts/3dshawn.com/site1/_agent_scan.pl
modified on local at 2026-07-12 00:02:10
Added
+18
lines
Removed
-2
lines
Context
436
unchanged
Blobs
from ee7754b6fe45
to bf5b44533145
to bf5b44533145
Unified diff
Naive LCS-based line diff. Additions in emerald, deletions in rose. Both sides decompressed live from BLOB_STORE.| 1 | 1 | #!/usr/bin/perl |
| 2 | 2 | #====================================================================== |
| 3 | 3 | # DriftSense -- SSH agent scanner (Stealth Flavor 2) |
| 4 | 4 | # |
| 5 | 5 | # Cron entry point (NOT a CGI). For each active SERVERS row with |
| 6 | 6 | # kind='ssh_agent', SSHes into the monitored host using the configured |
| 7 | 7 | # restricted key and walks the paths in that server's FILE_MONITOR_SETTINGS. |
| 8 | 8 | # |
| 9 | 9 | # Monitored host runs zero DriftSense code -- only a single command- |
| 10 | 10 | # restricted authorized_keys entry. The wrapper on the remote side |
| 11 | 11 | # only allows 3 commands: |
| 12 | 12 | # |
| 13 | 13 | # drift-find <path> -> path\tsize\tmtime\n per file |
| 14 | 14 | # drift-hash <files> -> sha256sum output |
| 15 | 15 | # drift-read <file> -> raw bytes |
| 16 | 16 | # |
| 17 | 17 | # We drive it via SSH_ORIGINAL_COMMAND. If the wrapper isn't installed, |
| 18 | 18 | # we fall back to plain `find`, `sha256sum`, `cat` on the assumption |
| 19 | 19 | # that the SSH user has a normal shell (test-mode). |
| 20 | 20 | # |
| 21 | 21 | # Config: /etc/drift_sense/drift_sense.conf (via MODS::Config). |
| 22 | 22 | # Log: /var/log/drift_sense/agent_scan.log (via cron redirect). |
| 23 | 23 | #====================================================================== |
| 24 | 24 | use strict; |
| 25 | 25 | use warnings; |
| 26 | 26 | use lib '/var/www/vhosts/3dshawn.com/site1'; |
| 27 | 27 | use POSIX (); |
| 28 | 28 | use Digest::SHA qw(sha256_hex); |
| 29 | 29 | use Compress::Zlib qw(compress); |
| 30 | 30 | use IPC::Open3; |
| 31 | 31 | use Symbol 'gensym'; |
| 32 | 32 | use MODS::Config; |
| 33 | 33 | use MODS::DBConnect; |
| 34 | 34 | use MODS::Crypto; |
| 35 | 35 | use Fcntl (); |
| 36 | 36 | |
| 37 | 37 | $| = 1; |
| 38 | 38 | my $ts = POSIX::strftime('%Y-%m-%d %H:%M:%S', localtime); |
| 39 | 39 | |
| 40 | 40 | my $cfg = MODS::Config->new; |
| 41 | 41 | my $db = MODS::DBConnect->new; |
| 42 | 42 | my $dbh = $db->db_connect or die "[$ts] cannot connect to DriftSense storage DB\n"; |
| 43 | 43 | |
| 44 | 44 | my $default_max_size = int($cfg->settings('max_file_size_bytes') || 10_485_760); |
| 45 | 45 | my $DEFAULT_TIMEOUT = 30; |
| 46 | ||
| 47 | # ---- Global scan settings (SCAN_GLOBALS singleton) ----------------- | |
| 48 | my $g_row = $db->db_readwrite($dbh, q~ | |
| 49 | SELECT global_ignore_list, global_file_type_filter, global_max_file_size_bytes | |
| 50 | FROM SCAN_GLOBALS WHERE id = 1 LIMIT 1 | |
| 51 | ~, __FILE__, __LINE__); | |
| 52 | my $global_ignore = ($g_row && $g_row->{global_ignore_list}) // ''; | |
| 53 | my $global_ftypes = ($g_row && $g_row->{global_file_type_filter}) // ''; | |
| 54 | my $global_max_size = ($g_row && $g_row->{global_max_file_size_bytes}) || 0; | |
| 55 | $default_max_size = $global_max_size if $global_max_size; | |
| 46 | 56 | |
| 47 | 57 | # ---- Fetch ssh_agent servers ---------------------------------------- |
| 48 | 58 | my @servers = $db->db_readwrite_multiple($dbh, q~ |
| 49 | 59 | SELECT server_id, server_name, ssh_host, ssh_user, ssh_port, |
| 50 | 60 | ssh_key_path, ssh_options, ssh_key_blob, ssh_key_enc |
| 51 | 61 | FROM SERVERS |
| 52 | 62 | WHERE kind = 'ssh_agent' |
| 53 | 63 | AND status = 'active' |
| 54 | 64 | ~, __FILE__, __LINE__); |
| 55 | 65 | |
| 56 | 66 | unless (@servers) { |
| 57 | 67 | print "[$ts] no active ssh_agent servers, exiting\n"; |
| 58 | 68 | $db->db_disconnect($dbh); |
| 59 | 69 | exit 0; |
| 60 | 70 | } |
| 61 | 71 | |
| 62 | 72 | my $total_added = 0; |
| 63 | 73 | my $total_modified = 0; |
| 64 | 74 | my $total_deleted = 0; |
| 65 | 75 | |
| 66 | 76 | foreach my $server (@servers) { |
| 67 | 77 | my $sid = $server->{server_id}; |
| 68 | 78 | my $host = $server->{ssh_host} || next; |
| 69 | 79 | my $user = $server->{ssh_user} || 'root'; |
| 70 | 80 | my $port = $server->{ssh_port} || 22; |
| 71 | 81 | my $opts = $server->{ssh_options} || ''; |
| 72 | 82 | |
| 73 | 83 | # Resolve key: prefer encrypted blob (decrypt to a mode-600 temp |
| 74 | 84 | # file for the SSH call), else fall back to on-disk ssh_key_path. |
| 75 | 85 | my $key_path = $server->{ssh_key_path} || ''; |
| 76 | 86 | my $tmp_key; |
| 77 | 87 | if ($server->{ssh_key_blob}) { |
| 78 | 88 | my $pem = eval { MODS::Crypto::decrypt($server->{ssh_key_blob}) }; |
| 79 | 89 | if ($pem) { |
| 80 | 90 | $tmp_key = _materialize_key($pem); |
| 81 | 91 | $key_path = $tmp_key if $tmp_key; |
| 82 | 92 | } else { |
| 83 | 93 | print "[$ts] server $server->{server_name}: key decrypt failed ($@)\n"; |
| 84 | 94 | } |
| 85 | 95 | } |
| 86 | 96 | |
| 87 | 97 | my @ssh_base = _ssh_argv($user, $host, $port, $key_path, $opts); |
| 88 | 98 | |
| 89 | 99 | # Fetch this server's active file monitors |
| 90 | 100 | my @scans = $db->db_readwrite_multiple($dbh, qq~ |
| 91 | 101 | SELECT file_monitor_list_id, scan_path, ignore_list, file_type_filter, |
| 92 | 102 | max_file_size_bytes, scan_name |
| 93 | 103 | FROM FILE_MONITOR_SETTINGS |
| 94 | 104 | WHERE status = 1 |
| 95 | 105 | AND server_id = $sid |
| 96 | 106 | ~, __FILE__, __LINE__); |
| 97 | 107 | |
| 98 | 108 | unless (@scans) { |
| 99 | 109 | print "[$ts] server '$server->{server_name}' has no active monitors\n"; |
| 100 | 110 | next; |
| 101 | 111 | } |
| 102 | 112 | |
| 103 | 113 | my $server_err; |
| 104 | 114 | |
| 105 | 115 | foreach my $scan (@scans) { |
| 106 | 116 | my $path = $scan->{scan_path} or next; |
| 107 | 117 | my $max_size = $scan->{max_file_size_bytes} || $default_max_size; |
| 108 | 118 | |
| 109 | my %ignore_pats = _build_ignore_patterns($scan->{ignore_list}); | |
| 110 | my %type_filter = _build_type_filter($scan->{file_type_filter}); | |
| 119 | # UNION global + per-monitor ignore lists | |
| 120 | my $combined_ignore = join(',', grep { length } ($global_ignore, ($scan->{ignore_list} // ''))); | |
| 121 | my %ignore_pats = _build_ignore_patterns($combined_ignore); | |
| 122 | # Per-monitor filter wins if set; else global | |
| 123 | my $eff_ftypes = length($scan->{file_type_filter} // '') | |
| 124 | ? $scan->{file_type_filter} | |
| 125 | : $global_ftypes; | |
| 126 | my %type_filter = _build_type_filter($eff_ftypes); | |
| 111 | 127 | |
| 112 | 128 | # ---- Remote listing ----------------------------------------- |
| 113 | 129 | my $remote_cmd = qq{drift-find $path}; |
| 114 | 130 | my ($rc, $out, $err) = _ssh_run(\@ssh_base, $remote_cmd); |
| 115 | 131 | if ($rc != 0) { |
| 116 | 132 | # Fallback: no wrapper -> plain shell |
| 117 | 133 | my $shell = qq{find } . _sh_quote($path) . qq{ -type f -not -path '*/.*' -printf '%p\\t%s\\t%T@\\n' 2>/dev/null}; |
| 118 | 134 | ($rc, $out, $err) = _ssh_run(\@ssh_base, $shell); |
| 119 | 135 | } |
| 120 | 136 | if ($rc != 0) { |
| 121 | 137 | $server_err = "list failed: $err"; |
| 122 | 138 | print "[$ts] server '$server->{server_name}' scan '$scan->{scan_name}': $server_err\n"; |
| 123 | 139 | next; |
| 124 | 140 | } |
| 125 | 141 | |
| 126 | 142 | # Parse listing: path\tsize\tmtime_epoch |
| 127 | 143 | my %remote; |
| 128 | 144 | foreach my $line (split /\n/, $out) { |
| 129 | 145 | chomp $line; |
| 130 | 146 | next unless length $line; |
| 131 | 147 | my ($p, $sz, $mt) = split /\t/, $line, 3; |
| 132 | 148 | next unless defined $p && defined $sz && defined $mt; |
| 133 | 149 | $sz = int($sz); |
| 134 | 150 | $mt = int($mt); # printf gives float mtime, truncate |
| 135 | 151 | |
| 136 | 152 | # Ignore-glob filter (local side) |
| 137 | 153 | my $skip = 0; |
| 138 | 154 | for my $pat (keys %ignore_pats) { |
| 139 | 155 | my $re = $ignore_pats{$pat}; |
| 140 | 156 | if ($p =~ $re) { $skip = 1; last; } |
| 141 | 157 | } |
| 142 | 158 | next if $skip; |
| 143 | 159 | |
| 144 | 160 | # File-type filter (local side) |
| 145 | 161 | if (%type_filter) { |
| 146 | 162 | my $ext_ok = 0; |
| 147 | 163 | for my $e (keys %type_filter) { |
| 148 | 164 | if (lc(substr($p, -length($e))) eq $e) { $ext_ok = 1; last; } |
| 149 | 165 | } |
| 150 | 166 | next unless $ext_ok; |
| 151 | 167 | } |
| 152 | 168 | |
| 153 | 169 | next if $sz > $max_size; |
| 154 | 170 | $remote{$p} = { size => $sz, mtime => $mt }; |
| 155 | 171 | } |
| 156 | 172 | |
| 157 | 173 | # ---- Previous state ---------------------------------------- |
| 158 | 174 | my $prev_sth = $dbh->prepare(qq{ |
| 159 | 175 | SELECT fc.file_name, fc.blob_sha, fc.status, |
| 160 | 176 | UNIX_TIMESTAMP(fc.date_time) AS mt_epoch |
| 161 | 177 | FROM FILE_CHANGES fc |
| 162 | 178 | WHERE fc.file_monitor_list_id = $scan->{file_monitor_list_id} |
| 163 | 179 | AND fc.server_id = $sid |
| 164 | 180 | AND fc.file_changes_id IN ( |
| 165 | 181 | SELECT MAX(inner_fc.file_changes_id) |
| 166 | 182 | FROM FILE_CHANGES inner_fc |
| 167 | 183 | WHERE inner_fc.file_monitor_list_id = $scan->{file_monitor_list_id} |
| 168 | 184 | AND inner_fc.server_id = $sid |
| 169 | 185 | GROUP BY inner_fc.file_name |
| 170 | 186 | ) |
| 171 | 187 | }); |
| 172 | 188 | my %prev; |
| 173 | 189 | if ($prev_sth && $prev_sth->execute) { |
| 174 | 190 | while (my $r = $prev_sth->fetchrow_hashref) { |
| 175 | 191 | $prev{$r->{file_name}} = $r; |
| 176 | 192 | } |
| 177 | 193 | $prev_sth->finish; |
| 178 | 194 | } |
| 179 | 195 | |
| 180 | 196 | # ---- Decide who needs a fresh hash -------------------------- |
| 181 | 197 | my @needs_hash; |
| 182 | 198 | foreach my $p (keys %remote) { |
| 183 | 199 | my $prev_row = $prev{$p}; |
| 184 | 200 | if (!$prev_row || ($prev_row->{status} // '') eq 'deleted') { |
| 185 | 201 | push @needs_hash, $p; |
| 186 | 202 | next; |
| 187 | 203 | } |
| 188 | 204 | if (($prev_row->{mt_epoch} // 0) != $remote{$p}{mtime}) { |
| 189 | 205 | push @needs_hash, $p; |
| 190 | 206 | } |
| 191 | 207 | } |
| 192 | 208 | |
| 193 | 209 | # ---- Batch hash over SSH ----------------------------------- |
| 194 | 210 | # `drift-hash <files>` returns sha256sum output: "<sha> <path>" |
| 195 | 211 | my %fresh_sha; |
| 196 | 212 | if (@needs_hash) { |
| 197 | 213 | my $q_list = join(' ', map { _sh_quote($_) } @needs_hash); |
| 198 | 214 | my $cmd = "drift-hash $q_list"; |
| 199 | 215 | my ($h_rc, $h_out, $h_err) = _ssh_run(\@ssh_base, $cmd); |
| 200 | 216 | if ($h_rc != 0) { |
| 201 | 217 | # Fallback: plain sha256sum |
| 202 | 218 | $cmd = "sha256sum $q_list 2>/dev/null"; |
| 203 | 219 | ($h_rc, $h_out, $h_err) = _ssh_run(\@ssh_base, $cmd); |
| 204 | 220 | } |
| 205 | 221 | if ($h_rc == 0) { |
| 206 | 222 | foreach my $line (split /\n/, $h_out) { |
| 207 | 223 | chomp $line; |
| 208 | 224 | if ($line =~ /^([0-9a-f]{64})\s+(.+)$/) { |
| 209 | 225 | $fresh_sha{$2} = $1; |
| 210 | 226 | } |
| 211 | 227 | } |
| 212 | 228 | } |
| 213 | 229 | } |
| 214 | 230 | |
| 215 | 231 | # ---- Process each remote file ------------------------------ |
| 216 | 232 | foreach my $p (keys %remote) { |
| 217 | 233 | my $sha = $fresh_sha{$p}; |
| 218 | 234 | my $prev_row = $prev{$p}; |
| 219 | 235 | |
| 220 | 236 | # If we didn't rehash this file, previous SHA still valid |
| 221 | 237 | if (!defined $sha && $prev_row && ($prev_row->{status} // '') ne 'deleted') { |
| 222 | 238 | # Nothing changed since last tick -- move on |
| 223 | 239 | next; |
| 224 | 240 | } |
| 225 | 241 | |
| 226 | 242 | # Content-addressable dedup: if we already have this SHA in |
| 227 | 243 | # BLOB_STORE, don't re-fetch content over SSH. |
| 228 | 244 | my $have = $db->db_readwrite($dbh, |
| 229 | 245 | "SELECT blob_sha FROM BLOB_STORE WHERE blob_sha = " . $dbh->quote($sha) . " LIMIT 1", |
| 230 | 246 | __FILE__, __LINE__); |
| 231 | 247 | |
| 232 | 248 | my $status; |
| 233 | 249 | if (!$prev_row) { |
| 234 | 250 | $status = 'added'; |
| 235 | 251 | } else { |
| 236 | 252 | $status = 'modified'; |
| 237 | 253 | if ($prev_row->{blob_sha} && $prev_row->{blob_sha} eq $sha) { |
| 238 | 254 | # Same bytes, just an mtime touch -- flag ts-only |
| 239 | 255 | $status = 'modified'; |
| 240 | 256 | } |
| 241 | 257 | } |
| 242 | 258 | |
| 243 | 259 | # Fetch + store blob only if we don't already have it |
| 244 | 260 | if (!($have && $have->{blob_sha})) { |
| 245 | 261 | my $cmd = 'drift-read ' . _sh_quote($p); |
| 246 | 262 | my ($c_rc, $c_out, $c_err) = _ssh_run(\@ssh_base, $cmd); |
| 247 | 263 | if ($c_rc != 0) { |
| 248 | 264 | $cmd = 'cat ' . _sh_quote($p); |
| 249 | 265 | ($c_rc, $c_out, $c_err) = _ssh_run(\@ssh_base, $cmd); |
| 250 | 266 | } |
| 251 | 267 | if ($c_rc != 0) { |
| 252 | 268 | print "[$ts] fetch $p on $server->{server_name}: $c_err\n"; |
| 253 | 269 | next; |
| 254 | 270 | } |
| 255 | 271 | # Verify the fetched content matches the reported hash |
| 256 | 272 | my $verify_sha = sha256_hex($c_out); |
| 257 | 273 | if ($verify_sha ne $sha) { |
| 258 | 274 | print "[$ts] $p: hash mismatch (list=$sha vs read=$verify_sha), using read\n"; |
| 259 | 275 | $sha = $verify_sha; |
| 260 | 276 | } |
| 261 | 277 | _store_blob($db, $dbh, $sha, $c_out); |
| 262 | 278 | } |
| 263 | 279 | |
| 264 | 280 | # Determine timestamp-only via prev SHA compare |
| 265 | 281 | my $is_ts_only = 0; |
| 266 | 282 | if ($prev_row && $prev_row->{blob_sha} && $prev_row->{blob_sha} eq $sha) { |
| 267 | 283 | $is_ts_only = 1; |
| 268 | 284 | } |
| 269 | 285 | |
| 270 | 286 | # Insert FILE_CHANGES row keyed to this server |
| 271 | 287 | my $q_file = $dbh->quote($p); |
| 272 | 288 | my $q_sha = $dbh->quote($sha); |
| 273 | 289 | my $q_stat = $dbh->quote($status); |
| 274 | 290 | my $mt = $remote{$p}{mtime}; |
| 275 | 291 | $db->db_readwrite($dbh, qq{ |
| 276 | 292 | INSERT INTO FILE_CHANGES |
| 277 | 293 | (file_monitor_list_id, server_id, container_target_id, |
| 278 | 294 | file_name, blob_sha, is_ts_only, date_time, status) |
| 279 | 295 | VALUES |
| 280 | 296 | ($scan->{file_monitor_list_id}, $sid, NULL, |
| 281 | 297 | $q_file, $q_sha, $is_ts_only, |
| 282 | 298 | FROM_UNIXTIME($mt), $q_stat) |
| 283 | 299 | }, __FILE__, __LINE__); |
| 284 | 300 | |
| 285 | 301 | if ($is_ts_only) { } |
| 286 | 302 | elsif ($status eq 'added') { $total_added++; } |
| 287 | 303 | else { $total_modified++; } |
| 288 | 304 | } |
| 289 | 305 | |
| 290 | 306 | # ---- Delete detection -------------------------------------- |
| 291 | 307 | foreach my $p (keys %prev) { |
| 292 | 308 | next if $remote{$p}; |
| 293 | 309 | next if ($prev{$p}{status} // '') eq 'deleted'; |
| 294 | 310 | my $q_file = $dbh->quote($p); |
| 295 | 311 | $db->db_readwrite($dbh, qq{ |
| 296 | 312 | INSERT INTO FILE_CHANGES |
| 297 | 313 | (file_monitor_list_id, server_id, file_name, status, date_time) |
| 298 | 314 | VALUES |
| 299 | 315 | ($scan->{file_monitor_list_id}, $sid, $q_file, 'deleted', NOW()) |
| 300 | 316 | }, __FILE__, __LINE__); |
| 301 | 317 | $total_deleted++; |
| 302 | 318 | } |
| 303 | 319 | |
| 304 | 320 | $db->db_readwrite($dbh, qq{ |
| 305 | 321 | UPDATE FILE_MONITOR_SETTINGS |
| 306 | 322 | SET last_scanned = NOW() |
| 307 | 323 | WHERE file_monitor_list_id = $scan->{file_monitor_list_id} |
| 308 | 324 | }, __FILE__, __LINE__); |
| 309 | 325 | } |
| 310 | 326 | |
| 311 | 327 | # Server-level bookkeeping |
| 312 | 328 | my $q_err = $dbh->quote($server_err || ''); |
| 313 | 329 | $db->db_readwrite($dbh, qq{ |
| 314 | 330 | UPDATE SERVERS |
| 315 | 331 | SET last_agent_scan_at = NOW(), |
| 316 | 332 | last_agent_error = $q_err, |
| 317 | 333 | last_heartbeat_at = NOW() |
| 318 | 334 | WHERE server_id = $sid |
| 319 | 335 | }, __FILE__, __LINE__); |
| 320 | 336 | |
| 321 | 337 | # Clean up decrypted-key temp file |
| 322 | 338 | unlink $tmp_key if $tmp_key && $tmp_key =~ m!^/tmp/\.ds_agent_key_!; |
| 323 | 339 | } |
| 324 | 340 | |
| 325 | 341 | $db->db_disconnect($dbh); |
| 326 | 342 | print "[$ts] agent scan complete: +$total_added added, ~$total_modified modified, -$total_deleted deleted\n" |
| 327 | 343 | if ($total_added + $total_modified + $total_deleted) > 0; |
| 328 | 344 | exit 0; |
| 329 | 345 | |
| 330 | 346 | #--------------------------------------------------------------------- |
| 331 | 347 | sub _ssh_argv { |
| 332 | 348 | my ($user, $host, $port, $key, $opts) = @_; |
| 333 | 349 | my @a = ('/usr/bin/ssh', |
| 334 | 350 | '-o', 'BatchMode=yes', |
| 335 | 351 | '-o', 'StrictHostKeyChecking=no', |
| 336 | 352 | '-o', 'UserKnownHostsFile=/dev/null', |
| 337 | 353 | '-o', 'LogLevel=ERROR', |
| 338 | 354 | '-o', 'ConnectTimeout=8', |
| 339 | 355 | '-p', $port); |
| 340 | 356 | if ($key && -r $key) { |
| 341 | 357 | push @a, '-i', $key; |
| 342 | 358 | } |
| 343 | 359 | if ($opts) { |
| 344 | 360 | # Space-separated -o key=value pairs |
| 345 | 361 | foreach my $o (split /\s+/, $opts) { |
| 346 | 362 | push @a, '-o', $o if length $o; |
| 347 | 363 | } |
| 348 | 364 | } |
| 349 | 365 | push @a, "$user\@$host"; |
| 350 | 366 | return @a; |
| 351 | 367 | } |
| 352 | 368 | |
| 353 | 369 | sub _ssh_run { |
| 354 | 370 | my ($base, $cmd) = @_; |
| 355 | 371 | my @argv = (@$base, $cmd); |
| 356 | 372 | my ($wtr, $rdr, $err_fh); |
| 357 | 373 | $err_fh = gensym; |
| 358 | 374 | my $pid = eval { open3($wtr, $rdr, $err_fh, @argv) }; |
| 359 | 375 | return (-1, '', $@) if $@ || !$pid; |
| 360 | 376 | close $wtr; |
| 361 | 377 | binmode $rdr; |
| 362 | 378 | my $out = do { local $/; <$rdr> // '' }; |
| 363 | 379 | my $err = do { local $/; <$err_fh> // '' }; |
| 364 | 380 | close $rdr; close $err_fh; |
| 365 | 381 | waitpid $pid, 0; |
| 366 | 382 | my $rc = $? >> 8; |
| 367 | 383 | return ($rc, $out, $err); |
| 368 | 384 | } |
| 369 | 385 | |
| 370 | 386 | sub _materialize_key { |
| 371 | 387 | my ($pem) = @_; |
| 372 | 388 | return undef unless defined $pem && length $pem; |
| 373 | 389 | my $t = POSIX::strftime('%s', localtime); |
| 374 | 390 | my $path = "/tmp/.ds_agent_key_${t}_$$_" . int(rand(1_000_000)); |
| 375 | 391 | sysopen(my $fh, $path, |
| 376 | 392 | Fcntl::O_WRONLY() | Fcntl::O_CREAT() | Fcntl::O_EXCL(), |
| 377 | 393 | 0600) or return undef; |
| 378 | 394 | print $fh $pem; |
| 379 | 395 | close $fh; |
| 380 | 396 | return $path; |
| 381 | 397 | } |
| 382 | 398 | |
| 383 | 399 | sub _sh_quote { |
| 384 | 400 | my $s = shift; $s //= ''; |
| 385 | 401 | # Single-quote and escape internal single quotes |
| 386 | 402 | $s =~ s/'/'\\''/g; |
| 387 | 403 | return "'$s'"; |
| 388 | 404 | } |
| 389 | 405 | |
| 390 | 406 | sub _build_ignore_patterns { |
| 391 | 407 | my $list = shift; |
| 392 | 408 | my %out; |
| 393 | 409 | return %out unless $list; |
| 394 | 410 | for my $ig (split /[,\n]+/, $list) { |
| 395 | 411 | $ig =~ s/^\s+|\s+$//g; |
| 396 | 412 | next unless length $ig; |
| 397 | 413 | my $re = quotemeta $ig; |
| 398 | 414 | $re =~ s/\\\*/.*/g; |
| 399 | 415 | $re =~ s/\\\?/./g; |
| 400 | 416 | $out{$ig} = qr/$re/; |
| 401 | 417 | } |
| 402 | 418 | return %out; |
| 403 | 419 | } |
| 404 | 420 | |
| 405 | 421 | sub _build_type_filter { |
| 406 | 422 | my $list = shift; |
| 407 | 423 | my %out; |
| 408 | 424 | return %out unless $list && length $list; |
| 409 | 425 | for my $ext (split /,/, $list) { |
| 410 | 426 | $ext =~ s/^\s+|\s+$//g; |
| 411 | 427 | next unless length $ext; |
| 412 | 428 | $ext = ".$ext" unless $ext =~ /^\./; |
| 413 | 429 | $out{lc $ext} = 1; |
| 414 | 430 | } |
| 415 | 431 | return %out; |
| 416 | 432 | } |
| 417 | 433 | |
| 418 | 434 | sub _store_blob { |
| 419 | 435 | my ($db, $dbh, $sha, $content) = @_; |
| 420 | 436 | my $existing = $db->db_readwrite($dbh, |
| 421 | 437 | "SELECT blob_sha FROM BLOB_STORE WHERE blob_sha = " . $dbh->quote($sha) . " LIMIT 1", |
| 422 | 438 | __FILE__, __LINE__); |
| 423 | 439 | if ($existing && $existing->{blob_sha}) { |
| 424 | 440 | $db->db_readwrite($dbh, |
| 425 | 441 | "UPDATE BLOB_STORE SET ref_count = ref_count + 1 WHERE blob_sha = " . $dbh->quote($sha), |
| 426 | 442 | __FILE__, __LINE__); |
| 427 | 443 | return; |
| 428 | 444 | } |
| 429 | 445 | my $gz = compress($content) // ''; |
| 430 | 446 | my $sth = $dbh->prepare(qq{ |
| 431 | 447 | INSERT INTO BLOB_STORE (blob_sha, content_gz, size_uncompressed, size_compressed, ref_count, first_seen_at) |
| 432 | 448 | VALUES (?, ?, ?, ?, 1, NOW()) |
| 433 | 449 | }); |
| 434 | 450 | if ($sth) { |
| 435 | 451 | $sth->execute($sha, $gz, length($content), length($gz)); |
| 436 | 452 | $sth->finish; |
| 437 | 453 | } |
| 438 | 454 | } |