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     # the field `deliberately' contains `--deliberately-blah-blah',
 125     # not just `blah blah'.
 126     $poldbh->do(<<END);
 127         CREATE TABLE IF NOT EXISTS taintoverrides (
 128             taint_id  INTEGER NOT NULL
 129                       REFERENCES taints (taint_id)
 130                           ON UPDATE RESTRICT
 131                           ON DELETE CASCADE
 132                       DEFERRABLE INITIALLY DEFERRED,
 133             deliberately TEXT NOT NULL,
 134             PRIMARY KEY (taint_id, deliberately)
 135         )
 136 END
 137
 138     $poldbh->commit;
 139 }
 140
 141 sub show_taints_bypackage ($) {
 142     my ($m) = @_;
 143     show_taints($m, "package = ?", $p);
 144 }
 145
 146 sub show_taints_bygitobjid ($) {
 147     my ($m) = @_;
 148     show_taints($m, "gitobjid = ?", $gitobjid);
 149 }
 150
 151 sub show_relevant_taints ($) {
 152     my ($what) = @_;
 153     show_taints_bypackage($p ? "$what taints for package $p"
 154                           : "$what global taints");
 155     show_taints_bygitobjid("$what taints for object $gitobjid");
 156 }
 157
 158 sub cmd_taint () {
 159     get_package_objid();
 160     my $comment = shift @ARGV;
 161     $comment // badusage "operation needs comment";
 162     @ARGV && badusage "too many arguments to taint";
 163
 164     sort_out_git_dir();
 165     $!=0; $?=0; my $objtype = `git cat-file -t $gitobjid`;
 166     chomp $objtype or die "$? $!";
 167
 168     $poldbh->do("INSERT INTO taints".
 169                 " (package, gitobjid, gitobjtype, time, comment)".
 170                 " VALUES (?,?,?,?,?)", {},
 171                 $p, $gitobjid, $objtype, time, $comment);
 172     $poldbh->commit;
 173     print "taint added\n" or die $!;
 174     show_relevant_taints("resulting");
 175 }
 176
 177 sub cmd_untaint () {
 178     get_package_objid();
 179     @ARGV && badusage "too many arguments to untaint";
 180
 181     show_relevant_taints("existing");
 182     my $affected =
 183         $poldbh->do("DELETE FROM taints".
 184                     " WHERE package = ? AND gitobjid = ?",
 185                     {}, $p, $gitobjid);
 186     $poldbh->commit;
 187     printf "%d taints removed\n", $affected or die $!;
 188     exit $affected ? 0 : 1;
 189 }
 190
 191
 192 my $cmd = shift @ARGV;
 193 $cmd // badusage "need operation";
 194
 195 $cmd =~ y/-/_/;
 196 my $fn = ${*::}{"cmd_$cmd"};
 197 $fn or badusage "unknown operation $cmd";
 198
 199 poldb_setup($db_path);
 200
 201 $fn->();