chiark / gitweb /
git_for_each_ref: Fix FH handling
[dgit.git] / 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->();