infra/dgit-repos-admin-debian

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