chiark / gitweb /
changelog: start 6.1
[dgit.git] / 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->();