Import VPN changes by the Special Interest Group.
[ipfire-2.x.git] / config / cfgroot / general-functions.pl
1 # SmoothWall CGIs
2 #
3 # This code is distributed under the terms of the GPL
4 #
5 # (c) The SmoothWall Team
6 # Copyright (C) 2002 Alex Hudson - getcgihash() rewrite
7 # Copyright (C) 2002 Bob Grant <bob@cache.ucr.edu> - validmac()
8 # Copyright (c) 2002/04/13 Steve Bootes - add alias section, helper functions
9 # Copyright (c) 2002/08/23 Mark Wormgoor <mark@wormgoor.com> validfqdn()
10 # Copyright (c) 2003/09/11 Darren Critchley <darrenc@telus.net> srtarray()
11 #
12 # $Id: general-functions.pl,v 1.1.2.26 2006/01/04 16:33:55 franck78 Exp $
13 #
14
15 package General;
16
17 use strict;
18 use Socket;
19 use IO::Socket;
20 use Net::SSLeay;
21 use Net::IPv4Addr;
22
23 $|=1; # line buffering
24
25 $General::version = 'VERSION';
26 $General::swroot = 'CONFIG_ROOT';
27 $General::noipprefix = 'noipg-';
28 $General::adminmanualurl = 'http://wiki.ipfire.org';
29
30 #
31 # log ("message") use default 'ipcop' tag
32 # log ("tag","message") use your tag
33 #
34 sub log
35 {
36         my $tag='ipfire';
37         $tag = shift if (@_>1);
38         my $logmessage = $_[0];
39         $logmessage =~ /([\w\W]*)/;
40         $logmessage = $1;
41         system('logger', '-t', $tag, $logmessage);
42 }
43
44 sub readhash
45 {
46         my $filename = $_[0];
47         my $hash = $_[1];
48         my ($var, $val);
49         
50         
51         # Some ipcop code expects that readhash 'complete' the hash if new entries
52         # are presents. Not clear it !!!
53         #%$hash = ();
54
55         open(FILE, $filename) or die "Unable to read file $filename";
56         
57         while (<FILE>)
58         {
59                 chop;
60                 ($var, $val) = split /=/, $_, 2;
61                 if ($var)
62                 {
63                         $val =~ s/^\'//g;
64                         $val =~ s/\'$//g;
65
66                         # Untaint variables read from hash
67                         # trim space from begin and end
68                         $var =~ s/^\s+//;
69                         $var =~ s/\s+$//;
70                         $var =~ /([A-Za-z0-9_-]*)/;
71                         $var = $1;
72                         $val =~ /([\w\W]*)/;
73                         $val = $1;
74                         $hash->{$var} = $val;
75                 }
76         }
77         close FILE;
78 }
79
80
81 sub writehash
82 {
83         my $filename = $_[0];
84         my $hash = $_[1];
85         my ($var, $val);
86         
87         # write cgi vars to the file.
88         open(FILE, ">${filename}") or die "Unable to write file $filename";
89         flock FILE, 2;
90         foreach $var (keys %$hash) 
91         {
92                 if ( $var eq "__CGI__"){next;}
93                 $val = $hash->{$var};
94                 # Darren Critchley Jan 17, 2003 added the following because when submitting with a graphic, the x and y
95                 # location of the mouse are submitted as well, this was being written to the settings file causing
96                 # some serious grief! This skips the variable.x and variable.y
97                 if (!($var =~ /(.x|.y)$/)) {
98                         if ($val =~ / /) {
99                                 $val = "\'$val\'"; }
100                         if (!($var =~ /^ACTION/)) {
101                                 print FILE "${var}=${val}\n"; }
102                 }
103         }
104         close FILE;
105 }
106
107 sub writehashpart
108 {
109         # This function replaces the given hash in the original hash by keeping the old
110         # content and just replacing the new content
111
112         my $filename = $_[0];
113         my $newhash = $_[1];
114         my %oldhash;
115         my ($var, $val);
116
117         readhash("${filename}", \%oldhash);
118
119         foreach $var (keys %$newhash){
120                 $oldhash{$var}=$newhash->{$var};
121         }
122
123         # write cgi vars to the file.
124         open(FILE, ">${filename}") or die "Unable to write file $filename";
125         flock FILE, 2;
126         foreach $var (keys %oldhash) 
127         {
128                 if ( $var eq "__CGI__"){next;}
129                 $val = $oldhash{$var};
130                 # Darren Critchley Jan 17, 2003 added the following because when submitting with a graphic, the x and y
131                 # location of the mouse are submitted as well, this was being written to the settings file causing
132                 # some serious grief! This skips the variable.x and variable.y
133                 if (!($var =~ /(.x|.y)$/)) {
134                         if ($val =~ / /) {
135                                 $val = "\'$val\'"; }
136                         if (!($var =~ /^ACTION/)) {
137                                 print FILE "${var}=${val}\n"; }
138                 }
139         }
140         close FILE;
141 }
142
143 sub age
144 {
145         my ($dev, $ino, $mode, $nlink, $uid, $gid, $rdev, $size,
146                 $atime, $mtime, $ctime, $blksize, $blocks) = stat $_[0];
147         my $now = time;
148
149         my $totalsecs = $now - $mtime;
150         my $days = int($totalsecs / 86400);
151         my $totalhours = int($totalsecs / 3600);
152         my $hours = $totalhours % 24;
153         my $totalmins = int($totalsecs / 60);
154         my $mins = $totalmins % 60;
155         my $secs = $totalsecs % 60;
156
157         return "${days}d ${hours}h ${mins}m ${secs}s";
158 }
159
160 sub validip
161 {
162         my $ip = $_[0];
163
164         if (!($ip =~ /^(\d+)\.(\d+)\.(\d+)\.(\d+)$/)) {
165                 return 0; }
166         else 
167         {
168                 my @octets = ($1, $2, $3, $4);
169                 foreach $_ (@octets)
170                 {
171                         if (/^0./) {
172                                 return 0; }
173                         if ($_ < 0 || $_ > 255) {
174                                 return 0; }
175                 }
176                 return 1;
177         }
178 }
179
180 sub validmask
181 {
182         my $mask = $_[0];
183
184         # secord part an ip?
185         if (&validip($mask)) {
186                 return 1; }
187         # second part a number?
188         if (/^0/) {
189                 return 0; }
190         if (!($mask =~ /^\d+$/)) {
191                 return 0; }
192         if ($mask >= 0 && $mask <= 32) {
193                 return 1; }
194         return 0;
195 }
196
197 sub validipormask
198 {
199         my $ipormask = $_[0];
200
201         # see if it is a IP only.
202         if (&validip($ipormask)) {
203                 return 1; }
204         # split it into number and mask.
205         if (!($ipormask =~ /^(.*?)\/(.*?)$/)) {
206                 return 0; }
207         my $ip = $1;
208         my $mask = $2;
209         # first part not a ip?
210         if (!(&validip($ip))) {
211                 return 0; }
212         return &validmask($mask);
213 }
214
215 sub validipandmask
216 {
217         my $ipandmask = $_[0];
218
219         # split it into number and mask.
220         if (!($ipandmask =~ /^(.*?)\/(.*?)$/)) {
221                 return 0; }
222         my $ip = $1;
223         my $mask = $2;
224         # first part not a ip?
225         if (!(&validip($ip))) {
226                 return 0; }
227         return &validmask($mask);
228 }
229
230 sub validport
231 {
232         $_ = $_[0];
233
234         if (!/^\d+$/) {
235                 return 0; }
236         if (/^0./) {
237                 return 0; }
238         if ($_ >= 1 && $_ <= 65535) {
239                 return 1; }
240         return 0;
241 }
242
243 sub validproxyport
244 {
245         $_ = $_[0];
246
247         if (!/^\d+$/) {
248                 return 0; }
249         if (/^0./) {
250                 return 0; }
251         if ($_ == 53 || $_ == 222 || $_ == 444 || $_ == 81 ) {
252                 return 0; }
253         elsif ($_ >= 1 && $_ <= 65535) {
254                 return 1; }
255         return 0;
256 }
257
258 sub validmac
259 {
260         my $checkmac = $_[0];
261         my $ot = '[0-9a-f]{2}'; # 2 Hex digits (one octet)
262         if ($checkmac !~ /^$ot:$ot:$ot:$ot:$ot:$ot$/i)
263         {
264                 return 0;
265         }
266         return 1;
267 }
268
269 sub validhostname
270 {
271         # Checks a hostname against RFC1035
272         my $hostname = $_[0];
273
274         # Each part should be at least two characters in length
275         # but no more than 63 characters
276         if (length ($hostname) < 1 || length ($hostname) > 63) {
277                 return 0;}
278         # Only valid characters are a-z, A-Z, 0-9 and -
279         if ($hostname !~ /^[a-zA-Z0-9-]*$/) {
280                 return 0;}
281         # First character can only be a letter or a digit
282         if (substr ($hostname, 0, 1) !~ /^[a-zA-Z0-9]*$/) {
283                 return 0;}
284         # Last character can only be a letter or a digit
285         if (substr ($hostname, -1, 1) !~ /^[a-zA-Z0-9]*$/) {
286                 return 0;}
287         return 1;
288 }
289
290 sub validdomainname
291 {
292         my $part;
293
294         # Checks a domain name against RFC1035
295         my $domainname = $_[0];
296         my @parts = split (/\./, $domainname);  # Split hostname at the '.'
297
298         foreach $part (@parts) {
299                 # Each part should be at least two characters in length
300                 # but no more than 63 characters
301                 if (length ($part) < 2 || length ($part) > 63) {
302                         return 0;}
303                 # Only valid characters are a-z, A-Z, 0-9 and -
304                 if ($part !~ /^[a-zA-Z0-9-]*$/) {
305                         return 0;}
306                 # First character can only be a letter or a digit
307                 if (substr ($part, 0, 1) !~ /^[a-zA-Z0-9]*$/) {
308                         return 0;}
309                 # Last character can only be a letter or a digit
310                 if (substr ($part, -1, 1) !~ /^[a-zA-Z0-9]*$/) {
311                         return 0;}
312         }
313         return 1;
314 }
315
316 sub validfqdn
317 {
318         my $part;
319
320         # Checks a fully qualified domain name against RFC1035
321         my $fqdn = $_[0];
322         my @parts = split (/\./, $fqdn);        # Split hostname at the '.'
323         if (scalar(@parts) < 2) {               # At least two parts should
324                 return 0;}                      # exist in a FQDN
325                                                 # (i.e. hostname.domain)
326         foreach $part (@parts) {
327                 # Each part should be at least one character in length
328                 # but no more than 63 characters
329                 if (length ($part) < 1 || length ($part) > 63) {
330                         return 0;}
331                 # Only valid characters are a-z, A-Z, 0-9 and -
332                 if ($part !~ /^[a-zA-Z0-9-]*$/) {
333                         return 0;}
334                 # First character can only be a letter or a digit
335                 if (substr ($part, 0, 1) !~ /^[a-zA-Z0-9]*$/) {
336                         return 0;}
337                 # Last character can only be a letter or a digit
338                 if (substr ($part, -1, 1) !~ /^[a-zA-Z0-9]*$/) {
339                         return 0;}
340         }
341         return 1;
342 }
343
344 sub validportrange # used to check a port range 
345 {
346         my $port = $_[0]; # port values
347         $port =~ tr/-/:/; # replace all - with colons just in case someone used -
348         my $srcdst = $_[1]; # is it a source or destination port
349
350         if (!($port =~ /^(\d+)\:(\d+)$/)) {
351         
352                 if (!(&validport($port))) {      
353                         if ($srcdst eq 'src'){
354                                 return $Lang::tr{'source port numbers'};
355                         } else  {
356                                 return $Lang::tr{'destination port numbers'};
357                         } 
358                 }
359         }
360         else 
361         {
362                 my @ports = ($1, $2);
363                 if ($1 >= $2){
364                         if ($srcdst eq 'src'){
365                                 return $Lang::tr{'bad source range'};
366                         } else  {
367                                 return $Lang::tr{'bad destination range'};
368                         } 
369                 }
370                 foreach $_ (@ports)
371                 {
372                         if (!(&validport($_))) {
373                                 if ($srcdst eq 'src'){
374                                         return $Lang::tr{'source port numbers'}; 
375                                 } else  {
376                                         return $Lang::tr{'destination port numbers'};
377                                 } 
378                         }
379                 }
380                 return;
381         }
382 }
383
384 # Test if IP is within a subnet
385 # Call: IpInSubnet (Addr, Subnet, Subnet Mask)
386 #       Subnet can be an IP of the subnet: 10.0.0.0 or 10.0.0.1
387 #       Everything in dottted notation
388 # Return: TRUE/FALSE
389 sub IpInSubnet
390 {
391     my $ip = unpack('N', &Socket::inet_aton(shift));
392     my $start = unpack('N', &Socket::inet_aton(shift));
393     my $mask  = unpack('N', &Socket::inet_aton(shift));
394        $start &= $mask;  # base of subnet...
395     my $end   = $start + ~$mask;
396     return (($ip >= $start) && ($ip <= $end));
397 }
398
399 #
400 # Return the following IP (IP+1) in dotted notation.
401 # Call: NextIP ('1.1.1.1');
402 # Return: '1.1.1.2'
403 #
404 sub NextIP
405 {
406     return &Socket::inet_ntoa( pack("N", 1 +  unpack('N', &Socket::inet_aton(shift))
407                                    )
408                              );
409 }
410
411 sub ipcidr
412 {
413         my ($ip,$cidr) = &Net::IPv4Addr::ipv4_parse(shift);
414         return "$ip\/$cidr";
415 }
416
417 sub ipcidr2msk
418 {
419        my ($ip,$cidr) = &Net::IPv4Addr::ipv4_parse(shift);
420        my $netmask = &Net::IPv4Addr::ipv4_cidr2msk($cidr);
421        return "$ip\/$netmask";
422 }
423
424
425 sub validemail {
426     my $mail = shift;
427     return 0 if ( $mail !~ /^[0-9a-zA-Z\.\-\_]+\@[0-9a-zA-Z\.\-]+$/ );
428     return 0 if ( $mail =~ /^[^0-9a-zA-Z]|[^0-9a-zA-Z]$/);
429     return 0 if ( $mail !~ /([0-9a-zA-Z]{1})\@./ );
430     return 0 if ( $mail !~ /.\@([0-9a-zA-Z]{1})/ );
431     return 0 if ( $mail =~ /.\.\-.|.\-\..|.\.\..|.\-\-./g );
432     return 0 if ( $mail =~ /.\.\_.|.\-\_.|.\_\..|.\_\-.|.\_\_./g );
433     return 0 if ( $mail !~ /\.([a-zA-Z]{2,4})$/ );
434     return 1;
435 }
436
437 #
438 # Currently only vpnmain use this three procs (readhasharray, writehasharray, findhasharray)
439 # The 'key' used is numeric but is perfectly unneeded! This will to be removed so don't use
440 # this code. Vpnmain will be splitted in parts: x509/pki, connection ipsec, connection other,... .
441 #
442 sub readhasharray {
443     my ($filename, $hash) = @_;
444     %$hash = ();
445
446     open(FILE, $filename) or die "Unable to read file $filename";
447
448     while (<FILE>) {
449         my ($key, $rest, @temp);
450         chomp;
451         ($key, $rest) = split (/,/, $_, 2);
452         if ($key =~ /^[0-9]+$/) {
453             @temp = split (/,/, $rest);
454             $hash->{$key} = \@temp;
455         }
456     }
457     close FILE;
458     return;
459 }
460
461 sub writehasharray {
462     my ($filename, $hash) = @_;
463     my ($key, @temp, $i);
464
465     open(FILE, ">$filename") or die "Unable to write to file $filename";
466
467     foreach $key (keys %$hash) {
468         if ($key =~ /^[0-9]+$/) {
469             print FILE "$key";
470             foreach $i (0 .. $#{$hash->{$key}}) {
471                 print FILE ",$hash->{$key}[$i]";
472             }
473             print FILE "\n";
474         }
475     }
476     close FILE;
477     return;
478 }
479
480 sub findhasharraykey {
481     foreach my $i (1 .. 1000000) {
482         if ( ! exists $_[0]{$i}) {
483              return $i;
484         }
485     }
486 }
487
488 sub srtarray 
489 # Darren Critchley - darrenc@telus.net - (c) 2003
490 # &srtarray(SortOrder, AlphaNumeric, SortDirection, ArrayToBeSorted)
491 # This subroutine will take the following parameters:
492 #   ColumnNumber = the column which you want to sort on, starts at 1
493 #   AlphaNumberic = a or n (lowercase) defines whether the sort should be alpha or numberic
494 #   SortDirection = asc or dsc (lowercase) Ascending or Descending sort
495 #   ArrayToBeSorted = the array that wants sorting
496 #
497 #   Returns an array that is sorted to your specs
498 #
499 #   If SortOrder is greater than the elements in array, then it defaults to the first element
500
501 {
502         my ($colno, $alpnum, $srtdir, @tobesorted) = @_;
503         my @tmparray;
504         my @srtedarray;
505         my $line;
506         my $newline;
507         my $ctr;
508         my $ttlitems = scalar @tobesorted; # want to know the number of rows in the passed array
509         if ($ttlitems < 1){ # if no items, don't waste our time lets leave
510                 return (@tobesorted);
511         }
512         my @tmp = split(/\,/,$tobesorted[0]);
513         $ttlitems = scalar @tmp; # this should be the number of elements in each row of the passed in array
514
515         # Darren Critchley - validate parameters
516         if ($colno > $ttlitems){$colno = '1';}
517         $colno--; # remove one from colno to deal with arrays starting at 0
518         if($colno < 0){$colno = '0';}
519         if ($alpnum ne '') { $alpnum = lc($alpnum); } else { $alpnum = 'a'; }
520         if ($srtdir ne '') { $srtdir = lc($srtdir); } else { $srtdir = 'src'; }
521
522         foreach $line (@tobesorted)
523         {
524                 chomp($line);
525                 if ($line ne '') {
526                         my @temp = split(/\,/,$line);
527                         # Darren Critchley - juggle the fields so that the one we want to sort on is first
528                         my $tmpholder = $temp[0];
529                         $temp[0] = $temp[$colno];
530                         $temp[$colno] = $tmpholder;
531                         $newline = "";
532                         for ($ctr=0; $ctr < $ttlitems ; $ctr++) {
533                                 $newline=$newline . $temp[$ctr] . ",";
534                         }
535                         chop($newline);
536                         push(@tmparray,$newline);
537                 }
538         }
539         if ($alpnum eq 'n') {
540                 @tmparray = sort {$a <=> $b} @tmparray;
541         } else {
542                 @tmparray = (sort @tmparray);
543         }
544         foreach $line (@tmparray)
545         {
546                 chomp($line);
547                 if ($line ne '') {
548                         my @temp = split(/\,/,$line);
549                         my $tmpholder = $temp[0];
550                         $temp[0] = $temp[$colno];
551                         $temp[$colno] = $tmpholder;
552                         $newline = "";
553                         for ($ctr=0; $ctr < $ttlitems ; $ctr++){
554                                 $newline=$newline . $temp[$ctr] . ",";
555                         }
556                         chop($newline);
557                         push(@srtedarray,$newline);
558                 }
559         }
560
561         if ($srtdir eq 'dsc') {
562                 @tmparray = reverse(@srtedarray);
563                 return (@tmparray);
564         } else {
565                 return (@srtedarray);
566         }
567 }
568
569 sub FetchPublicIp {
570     my %proxysettings;
571     &General::readhash("${General::swroot}/proxy/settings", \%proxysettings);
572     if ($_=$proxysettings{'UPSTREAM_PROXY'}) {
573         my ($peer, $peerport) = (/^(?:[a-zA-Z ]+\:\/\/)?(?:[A-Za-z0-9\_\.\-]*?(?:\:[A-Za-z0-9\_\.\-]*?)?\@)?([a-zA-Z0-9\.\_\-]*?)(?:\:([0-9]{1,5}))?(?:\/.*?)?$/);
574         Net::SSLeay::set_proxy($peer,$peerport,$proxysettings{'UPSTREAM_USER'},$proxysettings{'UPSTREAM_PASSWORD'} );
575     }
576     my ($out, $response) = Net::SSLeay::get_http(  'checkip.dyndns.org',
577                                                     80,
578                                                     "/",
579                                                     Net::SSLeay::make_headers('User-Agent' => 'IPFire' )
580                                                 );
581     if ($response =~ m%HTTP/1\.. 200 OK%) {
582         $out =~ /Current IP Address: (\d+.\d+.\d+.\d+)/;
583         return $1;
584     }
585     return '';
586 }
587
588 #
589 # Check if hostname.domain provided have IP provided
590 # use gethostbyname to verify that
591 # Params:
592 #       IP
593 #       hostname
594 #       domain
595 # Output 
596 #       1 IP matches host.domain
597 #       0 not in sync
598 #
599 sub DyndnsServiceSync ($;$;$) {
600  
601     my ($ip,$hostName,$domain) = @_;
602     my @addresses;
603
604     #fix me no ip GROUP, what is the name ?
605     $hostName =~ s/$General::noipprefix//;
606     if ($hostName) { #may be empty
607         $hostName = "$hostName.$domain";
608         @addresses = gethostbyname($hostName);
609     }
610
611     if ($addresses[0] eq '') {                  # nothing returned ?
612         $hostName = $domain;                    # try resolving with domain only
613         @addresses = gethostbyname($hostName);
614     }
615
616     if ($addresses[0] ne '') {                  # got something ?
617         #&General::log("name:$addresses[0], alias:$addresses[1]");                          
618         # Build clear text list of IP
619         @addresses = map ( &Socket::inet_ntoa($_), @addresses[4..$#addresses]);
620         if (grep (/$ip/, @addresses)) {
621             return 1;
622         }
623     }
624     return 0;
625 }
626 #
627 # This sub returns the red IP used to compare in DyndnsServiceSync
628 #
629 sub GetDyndnsRedIP {
630     my %settings;
631     &General::readhash("${General::swroot}/ddns/settings", \%settings);
632
633     open(IP, "${General::swroot}/red/local-ipaddress") or return 'unavailable';
634     my $ip = <IP>;
635     close(IP);
636     chomp $ip;
637
638     if (&General::IpInSubnet ($ip,'10.0.0.0','255.0.0.0') ||
639         &General::IpInSubnet ($ip,'172.16.0.0.','255.240.0.0') ||
640         &General::IpInSubnet ($ip,'192.168.0.0','255.255.0.0'))
641     {
642         if ($settings{'BEHINDROUTER'} eq 'FETCH_IP') {
643             my $RealIP = &General::FetchPublicIp;
644             $ip = (&General::validip ($RealIP) ?  $RealIP : 'unavailable');
645         }
646     }
647     return $ip;
648 }
649
650 # Translate ICMP code to text
651 # ref: http://www.iana.org/assignments/icmp-parameters
652 sub GetIcmpDescription ($) {
653     my $index = shift;
654     my @icmp_description = (
655     'Echo Reply',                       #0
656     'Unassigned',
657     'Unassigned',
658     'Destination Unreachable',
659     'Source Quench',
660     'Redirect',
661     'Alternate Host Address',
662     'Unassigned',
663     'Echo',
664     'Router Advertisement',
665     'Router Solicitation',              #10
666     'Time Exceeded',
667     'Parameter Problem',
668     'Timestamp',
669     'Timestamp Reply',
670     'Information Request',
671     'Information Reply',
672     'Address Mask Request',
673     'Address Mask Reply',
674     'Reserved (for Security)',
675     'Reserved (for Robustness Experiment)', #20
676     'Reserved',
677     'Reserved',
678     'Reserved',
679     'Reserved',
680     'Reserved',
681     'Reserved',
682     'Reserved',
683     'Reserved',
684     'Reserved',
685     'Traceroute',                               #30
686     'Datagram Conversion Error',
687     'Mobile Host Redirect',
688     'IPv6 Where-Are-You',
689     'IPv6 I-Am-Here',
690     'Mobile Registration Request',
691     'Mobile Registration Reply',
692     'Domain Name Request',
693     'Domain Name Reply',
694     'SKIP',
695     'Photur',                           #40
696     'Experimental');
697     if ($index>41) {return 'unknown'} else {return @icmp_description[$index]};
698 }
699 1;