xref: /curl/tests/serverhelp.pm (revision 7f3d5982) 
1#***************************************************************************
2#                                  _   _ ____  _
3#  Project                     ___| | | |  _ \| |
4#                             / __| | | | |_) | |
5#                            | (__| |_| |  _ <| |___
6#                             \___|\___/|_| \_\_____|
7#
8# Copyright (C) Daniel Stenberg, <daniel@haxx.se>, et al.
9#
10# This software is licensed as described in the file COPYING, which
11# you should have received as part of this distribution. The terms
12# are also available at https://curl.se/docs/copyright.html.
13#
14# You may opt to use, copy, modify, merge, publish, distribute and/or sell
15# copies of the Software, and permit persons to whom the Software is
16# furnished to do so, under the terms of the COPYING file.
17#
18# This software is distributed on an "AS IS" basis, WITHOUT WARRANTY OF ANY
19# KIND, either express or implied.
20#
21# SPDX-License-Identifier: curl
22#
23#***************************************************************************
24
25# This perl module contains functions useful in writing test servers.
26
27package serverhelp;
28
29use strict;
30use warnings;
31
32BEGIN {
33    use base qw(Exporter);
34
35    our @EXPORT_OK = qw(
36        logmsg
37        $logfile
38        serverfactors
39        servername_id
40        servername_str
41        servername_canon
42        server_pidfilename
43        server_portfilename
44        server_logfilename
45        server_cmdfilename
46        server_inputfilename
47        server_outputfilename
48        mainsockf_pidfilename
49        mainsockf_logfilename
50        datasockf_pidfilename
51        datasockf_logfilename
52    );
53
54    # sub second timestamping needs Time::HiRes
55    eval {
56        no warnings "all";
57        require Time::HiRes;
58        import  Time::HiRes qw( gettimeofday );
59    }
60}
61
62
63our $logfile;  # server log file name, for logmsg
64
65#***************************************************************************
66# Just for convenience, test harness uses 'https' and 'httptls' literals as
67# values for 'proto' variable in order to differentiate different servers.
68# 'https' literal is used for stunnel based https test servers, and 'httptls'
69# is used for non-stunnel https test servers.
70
71#**********************************************************************
72# logmsg is general message logging subroutine for our test servers.
73#
74sub logmsg {
75    my $now;
76    # sub second timestamping needs Time::HiRes
77    if($Time::HiRes::VERSION) {
78        my ($seconds, $usec) = gettimeofday();
79        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
80            localtime($seconds);
81        $now = sprintf("%02d:%02d:%02d.%06d ", $hour, $min, $sec, $usec);
82    }
83    else {
84        my $seconds = time();
85        my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) =
86            localtime($seconds);
87        $now = sprintf("%02d:%02d:%02d ", $hour, $min, $sec);
88    }
89    # we see warnings on Windows run that $logfile is used uninitialized
90    # TODO: not found yet where this comes from
91    $logfile = "serverhelp_uninitialized.log" if(!$logfile);
92    if(open(my $logfilefh, ">>", "$logfile")) {
93        print $logfilefh $now;
94        print $logfilefh @_;
95        close($logfilefh);
96    }
97}
98
99
100#***************************************************************************
101# Return server characterization factors given a server id string.
102#
103sub serverfactors {
104    my $server = $_[0];
105    my $proto;
106    my $ipvnum;
107    my $idnum;
108
109    if($server =~
110        /^((ftp|http|imap|pop3|smtp|http-pipe)s?)(\d*)(-ipv6|)$/) {
111        $proto  = $1;
112        $idnum  = ($3 && ($3 > 1)) ? $3 : 1;
113        $ipvnum = ($4 && ($4 =~ /6$/)) ? 6 : 4;
114    }
115    elsif($server =~
116        /^(tftp|sftp|socks|ssh|rtsp|gopher|httptls)(\d*)(-ipv6|)$/) {
117        $proto  = $1;
118        $idnum  = ($2 && ($2 > 1)) ? $2 : 1;
119        $ipvnum = ($3 && ($3 =~ /6$/)) ? 6 : 4;
120    }
121    else {
122        die "invalid server id: '$server'"
123    }
124    return($proto, $ipvnum, $idnum);
125}
126
127
128#***************************************************************************
129# Return server name string formatted for presentation purposes
130#
131sub servername_str {
132    my ($proto, $ipver, $idnum) = @_;
133
134    $proto = uc($proto) if($proto);
135    die "unsupported protocol: '$proto'" unless($proto &&
136        ($proto =~ /^(((FTP|HTTP|HTTP\/2|HTTP\/3|IMAP|POP3|GOPHER|SMTP|HTTP-PIPE)S?)|(TFTP|SFTP|SOCKS|SSH|RTSP|HTTPTLS|DICT|SMB|SMBS|TELNET|MQTT))$/));
137
138    $ipver = (not $ipver) ? 'ipv4' : lc($ipver);
139    die "unsupported IP version: '$ipver'" unless($ipver &&
140        ($ipver =~ /^(4|6|ipv4|ipv6|-ipv4|-ipv6|unix)$/));
141    $ipver = ($ipver =~ /6$/) ? '-IPv6' : (($ipver =~ /unix$/) ? '-unix' : '');
142
143    $idnum = 1 if(not $idnum);
144    die "unsupported ID number: '$idnum'" unless($idnum &&
145        ($idnum =~ /^(\d+)$/));
146    $idnum = '' if($idnum <= 1);
147
148    return "${proto}${idnum}${ipver}";
149}
150
151
152#***************************************************************************
153# Return server name string formatted for identification purposes
154#
155sub servername_id {
156    my ($proto, $ipver, $idnum) = @_;
157    return lc(servername_str($proto, $ipver, $idnum));
158}
159
160
161#***************************************************************************
162# Return server name string formatted for file name purposes
163#
164sub servername_canon {
165    my ($proto, $ipver, $idnum) = @_;
166    my $string = lc(servername_str($proto, $ipver, $idnum));
167    $string =~ tr/-/_/;
168    $string =~ s/\//_v/;
169    return $string;
170}
171
172
173#***************************************************************************
174# Return file name for server pid file.
175#
176sub server_pidfilename {
177    my ($piddir, $proto, $ipver, $idnum) = @_;
178    my $trailer = '_server.pid';
179    return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
180}
181
182#***************************************************************************
183# Return file name for server port file.
184#
185sub server_portfilename {
186    my ($piddir, $proto, $ipver, $idnum) = @_;
187    my $trailer = '_server.port';
188    return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
189}
190
191
192#***************************************************************************
193# Return file name for server log file.
194#
195sub server_logfilename {
196    my ($logdir, $proto, $ipver, $idnum) = @_;
197    my $trailer = '_server.log';
198    $trailer = '_stunnel.log' if(lc($proto) =~ /^(ftp|http|imap|pop3|smtp)s$/);
199    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
200}
201
202
203#***************************************************************************
204# Return file name for server commands file.
205#
206sub server_cmdfilename {
207    my ($logdir, $proto, $ipver, $idnum) = @_;
208    my $trailer = '_server.cmd';
209    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
210}
211
212
213#***************************************************************************
214# Return file name for server input file.
215#
216sub server_inputfilename {
217    my ($logdir, $proto, $ipver, $idnum) = @_;
218    my $trailer = '_server.input';
219    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
220}
221
222
223#***************************************************************************
224# Return file name for server output file.
225#
226sub server_outputfilename {
227    my ($logdir, $proto, $ipver, $idnum) = @_;
228    my $trailer = '_server.output';
229    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
230}
231
232
233#***************************************************************************
234# Return file name for main or primary sockfilter pid file.
235#
236sub mainsockf_pidfilename {
237    my ($piddir, $proto, $ipver, $idnum) = @_;
238    die "unsupported protocol: '$proto'" unless($proto &&
239        (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
240    my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.pid':'_sockfilt.pid';
241    return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
242}
243
244
245#***************************************************************************
246# Return file name for main or primary sockfilter log file.
247#
248sub mainsockf_logfilename {
249    my ($logdir, $proto, $ipver, $idnum) = @_;
250    die "unsupported protocol: '$proto'" unless($proto &&
251        (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
252    my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.log':'_sockfilt.log';
253    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
254}
255
256
257#***************************************************************************
258# Return file name for data or secondary sockfilter pid file.
259#
260sub datasockf_pidfilename {
261    my ($piddir, $proto, $ipver, $idnum) = @_;
262    die "unsupported protocol: '$proto'" unless($proto &&
263        (lc($proto) =~ /^ftps?$/));
264    my $trailer = '_sockdata.pid';
265    return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
266}
267
268
269#***************************************************************************
270# Return file name for data or secondary sockfilter log file.
271#
272sub datasockf_logfilename {
273    my ($logdir, $proto, $ipver, $idnum) = @_;
274    die "unsupported protocol: '$proto'" unless($proto &&
275        (lc($proto) =~ /^ftps?$/));
276    my $trailer = '_sockdata.log';
277    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
278}
279
280
281#***************************************************************************
282# End of library
2831;
284