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