#!/usr/bin/perl

# SSHARK reference implementation (server side component)
# Version 0.1.1, released 28 December 2012
# ----- See http://sshark.org/ -----
# Written by Anatole Shaw; ash AT greenhost DOT nl
# Copyright (C)2012 Greenhost VOF; https://greenhost.nl/
#
# 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 3 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, see <http://www.gnu.org/licenses/>.

use strict;
use Switch;
use File::Temp qw(tempfile);
use Sys::Syslog;
use Getopt::Long;
use MIME::Base64;
use Digest::SHA qw(sha256_hex);
use IO::Select;
use POSIX qw(strftime);
use Net::DNS;
use Net::DNS::RR;
use Net::DNS::RR::TXT;
use Authen::PAM qw(:constants);

#my $debug = 1;
my $debug;
my $dnstimeout = 5;

umask(077);
$ENV{PATH} = '/bin:/sbin:/usr/bin:/usr/sbin';
setproctitle();
openlog('sshark','pid','auth');

sub setproctitle {
  # horrible hack around syslog bug in Authen::PAM
  switch ($_[0]) {
    case 'pam' { $0 = "sshark\0\0\0sshark[$$]"; }
    else { $0 = "sshark [$ENV{USER}]"; }
  }
}

sub fatal {
  print STDERR "$0: fatal: @_\n";
  syslog('alert',"fatal: @_");
  closelog();
  exit(2);
}

sub deny {
  my $keytype = $_[0];
  my $keyhash = $_[1];
  my $zone = $_[2];
  my $msg = $_[3];

  print STDERR "================================[sshark]================================\n";
  print STDERR "Sorry, your SSH key ${msg}.\n";
  print STDERR "Key: $keytype $keyhash\n";
  print STDERR "Zone: $zone\n";
  print STDERR "========================================================================\n";
  syslog('warning',"denied user '$ENV{USER}' with $keytype key $keyhash from $ENV{SSH_CLIENT}");
  closelog();
  exit(3);
}

sub note {
  print STDERR "[sshark] @_\n";
}

sub warning {
  print STDERR "[sshark] warning: @_\n";
  syslog('warning',"warning: @_");
}

sub debug {
  if (defined($debug)) {
    print STDERR "<sshark> @_\n";
    syslog('debug',"debug: @_");
  }
}

sub tmpf {
  my $tmp = File::Temp->new(
	TEMPLATE => 'sshark-XXXXXXXXXXX',
  	SUFFIX   => '.tmp',
  	UNLINK   => 1
        );
  return $tmp;
}

## Take an SSH key type and fingerprint,
## and return the matching key and comment from ~/.ssh/authorized_keys
sub getpubkey {
  my $spectype = $_[0];
  my $spechash = $_[1];

  my $pubkey;
  my $comment;

  my $AUTHKEYS;
  my $authkeys = "$ENV{HOME}/.ssh/authorized_keys";
  open(AUTHKEYS, "<$authkeys") or fatal("could not open $authkeys");

  my $found = 0;
  while (<AUTHKEYS>) {
    my $keyline = $_;
    $keyline =~ s/.* ssh-/ssh-/g;
    my $keytype = (split(/\s/,$keyline))[0];
    next unless ( $keytype eq $spectype );
    my $tmp = tmpf();
    my $TMP;
    open(TMP, ">".$tmp->filename);
    print(TMP $keyline);
    my $data=`ssh-keygen -l -f $tmp`;
    my $keyhash = (split(/\s/,$data))[1];
    if ( lc($keyhash) eq lc($spechash) ) {
      $found = 1;
      ($pubkey,$comment) = (split(/\s/,$keyline))[1..2];
      last;
    }
    close(TMP);
  }
  close(AUTHKEYS);
  if ( $found == 1 ) {
    return(($pubkey,$comment));
  }
  else {
    return((undef,undef));
  }
}

## Test whether a string is a valid lookup zone,
## which is nearly the same thing as a valid email address.
sub zonevalid {
  if ( lc($_[0]) =~ /^[a-z0-9][a-z0-9-]*@[a-z0-9_][a-z0-9-]*(\.[a-z0-9_][a-z0-9-]*)*\.?$/ ) {
    return(1);
  }
  else {
    return(undef);
  }
}

## Turn an SSH key comment field into a lookup zone.
sub comment2zone {
  my $comment = $_[0];

  if ( $comment =~ /^([^@]+)@([^@]+)$/ ) {
    (my $cuser, my $cdom) = ($1,$2);
    $cuser =~ tr[A-Za-z0-9-][-]c;
    my $czone = lc("${cuser}\@${cdom}");
    return (undef) unless ( zonevalid($czone) );
    $czone =~ s/@/._sshark./;
    return($czone);
  }
  else {
    return(undef);
  }
}

## Return the deeper zone (querybase) containing claims for a given key.
sub getquerybase {
  my $keytype = $_[0];
  my $keyhash = $_[1];
  my $zone = $_[2];

  my $keyhashx = $keyhash;
  $keyhashx =~ s/://g;
  my $querybase = "${keytype}-${keyhashx}.${zone}";
  return $querybase;
}

## Extract the fields present in a SSHARK claim.
sub extractclaim {
  my $text = $_[0];
  my $type = $_[1];

  if ( $text =~ /^sshark1 serial ([0-9]+) expiry ([0-9]+)$/ ) {
    (my $serial, my $expiry) = ($1,$2);
    my $claim = {serial=>$1,expiry=>$2,source=>$type};
    debug("found claim $1, expiry $2, source $type");
    return $claim;
  }
}

## Get all the claims in a zone (querybase).
## Sort order: revocations first, then by descending serial number.
sub getclaims {
  my $querybase = $_[0];
  my $rrfile = $_[1];
  my @claims;

  if ( -r $rrfile ) {
    my $RRFILE;
    open(RRFILE,"<$rrfile");
    while (<RRFILE>) {
      if ( /^([^\s]+)\s+"([^"]+)"\s*$/ ) {
        (my $rrname, my $rrdata) = ($1,$2);
        if ( $rrname eq $querybase ) {
          my $claim = extractclaim($rrdata,'file');
          push(@claims, $claim);
        }
      }
    }
    close(RRFILE);
  }
  my $dns = Net::DNS::Resolver->new;
  $dns->tcp_timeout($dnstimeout);
  my $dnssock = $dns->bgsend($querybase,'TXT');
  my $dnssel = IO::Select->new($dnssock);
  my @sel = $dnssel->can_read($dnstimeout);
  if (@sel) {
    foreach my $sock (@sel) {
      if ( $sock == $dnssock ) {
        my $dnsq = $dns->bgread($sock);
        foreach my $txt ($dnsq->answer) {
          my $claim = extractclaim($txt->txtdata,'dns');
          push(@claims, $claim);
        }
      }
    }
  }
  else {
    debug("DNS timeout");
  }
  @claims = sort {
    if ( $a->{expiry} == 0 ) {
      debug("prioritizing claim " . $a->{serial} . " because it is a revocation");
      return (-1);
    }
    else {
      return ( $b->{serial} <=> $a->{serial} );
    }
  } @claims;
  return(\@claims);
}

## Return the signature data associated with a given claim.
sub getclaimval {
  my $querybase = $_[0];
  my $rrfile = $_[1];
  my $claim = $_[2];

  debug("looking in " . $claim->{source} . " for data on claim " . $claim->{serial});
  my $rrsearch = 's'.$claim->{serial}.'.'.$querybase;

  my $valdata;
  switch ( $claim->{source} ) {
    case 'file' {
      my $RRFILE;
      open(RRFILE,"<$rrfile");
      while (<RRFILE>) {
        if ( /^([^\s]+)\s+"([^"]+)"\s*$/ ) {
          (my $rrname, my $rrdata) = ($1,$2);
          debug("found: $rrname");
          if ( $rrname eq $rrsearch && $rrdata =~ /^sshark1 data ([0-9A-Za-z\/+=]+)$/ ) {
            #debug("found data in file $rrfile") if ( !defined($valdata) );
            $valdata .= $1;
          }
        }
      }
      close(RRFILE);
    }
    case 'dns' {
      my $dns = Net::DNS::Resolver->new;
      $dns->tcp_timeout($dnstimeout);
      $dns->usevc(1); #TCP
      my $dnsq = $dns->query($rrsearch, "TXT");
      warning("could not query DNS for revocation data") if (!defined($dnsq));
      foreach my $txt ($dnsq->answer) {
        if ( $txt->txtdata =~ /^sshark1 data ([0-9A-Za-z\/+=]+)$/ ) {
          #debug("found data in DNS") if ( !defined($valdata) );
          $valdata .= $1;
        }
      }
    }
  }
  if (defined($valdata)) { $valdata = decode_base64($valdata); }
  return $valdata;
}

## Validate the signature that was found on a claim.
sub chkclaimval {
  my $valdata = $_[0];
  my $keytype = $_[1];
  my $pubkey = $_[2];

  my $pempub = key2pem("$keytype $pubkey");
  fatal("unable to convert public key to pkcs8") if (!defined($pempub));

  my $pempubf = tmpf();
  my $pempubfn = $pempubf->filename;
  my $PEMPUBF;
  open(PEMPUBF, ">$pempubfn");
  print(PEMPUBF $pempub);

  my $valdataf = tmpf();
  my $valdatafn = $valdataf->filename;
  my $REVODATAF;
  open(REVODATAF, ">$valdatafn");
  print(REVODATAF $valdata);

  my $result = `openssl rsautl -verify -pubin -keyform PEM -inkey $pempubfn -in $valdatafn 2>/dev/null`;

  close(PEMPUBF);
  close(REVODATAF);

  chomp $result;
  return $result;
}

## Turn an SSH public key into PEM format.
## This depends on ssh-keygen(1) but we should do it ourselves.
sub key2pem {
  my $retval;
  my $tmp = tmpf();
  my $TMP;
  open(TMP, ">".$tmp->filename);
  print(TMP @_);
  my $tmpfn = $tmp->filename;
  my $pkcs8 = `ssh-keygen -e -m pkcs8 -f $tmpfn`;
  if ( $pkcs8 =~ /^-----BEGIN PUBLIC KEY-----/ ) {
    $retval = $pkcs8;
  }
  else {
    $retval = undef;
  }
  close(TMP);
  return($retval);
}

## Simulate a full login as best we can.
sub loginfull {
  my $pam = new Authen::PAM('sshark',$ENV{USER});
  fatal("pam_start") if ( !defined($pam) );
  my $pamerr;
  setproctitle('pam'); $pamerr = $pam->pam_open_session(); setproctitle();
  fatal("pam_open_session $pamerr") if ( $pamerr != 0 );
  system($ENV{SHELL});
  setproctitle('pam'); $pamerr = $pam->pam_close_session(); setproctitle();
  fatal("pam_close_session $pamerr") if ( $pamerr != 0 );
}

## This is it.
my $keytype;
my $keyhash;
my $zone;
my $rrfile;
GetOptions(
	'key-type|t=s' => \$keytype,
	'key-hash|l=s' => \$keyhash,
	'domain|d=s' => \$zone,
	'rrfile|f=s' => \$rrfile,
	);
sub usage {
  print STDERR "USAGE: sshark [ -f <queryFile> ] [ -d <queryDomain> ] -t <keyType> -l <keyHash>\n";
  exit(1);
}

if ( !defined($keytype) || !defined($keyhash) ) { usage() }
unless ( $keytype eq 'ssh-rsa' ) { fatal("only ssh-rsa keys are supported right now") }
if ( defined($zone) && !zonevalid($zone) ) { fatal("invalid zone '$zone'") }
if ( !defined($rrfile) ) { $rrfile = "/var/lib/sshark/sshark.dat" }
if ( !-r $rrfile ) { warning("file $rrfile is unreadable") }

(my $pubkey, my $comment) = getpubkey($keytype, $keyhash);
if ( !defined($pubkey) ) { fatal("specification matches no authorized key") }

if ( !defined($zone) ) {
  if ( defined($comment) ) {
    my $czone = comment2zone($comment);
    if ( defined($czone) ) {
      $zone = $czone;
    }
    else {
      fatal("key has malformed comment '$comment'");
    }
  }
  else {
    fatal("key has no comment, and no zone specified on command line");
  }
}

my $querybase = getquerybase($keytype, $keyhash, $zone);
debug("querybase $querybase");

my $valid = 0;
my $claims = getclaims($querybase,$rrfile);
if ( @$claims ) {
  CLAIM: foreach my $claim (@$claims) {
    debug("evaluating claim " . $claim->{serial});
    my $valdata = getclaimval($querybase,$rrfile,$claim);
    if ( defined($valdata) ) {
      my $claimstr = sha256_hex('sshark1 serial '.$claim->{serial}.' expiry '.$claim->{expiry});
      my $signedmsg = chkclaimval($valdata, $keytype, $pubkey);
      if ( $signedmsg eq $claimstr ) {
        debug("claim " . $claim->{serial} . " is authentic");
        if ( $claim->{expiry} == 0 ) {
          deny($keytype,$keyhash,$zone,"has been revoked");
        }
        elsif ( $claim->{expiry} <= time() ) {
          my $expired = strftime("%a %b %e %H:%M:%S %Y %Z (%z)", localtime($claim->{expiry}));
          deny($keytype,$keyhash,$zone,"expired on $expired");
        }
        else {
          note("Your key is valid until " .
            strftime("%a %b %e %H:%M:%S %Y %Z (%z)", localtime($claim->{expiry})));
          $valid = 1;
          last CLAIM;
        }
      }
      else {
        debug("claim " . $claim->{serial} . " failed authenticity check, skipping");
      }
    }
    else {
      warning("claim " . $claim->{serial} . " has no associated data, skipping");
    }
  }
}
else {
  deny($keytype,$keyhash,$zone,"has no sshark records");
}

if ( $valid == 1 ) {
  closelog();
  my $origcmd = $ENV{SSH_ORIGINAL_COMMAND};
  if ( defined($origcmd) ) {
    if ( $origcmd eq 'internal-sftp' ) {
      debug("requested internal-sftp");
      exec "/usr/lib/sftp-server";
    }
    else {
      debug("executing: $origcmd");
      exec "$origcmd";
    }
  }
  else {
    debug("performing full login");
    loginfull();
  }
}
else {
  deny($keytype,$keyhash,$zone,"has no authentic sshark records");
}