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