smb2www 980804-41 / usr / share / perl5 / smb2www.pm

### Copyright notice

# SMB2WWW - a smb to WWW gateway; access windows computers through a browser
# Copyright (C) 1997,1998 Remco van Mook

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 2 of the License, or
# (at your option) any later version.

# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.

# You should have received a copy of the GNU General Public License
# along with this program; if not, write to the Free Software
# Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.

# The author can be contacted by e-mail: remco@samba.anu.edu.au

### Configuration and common procedures for smb2www

## This is a perl module. Some headers

package smb2www;
use Exporter ();

use IO::File;
use MIME::Base64;
use Time::Local; # for lmtime
use strict;
use vars qw( %cfg %text @ISA @EXPORT );
@ISA = qw(Exporter);
@EXPORT = qw( %cfg $cfg %text $text urlDecode urlEncode image table href
              shref header trailer decode_query mimetype lmtime
              GetSMBTar GetSMBFile GetSMBDir GetSMBShr 
              GetSMBHosts GetSMBGroups
              httptime MakeAuth GetAuth 
              SendHostMessage GetCmdOutput
              CheckEnabled
);

## Configuration

%cfg=();
my $cfg_file;
foreach $cfg_file (("/usr/share/smb2www/smb2www.default","/etc/smb2www/smb2www.conf")) {
  open (CONFIG, $cfg_file) or die "SMB2WWW: No config file found.";
  while (<CONFIG>) {
    next if (/^#/);
    if (/([\w\_]+)\s*=\s*(.+)/ ) {
       $cfg{$1} = $2;
    }
  }
  close CONFIG;
}

## Multi-language support

%text = ();
open (LANGUAGE,"$cfg{cfgdir}/$cfg{language}.lang") or die "SMB2WWW: No language support found for $cfg{language}.";
while (<LANGUAGE>) {
  if ( $_ =~/([\w\_]+)\s*=\s*(.+)/ ) {
     $text{$1} = $2;
  }
}
close LANGUAGE;   

## Common procedures

# Get output of command without using shell
# usage: @output = GetCmdOutput(@args)
sub GetCmdOutput {
        my @args = @_;
	# fork and exec command
        open (OUT, '-|')
                || exec { $args[0] } @args;
        my @out=<OUT>;
        close OUT;
        return @out;
}

# Nasty URL encoding/decoding stuff
sub urlDecode{
  my $value= $_[0];
  $value =~ tr/+/ /;
  $value =~ s/%([a-fA-F0-9][a-fA-F0-9])/pack("C", hex($1))/eg;
  return $value;
};

sub urlEncode {
  my $value=$_[0];
  $value =~ s/([^a-zA-Z0-9\.\_\'\-\$\~\\\/])/'%'.unpack("H*",$1)/eg;
  $value =~ tr/ /+/;
  return $value;
};

# Getting info from the webserver
# Some security might be nice.. let's kill it at the first ; for now
# Only brave souls hack smb2www without going insane at all the refs..

sub decode_query {
  my %query = ();
  my $input;
  if ($ENV{'REQUEST_METHOD'} eq "POST") {
    chomp ($input = <STDIN>);
  } else {
    $input = $ENV{'QUERY_STRING'};
  }
  my @qs = split ( '&', $input);
  my $entry;
  foreach $entry (@qs) {
    if ($entry =~ /([\w]+)=([^\&\?]+)/) {
      my $key = urlDecode($1);
      my $value = urlDecode($2);
      $query{$key}=$value;
    }
  }
  return %query;   
};

# Return a HTML href tag
sub href {
  return "<A HREF=\"$_[0]\">$_[1]</A>";
};

# Return a HTML image tag

sub image {
  return "<IMG SRC=\"$cfg{imgroot}/$_[0]\" BORDER=\"0\" ALIGN=\"MIDDLE\" ALT=\"$_[1]\">";
};

# Return a HTML table entry 
sub table {
  my @table = @_;
  print "<TR>\n";
  foreach ( @table ) {
    print "<TD>$_</TD>\n";
  }
  print "</TR>\n";
}

# Return a SMB2WWW url tag

sub shref {
  my ($type, $group, $master, $host, $share, $dir, 
      $user, $pass, $size, $date, $auth) = @_;
  my @urlencoded = ($group,$master, $host,$share,$dir,$user,$pass);
  for (@urlencoded) { $_ = urlEncode $_ }    
  ($group,$master, $host,$share,$dir,$user,$pass) = @urlencoded;
  my $url; 
  my $pwa;
  if ( $auth eq "" ) {
    $pwa = "user=$user&amp;pass=$pass"
  } else {
    $pwa = "auth=$auth";
  }
  if ( (lc $type) eq "file" ) { 
   $url = "$cfg{cgiroot}/smbfile.pl/$host/$share/$size/$dir?$pwa&amp;lm=".lmtime($date);
  } elsif ( (lc $type) eq "tar" ) {
   $url = "$cfg{cgiroot}/smbtar.pl/$host/$share$dir?$pwa";
  } elsif ( (lc $type) eq "dir" ) {
      $url = "$cfg{cgiroot}/smbdir.pl?group=$group&amp;master=$master&amp;host=$host&amp;share=$share&amp;dir=$dir&amp;$pwa";
  } elsif ( (lc $type) eq "share" ) {
   $url = "$cfg{cgiroot}/smbshr.pl?group=$group&amp;master=$master&amp;host=$host";
  } elsif ( (lc $type) eq "group" ) {
   $url = "$cfg{cgiroot}/smbgrp.pl?group=$group&amp;master=$master";
  } elsif ( (lc $type) eq "all" ) {
   $url = "$cfg{cgiroot}/smb2www.pl";
  } elsif ( (lc $type) eq "msg" ) {
   $url = "$cfg{cgiroot}/smbmsg.pl?group=$group&amp;master=$master&amp;host=$host";
  } else {
   $url = $_[0]; # Act stupid when acted stupid upon
  } 
  return $url;
}

# Determine mimetype, given a file extension

sub mimetype {
  my $test = lc $_[0];
  my $type = "";
 if (open MIME, $cfg{mimetype}) {
  RULE: while ( <MIME> ) {
    my $line = $_;
    if ( not ($line =~ /^$/) and not ($line =~ /^#/) ) {
      if ( $line =~ /^([^\s]+)\s+([\w\ ]+)/ ) {
        $type = $1;
        if ( $2 =~ /\b$test\b/o ) {
          last RULE;
        } else {
          $type = "";
        }
      }
    }
  }
  close MIME;
 }
  $type = "application/octet-stream" if ($type eq "");
  return $type; 
}

# Calculate expiretime for header()

sub expiretime {
  return httptime(time+$cfg{refresh});
}

# Calculate Last-Modified: timestamp out of a SMB timestamp

sub lmtime {
  my $timestring = $_[0];
  my %month = (
   Jan => 0, Feb => 1, Mar => 2, 
   Apr => 3, May => 4, Jun => 5,
   Jul => 6, Aug => 7, Sep => 8, 
   Oct => 9, Nov =>10, Dec =>11
  );
  my $time;
  if ( $timestring =~ /^\w+ (\w+)[ ]+(\w+) (\w+):(\w+):(\w+) (\w+)/ ){
    $time = timelocal ($5,$4,$3,$2,$month{$1},$6);
  }
  return $time; # Now put this into httptime
}

# Make a HTTP/1.1 certified timestamp out of a UNIX timestamp.

sub httptime {
  my $time = $_[0];
  my @days = qw (Sun Mon Tue Wed Thu Fri Sat);
  my @months = qw (Jan Feb Mar Apr May Jun Jul Aug Sep Oct Nov Dec);
  my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$istdst) = gmtime($time);
  my $realyear;
  if ($year < 70) {
    $realyear = "20$year";
  } else {
    $realyear = "19$year";
  }
  return sprintf ("%s, %02d %s %s %02d:%02d:%02d GMT", 
         $days[$wday],$mday,$months[$mon],$realyear,$hour,$min,$sec);
}

# Starting a page

sub header {
  my $exp = expiretime;
  my $charset = (defined $text{'lang_charset'}) ? $text{'lang_charset'} : 'ISO-8859-1';
  print << "EOF";
Cache-Control: $cfg{cache}
Expires: $exp
Content-type: text/html; charset=$charset

EOF

  if (defined $cfg{html_header_file} and -f $cfg{html_header_file}) {
    my ($head_file, $head_data, %head_conf);
    $head_file = IO::File->new($cfg{html_header_file}, 'r') or
      die "Could not open $cfg{html_head_file}: $!";
    $head_data = join("\n", $head_file->getlines);
    $head_file->close;

    %head_conf = (TITLE => $_[0],
		  REFRESH => (not $_[1] =~ /norefresh/) ?
		  "<META HTTP-EQUIV=\"refresh\" content=\"$cfg{refresh}\">\n" :
		  '',
		  CHARSET => $charset,
		  IMGROOT => $cfg{imgroot},
		  BACKGROUND => $cfg{background},
		  LINK => $cfg{link},
		  VLINK => $cfg{vlink});

    for my $key (keys %head_conf) {
	$head_data =~ s/%$key%/$head_conf{$key}/g;
    }

    print $head_data;
  } else {
    print << "EOF";
<HTML>

<HEAD>
<TITLE>$_[0]</TITLE>
<!--
This page has been produced by SMB2WWW.
SMB2WWW is (C) Remco van Mook 1997,1998.
You can contact the author at: remco\@samba.anu.edu.au.
More information about SMB2WWW is at http://samba.anu.edu.au/samba/smb2www
//-->
EOF
    if (not $_[1] =~ /norefresh/ ) {
	print "<META HTTP-EQUIV=\"refresh\" content=\"$cfg{refresh}\">\n";
    }
    print << "EOF";
<META HTTP-EQUIV="Content-Type" CONTENT="text/html; charset=$charset">
</HEAD>
<BODY background="$cfg{imgroot}/$cfg{background}" LINK="$cfg{"link"}" VLINK="$cfg{vlink}">
<CENTER><H1>$_[0]</H1></CENTER>
<HR WIDTH=\"75%\">
<TABLE>
EOF
  }
}

# Finishing the page

sub trailer {
  my ($help, $lang_sup) = @_; # the arguments are used only by smbhelp
  $help = href("$cfg{cgiroot}/smbhelp.pl", image ($cfg{icon_help},"$text{help}")."<BR><FONT SIZE=\"+1\"><B>$text{help2}</B></FONT><BR>") unless defined $help;
  $lang_sup = "" unless defined $lang_sup;


  if (defined $cfg{html_trailer_file} and -f $cfg{html_trailer_file}) {
    my ($trailer_file, $trailer_data);
    $trailer_file = IO::File->new($cfg{html_trailer_file}, 'r') or
      die "Could not open $cfg{html_trailer_file}: $!";
    $trailer_data = join("\n", $trailer_file->getlines);
    $trailer_file->close;

    $trailer_data =~ s/%HELP%/$help/g;
    $trailer_data =~ s/%LANG_SUPPORT%/$lang_sup/g;

    print $trailer_data;
  } else {
    print << "EOF";
</TABLE>
<HR WIDTH="75%">
<CENTER>
$help
Comments/remarks/kudos to:<i>remco\@samba.anu.edu.au</i>
</CENTER>
</BODY>
</HTML>
EOF
  }
};

## Interfacing perl with smbclient

#sort an array of hashes by $_->{name} (for GetSMBDir et al)

sub byname {
  (lc $a->{name}) cmp (lc $b->{name})
}

# Gets the file //$host/$share/$file, using $user and $pass, to $target.
# And return the error code. If $target is unspecified, 
# STDOUT is used (-).
# Syntax: $error = GetSMBFile ($host,$share,$file,$user,$pass,$target)

sub GetSMBFile {
  my ($host, $share, $file, $user, $pass, $target) = @_;
  if ( $target eq "") { $target = "-" };
  $file =~ s/^(.*)\/([^\/]*)$/$1$2/ ;
  if ( $user ne "" ) { $user="-U$user"; }
  if ( $pass ne "") { 
    if ( $user eq "" ) {
      $user = "-Uguest";
    }
  } else { 
    $pass = "-N";
  }
  my @args = ("$cfg{bindir}/smbclient", "//$host/$share", "$pass", "$user", "-E", "-d0", "-c", "get \"$file\" $target");
  exec { $args[0] } (@args);
### NOT REACHED ###
}

# Makes a TAR of //$host/$share/$dir, using $user and $pass, to $target.
# And return the error code. If $target is unspecified, 
# STDOUT is used (-).
# Syntax: $error = GetSMBTar ($host,$share,$dir,$user,$pass,$target)

sub GetSMBTar {
  my ($host, $share, $dir, $user, $pass, $target) = @_;
  if ( $target eq "") { $target = "-" };
  if ( $user ne "" ) { $user="-U$user"; }
  if ( $pass ne "") { 
    if ( $user eq "" ) {
      $user = "-Uguest";
    }
  } else { 
    $pass = "-N";
  }
  my @args = ("$cfg{bindir}/smbclient", "//$host/$share", "$pass", "$user", "-E", "-d0", "-D", "$dir", "-Tcq", "$target");
  exec { $args[0] } (@args);
### NOT REACHED ###
}

# Return an array with sorted dir and filelisting
# Syntax: @output = GetSMBDir (host,share,dir,user,pass)
# array contains hashes; keys: name, attr, size, date

sub GetSMBDir {
  my ($host, $share, $dir, $user, $pass ) = @_; 
  my @dir = (); my @files = ();
  if (! $user eq "") { $user = "-U".$user }
  if ( $pass eq "") { $pass = "-N" } 

  my @lookup = ("$cfg{bindir}/smbclient", "//$_[0]/$_[1]", "$pass", "$user", "-d0", "-c", "ls", "-D", "$_[2]");

  my @out = GetCmdOutput(@lookup);
  my $line;
  foreach $line ( @out ) {
    if ($line =~ /^  ([\S ]*\S|[\.]+) {5,}([HDRSA]+) +([0-9]+)  (\S[\S ]+\S)$/g) {
      my $rec = {};
      $rec->{name} = $1;
      $rec->{attr} = $2;
      $rec->{size} = $3;
      $rec->{date} = $4;
      if ($rec->{attr} =~ /D/) {
        push @dir, $rec;
      } else {
        push @files, $rec;
      }
    } elsif ($line =~ /^  ([\S ]*\S|[\.]+) {6,}([0-9]+)  (\S[\S ]+\S)$/) {
      my $rec = {};
      $rec->{name} = $1;
      $rec->{attr} = "";
      $rec->{size} = $2;
      $rec->{date} = $3;
      push @files, $rec; # No attributes at all, so it must be a file
    }
  } 
  my @ret = sort byname @dir;
  @files = sort byname @files;
  foreach $line ( @files ) {
    push @ret, $line;
  }
  return @ret; 
}

# Return an array with sorted share listing 
# Syntax: @output = GetSMBShr (host)
# array contains hashes; keys: name, type, comment

sub GetSMBShr {
  my $share = $_[0];
  my @ret = ();
  my @lookup = ("$cfg{bindir}/smbclient", "-L", "$share", "-d0", "-N");
  my @out = GetCmdOutput(@lookup);
  my $line = shift @out;
  while ( (not $line =~ /^\s+Sharename/) and ($#out > -1) ) {
    $line = shift @out;
  }
  if ($#out > 0) {
    $line = shift @out;
    $line = shift @out; 
    while ( (not $line =~ /^$/) ) {
      if ( $line =~ /^\s+(\S[\S ]{0,14})\s+(Disk|Printer|IPC)\s+([\S ]*)/ ) {
        my $rec = {};
        my $nearname = $1;
        $rec->{type} = $2;
        $rec->{comment} = $3;
        if ( $nearname =~ /^([\S ]*\S)\s*$/  ) {
          $rec->{name} = $1;
        } else {
          $rec->{name} = $nearname;
        }
        push @ret, $rec;
      } 
      last if $#out < 0;
      $line = shift @out;
    }
  }
  return sort byname @ret;
}

# Return an array with sorted host listing 
# Syntax: @output = GetSMBHosts (host,group)
# array contains hashes; keys: name, comment 

sub GetSMBHosts {
  my ($workgroup,$host) = @_;
  my @ret = ();
  my @lookup = ("$cfg{bindir}/smbclient", "-L", "$host", "-W", "$workgroup", "-d0", "-N");
  my @out = GetCmdOutput(@lookup);
  my $line = shift @out;

  while ((not $line =~ /^\s+Server\s+Comment$/) and ($#out > -1) ) {
    $line = shift @out;
  }
  if ($#out > 0) {
    $line = shift @out;
    $line = shift @out;
    while ((not $line =~ /^$/)) {
      if ( $line =~ /^\s+([\S ]*\S) {5,}\s?(\S[\S ]*|\S|)$/ ) {
        my $rec = {};
        $rec->{name} = $1;
        $rec->{comment} = $2;
        push @ret, $rec;
      }
      last if $#out < 0;
      $line = shift @out;
    }
  }
  return sort byname @ret; 
}

# Return an array with sorted groups listing 
# Syntax: @output = GetSMBGroups ()
# array contains hashes; keys: name, master

sub GetSMBGroups {
  my @ret = ();
  my @lookup = ("$cfg{bindir}/smbclient", "-L", "$cfg{masterbrowser}", "-d0", "-N");
  my @out = GetCmdOutput(@lookup);
  my $line = shift @out;

  while ((not $line =~ /^\s+Workgroup\s+Master$/) and ($#out > -1) ) {
    $line = shift @out;
  }
  if ($#out > 0) {
    $line = shift @out;
    $line = shift @out;
    while ((not $line =~ /^$/ )) {
      if ( $line =~ /^\s+([\S ]*\S) {2,}\s?(\S[\S ]*)$/ ) {
        my $rec = {};
        $rec->{name} = $1;
        $rec->{master} = $2;
        push @ret, $rec;
      }
      last if $#out < 0;
      $line = shift @out;
    }
  }
  return sort byname @ret;
}

sub SendHostMessage {
  my ($host,$msg) = @_;
  my @args = ("$cfg{bindir}/smbclient", "-M", "$host", "-d0", "-U", "smb2www");
  # fork...
  if (not open (MSGOUT, '|-')) {
	# ...child process, reopen STDOUT to /dev/null and exec smbclient
	close (STDOUT);
	open STDOUT, ">/dev/null";
	exec { $args[0] } @args;
  }
  # ... parent process
  print MSGOUT $msg;
  close MSGOUT;
  return "OK";
}

## User/Pass encryption stuff

sub MakeAuth {
  my $unenc = "$_[0]:$_[1]";
  my $length = length $unenc;
  my $key = $cfg{key} ;
  while ( (length $key) < $length ) {
    $key = $key . $cfg{key};
  }
  my $crypt = substr ($key,0,$length);
  my $b64enc = encode_base64($unenc ^ $crypt);
  $b64enc =~ tr#+#,#; $b64enc =~ tr#/#.#;
  return $b64enc;
}

sub GetAuth {
  my $auth = $_[0];
  $auth =~ tr#,#+#; $auth =~ tr#.#/#;
  my $uudec = decode_base64($auth);
  my $length = length $uudec;
  my $key = $cfg{key} ;
  while ( (length $key) < $length ) {
    $key = $key . $cfg{key};
  }
  my $crypt = substr ($key,0,$length);
  return split (":",($uudec ^ $crypt))
}

# Debian:
sub CheckEnabled() {

  return 1 if ((exists $cfg{'enabled'}) and ($cfg{'enabled'} eq 'yes'));
  print << "EOF";
Content-type: text/html; charset=ISO-8859-1

<HTML>
<HEAD>
  <TITLE>SMB2WWW is disabled!</TITLE>
</HEAD>
<BODY>
  <H1>SMB2WWW is disabled!</H1>
  <P ALIGN=\"center\">
   SMB2WWW is currently disabled.<BR>
   To enable it, please run the <I>dpkg-reconfigure smb2www</I> command.
  </P>
</BODY>
EOF
  return 0;
}