infra/dgit-repos-admin-debian

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