1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
|
#!/usr/bin/env perl
#
# This file is part of gcli.
#
# Copyright Nico Sonack <nsonack@herrhotzenplotz.de>
package server;
use strict;
use warnings;
our @EXPORT = qw(
runserver
kill
rungcli
);
use IO::Socket qw(AF_INET SOCK_STREAM IPPROTO_TCP);
use Socket qw(unpack_sockaddr_in pack_sockaddr_in inet_aton inet_ntoa);
use IO::File;
use Cwd;
sub new {
my %parms = @_;
my $cfg_file_name = "gcli_" . $parms{'id'} . ".conf";
my $srv_out_file = "gcli_" . $parms{'id'} . ".srv.out";
my $srv_log_file = "gcli_" . $parms{'id'} . ".srv.log";
my $gcli_out_file = "gcli_" . $parms{'id'} . ".console.log";
##################################################################
# Open Socket
my $lsock = IO::Socket->new(
Domain => AF_INET,
Type => SOCK_STREAM,
Proto => IPPROTO_TCP,
);
$lsock->bind(pack_sockaddr_in(0, inet_aton("127.0.0.1"))) or die "bind";
$lsock->listen(5);
my ($port, $ip) = unpack_sockaddr_in($lsock->sockname());
my $str_ip = inet_ntoa($ip);
##################################################################
# Write config file
my $config_file = IO::File->new($cfg_file_name, "w");
$config_file->print(<<EOF);
defaults {
gitlab-default-account = gitlab
github-default-account = github
gitea-default-account = gitea
bugzilla-default-account = bugzilla
disable-spinner = true
}
gitlab {
forge-type = gitlab
token = foobar
account = tester
apibase = http://${str_ip}:${port}
}
gitea {
forge-type = gitea
token = foobar
account = tester
apibase = http://${str_ip}:${port}
}
bugzilla {
forge-type = bugzilla
token = foobar
account = tester
apibase = http://${str_ip}:${port}
}
github {
forge-type = github
token = foobar
account = tester
apibase = http://${str_ip}:${port}
}
EOF
$config_file->flush();
$config_file->close();
my $pid = fork;
if ($pid != 0 ) {
return bless {
pid => $pid,
lsock => $lsock,
cfg_file_name => $cfg_file_name,
srv_out_file => $srv_out_file,
gcli_out_file => $gcli_out_file,
};
}
open my $srv_log, '>', $srv_log_file or die "cannot open server log file";
$srv_log->autoflush;
#################################################################
# event loop
my $max_reqs = scalar(@{$parms{'responses'}});
printf $srv_log "Waiting for %d requests\n", $max_reqs;
for (my $i = 0; $i < $max_reqs; ++$i) {
my $client_sock = $lsock->accept();
my ($client_port, $client_ip) = unpack_sockaddr_in($client_sock->peername());
my $client_ip_str = inet_ntoa($client_ip);
my $srv_out = IO::File->new($srv_out_file . ".${i}", "w");
my $rsp = $parms{'responses'}[$i];
print $srv_log "Received connection from ${client_ip_str}\n";
# Request
while (my $line = $client_sock->getline()) {
$line =~ s/\r\n$//;
print $srv_out "$line\n";
print $srv_log " > $line\n";
last if length($line) == 0;
}
$srv_out->flush();
$srv_out->close();
$rsp =~ s/\@SERVERURL\@/http:\/\/${str_ip}:${port}/g;
print $srv_log "Response is as follows\n";
print $srv_log $rsp;
$client_sock->printf("%s", $rsp);
$client_sock->close();
}
$srv_log->flush();
$srv_log->close();
exit 0;
}
sub kill {
my ($self) = @_;
kill('KILL', $self->{'pid'});
waitpid $self->{'pid'}, 0;
$self->{'lsock'}->close();
unlink $self->{'cfg_file_name'};
}
sub run_gcli {
my ($srv, $args) = @_;
my $cwd = getcwd();
my $cmd = "$cwd/gcli -C $srv->{'cfg_file_name'} $args 2>&1";
open my $logfile, '>', $srv->{'gcli_out_file'};
$logfile->autoflush;
my $output = qx($cmd);
my $rc = $? >> 8; # see perldoc perlop
$logfile->print($output);
$logfile->close();
return (VerifyClientExitCode => $rc, VerifyClientOutput => $output);
}
sub get_request {
my ($srv, $i) = @_;
# Open server output file
open my $f, '<', $srv->{'srv_out_file'} . ".$i";
# Parse the request line
my ($method, $path, $version) = split ' ', <$f>;
# Parse headers
my @headers = ();
while (my $ln = <$f>) {
last if ($ln eq "\r\n");
my ($k, $v) = split ": ", $ln;
push(@headers, { $k => $v });
}
# And the body
my $body = "";
while (my $ln = <$f>) {
$body = $body . $ln;
}
return bless {
VerifyRequestMethod => $method,
VerifyRequestPath => $path,
VerifyRequestVersion => $version,
VerifyRequestHeaders => \@headers,
VerifyRequestBody => $body,
};
}
1;
|
