infra/dgit-repos-admin-debian

   1 #!/usr/bin/perl -w
   2 # dgit repos policy admin script for Debian
   3
   4 use strict;
   5
   6 use Debian::Dgit;
   7 setup_sigwarn();
   8
   9 our $usage = <<'END';
  10 usage:
  11   dgit-repos-admin-debian [<options>] operation...
  12 options:
  13   --git-dir /path/to/git/repo/or/working/tree
  14   --repos /path/to/dgit/repos/directory    } alternatives
  15   --db /path/to/dgit/repos/policy.sqlite3  }
  16   (at least one of above required; if only one, cwd is used for other)
  17 operations:
  18   create-db
  19   list-taints
  20   taint [--global|<package>] <gitobjid> '<comment>'
  21   untaint [--global|<package>] <gitobjid>
  22 END
  23
  24 use POSIX;
  25 use DBI;
  26
  27 use Debian::Dgit::Policy::Debian;
  28
  29 sub badusage ($) { die "bad usage: $_[0]\n$usage"; }
  30
  31 use Getopt::Long qw(:config posix_default gnu_compat bundling);
  32
  33 our ($git_dir,$repos_dir,$db_path);
  34
  35 GetOptions("git-dir=s" => \$git_dir,
  36            "repos=s" => \$repos_dir,
  37            "db=s" => \$db_path)
  38     or die $usage;
  39
  40 $db_path //= poldb_path($repos_dir) if defined $repos_dir;
  41 $db_path // $repos_dir ||
  42     die <<'END'.$usage;
  43 Must supply --git-dir and/or --repos (or --db instead of --repos).
  44 If only one of --git-dir and --repos is supplied, other is taken to
  45 be current working directory.
  46 END
  47 # /
  48
  49 $git_dir //= '.';
  50 $repos_dir //= '.';
  51
  52 our $p;
  53 our $gitobjid;
  54
  55 sub get_package_objid () {
  56     $p = shift @ARGV;  $p // badusage "operation needs package or --global";
  57     if ($p eq '--global') {
  58         $p = '';
  59     } else {
  60         $p =~ m/^$package_re$/ or badusage 'package name or --global needed';
  61     }
  62     $gitobjid = shift @ARGV;
  63     $gitobjid // badusage "operation needs git object id";
  64     $gitobjid =~ m/\W/ && badusage "invalid git object id";
  65 }
  66
  67 sub sort_out_git_dir () {
  68     foreach my $sfx ('/.git', '') {
  69         my $path = "$git_dir/$sfx";
  70         if (stat_exists "$path/objects") {
  71             $ENV{GIT_DIR} = $git_dir = $path;
  72             return;
  73         }
  74     }
  75     die "git directory $git_dir doesn't seem valid\n";
  76 }
  77
  78 sub show_taints ($$@) {
  79     my ($m, $cond, @condargs) = @_;
  80     my $q = $poldbh->prepare
  81         ("SELECT package,gitobjid,gitobjtype,time,comment, ".
  82          " (gitobjdata IS NOT NULL) hasdata".
  83          " FROM taints WHERE $cond".
  84          " ORDER BY package, gitobjid, time");
  85     $q->execute(@condargs);
  86     print "$m:\n" or die $!;
  87     my $count = 0;
  88     while (my $row = $q->fetchrow_hashref) {
  89         my $t = strftime "%Y-%m-%dT%H:%M:%S", gmtime $row->{time};
  90         my $objinfo = $row->{gitobjtype}. ($row->{hasdata} ? '+' : ' ');
  91         my $comment = $row->{comment};
  92         $comment =~ s/\\/\\\\/g; $comment =~ s/\n/\\n/g;
  93         printf(" %s %-30s %s %7s %s\n",
  94                $t, $row->{package}, $row->{gitobjid},
  95                $objinfo, $row->{comment})
  96             or die $!;
  97         $count++;
  98     }
  99     return $count;
 100 }
 101
 102 sub cmd_list_taints ($) {
 103     badusage "no args/options" if @ARGV;
 104     my $count = show_taints("all taints","1");
 105     printf "%d taints listed\n", $count or die $!;
 106 }
 107
 108 sub cmd_create_db ($) {
 109     badusage "no args/options" if @ARGV;
 110
 111     $poldbh->do(<<END);
 112         CREATE TABLE IF NOT EXISTS taints (
 113             taint_id   INTEGER NOT NULL PRIMARY KEY ASC AUTOINCREMENT,
 114             package    TEXT    NOT NULL,
 115             gitobjid   TEXT    NOT NULL,
 116             comment    TEXT    NOT NULL,
 117             time       INTEGER,
 118             gitobjtype TEXT,
 119             gitobjdata TEXT
 120             )
 121 END
 122     $poldbh->do(<<END);
 123         CREATE INDEX IF NOT EXISTS taints_by_gitobjid
 124             ON taints (gitobjid, package)
 125 END
 126     # any one of of the listed deliberatelies will override its taint
 127     # the field `deliberately' contains `--deliberately-blah-blah',
 128     # not just `blah blah'.
 129     $poldbh->do(<<END);
 130         CREATE TABLE IF NOT EXISTS taintoverrides (
 131             taint_id  INTEGER NOT NULL
 132                       REFERENCES taints (taint_id)
 133                           ON UPDATE RESTRICT
 134                           ON DELETE CASCADE
 135                       DEFERRABLE INITIALLY DEFERRED,
 136             deliberately TEXT NOT NULL,
 137             PRIMARY KEY (taint_id, deliberately)
 138         )
 139 END
 140
 141     $poldbh->commit;
 142 }
 143
 144 sub show_taints_bypackage ($) {
 145     my ($m) = @_;
 146     show_taints($m, "package = ?", $p);
 147 }
 148
 149 sub show_taints_bygitobjid ($) {
 150     my ($m) = @_;
 151     show_taints($m, "gitobjid = ?", $gitobjid);
 152 }
 153
 154 sub show_relevant_taints ($) {
 155     my ($what) = @_;
 156     show_taints_bypackage($p ? "$what taints for package $p"
 157                           : "$what global taints");
 158     show_taints_bygitobjid("$what taints for object $gitobjid");
 159 }
 160
 161 sub cmd_taint () {
 162     get_package_objid();
 163     my $comment = shift @ARGV;
 164     $comment // badusage "operation needs comment";
 165     @ARGV && badusage "too many arguments to taint";
 166
 167     sort_out_git_dir();
 168     $!=0; $?=0; my $objtype = `git cat-file -t $gitobjid`;
 169     chomp $objtype or die "$? $!";
 170
 171     $poldbh->do("INSERT INTO taints".
 172                 " (package, gitobjid, gitobjtype, time, comment)".
 173                 " VALUES (?,?,?,?,?)", {},
 174                 $p, $gitobjid, $objtype, time, $comment);
 175     $poldbh->commit;
 176     print "taint added\n" or die $!;
 177     show_relevant_taints("resulting");
 178 }
 179
 180 sub cmd_untaint () {
 181     get_package_objid();
 182     @ARGV && badusage "too many arguments to untaint";
 183
 184     show_relevant_taints("existing");
 185     my $affected =
 186         $poldbh->do("DELETE FROM taints".
 187                     " WHERE package = ? AND gitobjid = ?",
 188                     {}, $p, $gitobjid);
 189     $poldbh->commit;
 190     printf "%d taints removed\n", $affected or die $!;
 191     exit $affected ? 0 : 1;
 192 }
 193
 194
 195 my $cmd = shift @ARGV;
 196 $cmd // badusage "need operation";
 197
 198 $cmd =~ y/-/_/;
 199 my $fn = ${*::}{"cmd_$cmd"};
 200 $fn or badusage "unknown operation $cmd";
 201
 202 poldb_setup($db_path);
 203
 204 $fn->();