1#***************************************************************************
2#                                  _   _ ____  _
3#  Project                     ___| | | |  _ \| |
4#                             / __| | | | |_) | |
5#                            | (__| |_| |  _ <| |___
6#                             \___|\___/|_| \_\_____|
7#
8# Copyright (C) 1998 - 2020, 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#***************************************************************************
22
23package serverhelp;
24
25use strict;
26use warnings;
27use Exporter;
28
29
30#***************************************************************************
31# Global symbols allowed without explicit package name
32#
33use vars qw(
34    @ISA
35    @EXPORT_OK
36    );
37
38
39#***************************************************************************
40# Inherit Exporter's capabilities
41#
42@ISA = qw(Exporter);
43
44
45#***************************************************************************
46# Global symbols this module will export upon request
47#
48@EXPORT_OK = qw(
49    serverfactors
50    servername_id
51    servername_str
52    servername_canon
53    server_pidfilename
54    server_portfilename
55    server_logfilename
56    server_cmdfilename
57    server_inputfilename
58    server_outputfilename
59    mainsockf_pidfilename
60    mainsockf_logfilename
61    datasockf_pidfilename
62    datasockf_logfilename
63    );
64
65
66#***************************************************************************
67# Just for convenience, test harness uses 'https' and 'httptls' literals as
68# values for 'proto' variable in order to differentiate different servers.
69# 'https' literal is used for stunnel based https test servers, and 'httptls'
70# is used for non-stunnel https test servers.
71
72
73#***************************************************************************
74# Return server characterization factors given a server id string.
75#
76sub serverfactors {
77    my $server = $_[0];
78    my $proto;
79    my $ipvnum;
80    my $idnum;
81
82    if($server =~
83        /^((ftp|http|imap|pop3|smtp|http-pipe)s?)(\d*)(-ipv6|)$/) {
84        $proto  = $1;
85        $idnum  = ($3 && ($3 > 1)) ? $3 : 1;
86        $ipvnum = ($4 && ($4 =~ /6$/)) ? 6 : 4;
87    }
88    elsif($server =~
89        /^(tftp|sftp|socks|ssh|rtsp|gopher|httptls)(\d*)(-ipv6|)$/) {
90        $proto  = $1;
91        $idnum  = ($2 && ($2 > 1)) ? $2 : 1;
92        $ipvnum = ($3 && ($3 =~ /6$/)) ? 6 : 4;
93    }
94    else {
95        die "invalid server id: '$server'"
96    }
97    return($proto, $ipvnum, $idnum);
98}
99
100
101#***************************************************************************
102# Return server name string formatted for presentation purposes
103#
104sub servername_str {
105    my ($proto, $ipver, $idnum) = @_;
106
107    $proto = uc($proto) if($proto);
108    die "unsupported protocol: '$proto'" unless($proto &&
109        ($proto =~ /^(((FTP|HTTP|HTTP\/2|IMAP|POP3|GOPHER|SMTP|HTTP-PIPE)S?)|(TFTP|SFTP|SOCKS|SSH|RTSP|HTTPTLS|DICT|SMB|SMBS|TELNET|MQTT))$/));
110
111    $ipver = (not $ipver) ? 'ipv4' : lc($ipver);
112    die "unsupported IP version: '$ipver'" unless($ipver &&
113        ($ipver =~ /^(4|6|ipv4|ipv6|-ipv4|-ipv6|unix)$/));
114    $ipver = ($ipver =~ /6$/) ? '-IPv6' : (($ipver =~ /unix$/) ? '-unix' : '');
115
116    $idnum = 1 if(not $idnum);
117    die "unsupported ID number: '$idnum'" unless($idnum &&
118        ($idnum =~ /^(\d+)$/));
119    $idnum = '' unless($idnum > 1);
120
121    return "${proto}${idnum}${ipver}";
122}
123
124
125#***************************************************************************
126# Return server name string formatted for identification purposes
127#
128sub servername_id {
129    my ($proto, $ipver, $idnum) = @_;
130    return lc(servername_str($proto, $ipver, $idnum));
131}
132
133
134#***************************************************************************
135# Return server name string formatted for file name purposes
136#
137sub servername_canon {
138    my ($proto, $ipver, $idnum) = @_;
139    my $string = lc(servername_str($proto, $ipver, $idnum));
140    $string =~ tr/-/_/;
141    $string =~ s/\//_v/;
142    return $string;
143}
144
145
146#***************************************************************************
147# Return file name for server pid file.
148#
149sub server_pidfilename {
150    my ($proto, $ipver, $idnum) = @_;
151    my $trailer = '_server.pid';
152    return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
153}
154
155#***************************************************************************
156# Return file name for server port file.
157#
158sub server_portfilename {
159    my ($proto, $ipver, $idnum) = @_;
160    my $trailer = '_server.port';
161    return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
162}
163
164
165#***************************************************************************
166# Return file name for server log file.
167#
168sub server_logfilename {
169    my ($logdir, $proto, $ipver, $idnum) = @_;
170    my $trailer = '_server.log';
171    $trailer = '_stunnel.log' if(lc($proto) =~ /^(ftp|http|imap|pop3|smtp)s$/);
172    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
173}
174
175
176#***************************************************************************
177# Return file name for server commands file.
178#
179sub server_cmdfilename {
180    my ($logdir, $proto, $ipver, $idnum) = @_;
181    my $trailer = '_server.cmd';
182    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
183}
184
185
186#***************************************************************************
187# Return file name for server input file.
188#
189sub server_inputfilename {
190    my ($logdir, $proto, $ipver, $idnum) = @_;
191    my $trailer = '_server.input';
192    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
193}
194
195
196#***************************************************************************
197# Return file name for server output file.
198#
199sub server_outputfilename {
200    my ($logdir, $proto, $ipver, $idnum) = @_;
201    my $trailer = '_server.output';
202    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
203}
204
205
206#***************************************************************************
207# Return file name for main or primary sockfilter pid file.
208#
209sub mainsockf_pidfilename {
210    my ($proto, $ipver, $idnum) = @_;
211    die "unsupported protocol: '$proto'" unless($proto &&
212        (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
213    my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.pid':'_sockfilt.pid';
214    return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
215}
216
217
218#***************************************************************************
219# Return file name for main or primary sockfilter log file.
220#
221sub mainsockf_logfilename {
222    my ($logdir, $proto, $ipver, $idnum) = @_;
223    die "unsupported protocol: '$proto'" unless($proto &&
224        (lc($proto) =~ /^(ftp|imap|pop3|smtp)s?$/));
225    my $trailer = (lc($proto) =~ /^ftps?$/) ? '_sockctrl.log':'_sockfilt.log';
226    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
227}
228
229
230#***************************************************************************
231# Return file name for data or secondary sockfilter pid file.
232#
233sub datasockf_pidfilename {
234    my ($proto, $ipver, $idnum) = @_;
235    die "unsupported protocol: '$proto'" unless($proto &&
236        (lc($proto) =~ /^ftps?$/));
237    my $trailer = '_sockdata.pid';
238    return '.'. servername_canon($proto, $ipver, $idnum) ."$trailer";
239}
240
241
242#***************************************************************************
243# Return file name for data or secondary sockfilter log file.
244#
245sub datasockf_logfilename {
246    my ($logdir, $proto, $ipver, $idnum) = @_;
247    die "unsupported protocol: '$proto'" unless($proto &&
248        (lc($proto) =~ /^ftps?$/));
249    my $trailer = '_sockdata.log';
250    return "${logdir}/". servername_canon($proto, $ipver, $idnum) ."$trailer";
251}
252
253
254#***************************************************************************
255# End of library
2561;
257