chiark / gitweb /
Tests: Introduce t-set-using-tmp and use it in lib and adhoc
[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     # 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->();