xref: /curl/tests/serverhelp.pm (revision dee50c9c) 
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    if(open(my $logfilefh, ">>", "$logfile")) {
90        print $logfilefh $now;
91        print $logfilefh @_;
92        close($logfilefh);
93    }
94}
95
96
97#***************************************************************************
98# Return server characterization factors given a server id string.
99#
100sub serverfactors {
101    my $server = $_[0];
102    my $proto;
103    my $ipvnum;
104    my $idnum;
105
106    if($server =~
107        /^((ftp|http|imap|pop3|smtp|http-pipe)s?)(\d*)(-ipv6|)$/) {
108        $proto  = $1;
109        $idnum  = ($3 && ($3 > 1)) ? $3 : 1;
110        $ipvnum = ($4 && ($4 =~ /6$/)) ? 6 : 4;
111    }
112    elsif($server =~
113        /^(tftp|sftp|socks|ssh|rtsp|gopher|httptls)(\d*)(-ipv6|)$/) {
114        $proto  = $1;
115        $idnum  = ($2 && ($2 > 1)) ? $2 : 1;
116        $ipvnum = ($3 && ($3 =~ /6$/)) ? 6 : 4;
117    }
118    else {
119        die "invalid server id: '$server'"
120    }
121    return($proto, $ipvnum, $idnum);
122}
123
124
125#***************************************************************************
126# Return server name string formatted for presentation purposes
127#
128sub servername_str {
129    my ($proto, $ipver, $idnum) = @_;
130
131    $proto = uc($proto) if($proto);
132    die "unsupported protocol: '$proto'" unless($proto &&
133        ($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))$/));
134
135    $ipver = (not $ipver) ? 'ipv4' : lc($ipver);
136    die "unsupported IP version: '$ipver'" unless($ipver &&
137        ($ipver =~ /^(4|6|ipv4|ipv6|-ipv4|-ipv6|unix)$/));
138    $ipver = ($ipver =~ /6$/) ? '-IPv6' : (($ipver =~ /unix$/) ? '-unix' : '');
139
140    $idnum = 1 if(not $idnum);
141    die "unsupported ID number: '$idnum'" unless($idnum &&
142        ($idnum =~ /^(\d+)$/));
143    $idnum = '' if($idnum <= 1);
144
145    return "${proto}${idnum}${ipver}";
146}
147
148
149#***************************************************************************
150# Return server name string formatted for identification purposes
151#
152sub servername_id {
153    my ($proto, $ipver, $idnum) = @_;
154    return lc(servername_str($proto, $ipver, $idnum));
155}
156
157
158#***************************************************************************
159# Return server name string formatted for file name purposes
160#
161sub servername_canon {
162    my ($proto, $ipver, $idnum) = @_;
163    my $string = lc(servername_str($proto, $ipver, $idnum));
164    $string =~ tr/-/_/;
165    $string =~ s/\//_v/;
166    return $string;
167}
168
169
170#***************************************************************************
171# Return file name for server pid file.
172#
173sub server_pidfilename {
174    my ($piddir, $proto, $ipver, $idnum) = @_;
175    my $trailer = '_server.pid';
176    return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
177}
178
179#***************************************************************************
180# Return file name for server port file.
181#
182sub server_portfilename {
183    my ($piddir, $proto, $ipver, $idnum) = @_;
184    my $trailer = '_server.port';
185    return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
186}
187
188
189#***************************************************************************
190# Return file name for server log file.
191#
192sub server_logfilename {
193    my ($logdir, $proto, $ipver, $idnum) = @_;
194    my $trailer = '_server.log';
195    $trailer = '_stunnel.log' if(lc($proto) =~ /^(ftp|http|imap|pop3|smtp)s$/);
196    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
197}
198
199
200#***************************************************************************
201# Return file name for server commands file.
202#
203sub server_cmdfilename {
204    my ($logdir, $proto, $ipver, $idnum) = @_;
205    my $trailer = '_server.cmd';
206    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
207}
208
209
210#***************************************************************************
211# Return file name for server input file.
212#
213sub server_inputfilename {
214    my ($logdir, $proto, $ipver, $idnum) = @_;
215    my $trailer = '_server.input';
216    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
217}
218
219
220#***************************************************************************
221# Return file name for server output file.
222#
223sub server_outputfilename {
224    my ($logdir, $proto, $ipver, $idnum) = @_;
225    my $trailer = '_server.output';
226    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
227}
228
229
230#***************************************************************************
231# Return file name for main or primary sockfilter pid file.
232#
233sub mainsockf_pidfilename {
234    my ($piddir, $proto, $ipver, $idnum) = @_;
235    die "unsupported protocol: '$proto'" unless($proto &&
236        (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
237    my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.pid':'_sockfilt.pid';
238    return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
239}
240
241
242#***************************************************************************
243# Return file name for main or primary sockfilter log file.
244#
245sub mainsockf_logfilename {
246    my ($logdir, $proto, $ipver, $idnum) = @_;
247    die "unsupported protocol: '$proto'" unless($proto &&
248        (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
249    my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.log':'_sockfilt.log';
250    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
251}
252
253
254#***************************************************************************
255# Return file name for data or secondary sockfilter pid file.
256#
257sub datasockf_pidfilename {
258    my ($piddir, $proto, $ipver, $idnum) = @_;
259    die "unsupported protocol: '$proto'" unless($proto &&
260        (lc($proto) =~ /^ftps?$/));
261    my $trailer = '_sockdata.pid';
262    return "${piddir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
263}
264
265
266#***************************************************************************
267# Return file name for data or secondary sockfilter log file.
268#
269sub datasockf_logfilename {
270    my ($logdir, $proto, $ipver, $idnum) = @_;
271    die "unsupported protocol: '$proto'" unless($proto &&
272        (lc($proto) =~ /^ftps?$/));
273    my $trailer = '_sockdata.log';
274    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
275}
276
277
278#***************************************************************************
279# End of library
2801;
281