### 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 POSIX ":sys_wait_h";
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
);

## Configuration

%cfg = ();
open (CONFIG,"/usr/local/smb2www/etc/smb2www.conf") or die "SMB2WWW: No config file found.";
while (<CONFIG>) {
  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

# 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 = urlDecode <STDIN>);
  } else {
    $input = $ENV{'QUERY_STRING'};
  }
  my @security = split ( ';',$input); 
  my @qs = split ( '&', $security[0]);
  my $entry;
  foreach $entry (@qs) {
    if ($entry =~ /([\w]+)=([^\&\?]+)/) {
      my $key = $1;
      my $value = $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=CENTER 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&pass=$pass"
  } else {
    $pwa = "auth=$auth";
  }
  if ( (lc $type) eq "file" ) { 
   $url = "$cfg{cgiroot}/smbfile.pl/$host/$share/$size/$dir?$pwa&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&master=$master&host=$host&share=$share&dir=$dir&$pwa";
  } elsif ( (lc $type) eq "share" ) {
   $url = "$cfg{cgiroot}/smbshr.pl?group=$group&master=$master&host=$host";
  } elsif ( (lc $type) eq "group" ) {
   $url = "$cfg{cgiroot}/smbgrp.pl?group=$group&master=$master";
  } elsif ( (lc $type) eq "all" ) {
   $url = "$cfg{cgiroot}/smb2www.pl";
  } elsif ( (lc $type) eq "msg" ) {
   $url = "$cfg{cgiroot}/smbmsg.pl?group=$group&master=$master&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;
  open MIME, $cfg{mimetype};
  RULE: while ( <MIME> ) {
    my $line = $_;
    if ( not ($line =~ /^$/) and not ($line =~ /^#/) ) {
      if ( $line =~ /^([^\s]+)\s+([\w\ ]+)/ ) {
        $type = $1;
        if ( $2 =~ /$test/ ) {
          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;
  print << "EOF";
Cache-Control: $cfg{cache}
Expires: $exp
Content-type: text/html

<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";
</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 = href("$cfg{cgiroot}/smbhelp.pl", image ($cfg{icon_help},"Help")."<H3>HELP</H3>");
  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"; }
  else { $user = "-Uguest"; }
  if ( $pass ne "") { 
    if ( $user eq "" ) {
      $user = "-Uguest";
    }
  } else { 
    $pass = "-N";
  }
  my @args = ("$cfg{bindir}/smbclient", "//$host/$share", "$pass", "$user",  "-d0", "-c", "get $file $target");
  my $pid=fork();
  if (!$pid) {
    exec (@args); 
    return 1;
  }
  waitpid(-1, &WNOHANG);
  return 0;
}

# 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", "-d0", "-D", "$dir", "-Tc", "$target");
  my $pid=fork();
  if (!$pid) {
    exec (@args);
    return 1;
  }
  waitpid(-1, &WNOHANG);
  return 0;
}

# 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 = `$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 -N -L \"$share\" -d0";
  my @out = `$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 =~ /^$/) and ($#out >= -1) ) {
      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;
      } 
      $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 -N -L \"$host\" -W \"$workgroup\" -d0";
  my @out = `$lookup`;
  my $line = shift @out;

  while ((not $line =~ /^\tServer\s+Comment$/) and ($#out >= -1) ) {
    $line = shift @out;
  }
  shift @out;
  $line = shift @out;
  if ($#out >= -1) {
    while ((not $line =~ /^$/) and ($#out >= -1)) {
      if ( $line =~ /^\t([\S ]*\S) {5,}(\S[\S ]*|\S|)$/ ) {
        my $rec = {};
        $rec->{name} = $1;
        $rec->{comment} = $2;
        push @ret, $rec;
      }
      $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 -N -L \"$cfg{masterbrowser}\" -d0";
  my @out = `$lookup`;
  my $line = shift @out;

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

sub SendHostMessage {
  my ($host,$msg) = @_;
  open ( MSGOUT, "| $cfg{bindir}/smbclient -M \"$host\" -d0 -U \"smb2www\" > /dev/null" );
  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))
}