netdisco/bin/netdisco-deploy

#!/usr/bin/env perl

use strict;
use warnings;

our $home;

BEGIN {
  use FindBin;
  FindBin::again();

  $home = ($ENV{NETDISCO_HOME} || $ENV{HOME});

  # try to find a localenv if one isn't already in place.
  if (!exists $ENV{PERL_LOCAL_LIB_ROOT}) {
      use File::Spec;
      my $localenv = File::Spec->catfile($FindBin::RealBin, 'localenv');
      exec($localenv, $0, @ARGV) if -f $localenv;
      $localenv = File::Spec->catfile($home, 'perl5', 'bin', 'localenv');
      exec($localenv, $0, @ARGV) if -f $localenv;

      die "Sorry, can't find libs required for App::Netdisco.\n"
        if !exists $ENV{PERLBREW_PERL};
  }
}

BEGIN {
  use Path::Class;

  # stuff useful locations into @INC and $PATH
  unshift @INC,
    dir($FindBin::RealBin)->parent->subdir('lib')->stringify,
    dir($FindBin::RealBin, 'lib')->stringify;

  use Config;
  $ENV{PATH} = $FindBin::RealBin . $Config{path_sep} . $ENV{PATH};
}

use App::Netdisco;
use Dancer ':script';
use Dancer::Plugin::DBIC 'schema';
use Dancer::Plugin::Passphrase;
use App::Netdisco::Util::Statistics ();

info "App::Netdisco $App::Netdisco::VERSION loaded.";

use 5.010_000;
use Term::UI;
use Term::ReadLine;
use Term::ANSIColor;

use Archive::Extract;
$Archive::Extract::PREFER_BIN = 1;
use File::Slurper 'read_lines';
use HTTP::Tiny;
use Digest::MD5;
use Try::Tiny;
use File::Path ();
use File::Copy ();
use Encode;

=head1 NAME

netdisco-deploy - Database, OUI and MIB deployment for Netdisco

=head1 USAGE

This script deploys the Netdisco database schema, OUI data, and MIBs. Each of
these is an optional service which the user is asked to confirm.

Pre-existing requirements are that there be a database table created and a
user with rights to create tables in that database. Both the table and user
name must match those configured in your environment YAML file (default
C<~/environments/deployment.yml>).

This script will download the latest MAC address vendor prefix data from the
Internet, and update the OUI table in the database. Hence Internet access is
required to run the script.

Similarly the latest Netdisco MIB bundle is also downloaded, placed into the
user's home directory (or C<$ENV{NETDISCO_HOME}>), and Netdisco reconfigured
for its use.

=cut

print color 'bold cyan';
say 'This is the Netdisco II deployment script.';
say '';
say 'Before we continue, the following prerequisites must be in place:';
say ' * Database added to PostgreSQL for Netdisco';
say ' * User added to PostgreSQL with rights to the Netdisco Database';
say ' * "~/environments/deployment.yml" file configured with Database dsn/user/pass';
say ' * A full backup of any existing Netdisco database data';
say ' * Internet access (for OUIs and MIBs)';
say '';
say 'You will be asked to confirm all changes to your system.';
say '';
print color 'reset';

my $term = Term::ReadLine->new('netdisco');
my $bool = $term->ask_yn(
  prompt => 'So, is all the above in place?', default => 'n',
);

exit(0) unless $bool;

say '';
$bool = $term->ask_yn(
  prompt => 'Would you like to deploy the database schema?', default => 'n',
);
deploy_db() if $bool;

say '';
$bool = $term->ask_yn(
  prompt => 'Download and update vendor MAC prefixes (OUI data)?', default => 'n',
);
deploy_oui() if $bool;

say '';
my $default_mibhome = dir($home, 'netdisco-mibs');
if (setting('mibhome') and setting('mibhome') ne $default_mibhome) {
    my $mibhome = $term->get_reply(
      print_me => "MIB home options:",
      prompt   => "Download and update MIB files to...?",
      choices  => [setting('mibhome'), $default_mibhome, 'Skip this.'],
      default  => 'Skip this.',
    );
    deploy_mibs($mibhome) if $mibhome and $mibhome ne 'Skip this.';
}
else {
    $bool = $term->ask_yn(
      prompt => "Download and update MIB files?", default => 'n',
    );
    deploy_mibs($default_mibhome) if $bool;
}

sub deploy_db {
  system 'netdisco-db-deploy';
  print color 'bold blue';
  say 'DB schema update complete.';
  print color 'reset';

  print color 'bold blue';
  print 'Updating statistics... ';
  App::Netdisco::Util::Statistics::update_stats();
  say 'done.';
  print color 'reset';

  if (not setting('safe_password_store')) {
      say '';
      print color 'bold red';
      say '*** WARNING: Weak password hashes are being stored in the database! ***';
      say '*** WARNING: Please add "safe_password_store: true" to your ~/environments/deployment.yml file. ***';
      print color 'reset';
  }

  sub _make_password {
    my $pass = (shift || passphrase->generate_random);
    if (setting('safe_password_store')) {
        return passphrase($pass)->generate;
    }
    else {
        return Digest::MD5::md5_hex($pass),
    }
  }

  # set up initial admin user
  my $users = schema('netdisco')->resultset('User');
  if ($users->search({-bool => 'admin'})->count == 0) {
      say '';
      print color 'bold green';
      say 'We need to create a user for inital login. This user will be a full Administrator.';
      say 'Afterwards, you can go to Admin -> User Management to manage users.';
      print color 'reset';
      say '';

      my ($name, $pass) = get_userpass($term);
      $users->create({
        username => $name,
        password => _make_password($pass),
        admin => 'true',
        port_control => 'true',
      });

      print color 'bold blue';
      say 'New user created.';
      print color 'reset';
  }

  # set initial dancer web session cookie key
  schema('netdisco')->resultset('Session')->find_or_create(
    {id => 'dancer_session_cookie_key', a_session => \'md5(random()::text)'},
    {key => 'primary'},
  );
}

sub get_userpass {
  my $term = shift;
  my $name = $term->get_reply(prompt => 'Username: ');
  my $pass = $term->get_reply(prompt => 'Password: ');

  unless ($name and $pass) {
    say 'username and password cannot be empty, please try again.';
    ($name, $pass) = get_userpass($term);
  }

  return ($name, $pass);
}

sub deploy_oui {
  my $schema = schema('netdisco');
  $schema->storage->disconnect;
  my @lines = ();
  my %data = ();

  if (@ARGV) {
      @lines = File::Slurper::read_lines($ARGV[0]);
  }
  else {
      my $url = 'https://raw.githubusercontent.com/netdisco/upstream-sources/master/ieee/oui.txt';
      my $resp = HTTP::Tiny->new->get($url);
      @lines = split /\n/, $resp->{content};
  }

  if (scalar @lines > 50) {
      foreach my $line (@lines) {
          if ($line =~ m/^\s*(.{2}-.{2}-.{2})\s+\(hex\)\s+(.*)\s*$/i) {
              my ($oui, $company) = ($1, $2);
              $oui =~ s/-/:/g;
              my $abbrev = shorten($company);
              $data{lc($oui)}{'company'} = $company;
              $data{lc($oui)}{'abbrev'}  = $abbrev;
          }
      }

      if ((scalar keys %data) > 15_000) {
          $schema->txn_do(sub{
            $schema->resultset('Oui')->delete;
            $schema->resultset('Oui')->populate([
                          map {
                              {   oui     => $_,
                                  company => $data{$_}{'company'},
                                  abbrev  => $data{$_}{'abbrev'}
                              }
                              } keys %data
            ]);
          });
      }

      print color 'bold blue';
      say 'OUI update complete.';
  }
  else {
      print color 'bold red';
      say 'OUI update failed!';
  }

  print color 'reset';
}

# This subroutine is from Wireshark's make-manuf
# http://anonsvn.wireshark.org/wireshark/trunk/tools/make-manuf
sub shorten {
    my $manuf = shift;

    $manuf = decode("utf8", $manuf, Encode::FB_CROAK) unless @ARGV;
    $manuf = " " . $manuf . " ";

    # Remove any punctuation
    $manuf =~ tr/',.()/    /;

    # & isn't needed when Standalone
    $manuf =~ s/ \& / /g;

    # Remove any "the", "inc", "plc" ...
    $manuf
        =~ s/\s(the|inc|incorporated|plc||systems|corp|corporation|s\/a|a\/s|ab|ag|kg|gmbh|co|company|limited|ltd|holding|spa)(?= )//gi;

    # Convert to consistent case
    $manuf =~ s/(\w+)/\u\L$1/g;

    # Remove all spaces
    $manuf =~ s/\s+//g;

    # Deviating from make-manuf for HP
    $manuf =~ s/Hewlett[-]?Packard/Hp/;

    # Truncate all names to a reasonable length, say, 8 characters.
    # If the string contains UTF-8, this may be substantially more than 8 bytes.
    $manuf = substr( $manuf, 0, 8 );

    return encode( "utf8", $manuf );
}

sub deploy_mibs {
  my $mibhome = dir(shift); # /path/to/netdisco-mibs
  my $fail = 0;

  my $latest = 'https://github.com/netdisco/netdisco-mibs/releases/latest';
  my $resp = HTTP::Tiny->new->get($latest);

  if ($resp->{url} =~ m/([0-9.]+)$/) {
    my $ver = $1;
    my $url = "https://github.com/netdisco/netdisco-mibs/releases/download/${ver}/netdisco-mibs.tar.gz";
    my $file = file($home, 'netdisco-mibs.tar.gz');
    $resp = HTTP::Tiny->new->mirror($url, $file);

    if ($resp->{success}) {
      my $ae = Archive::Extract->new(archive => $file, type => 'tgz');
      $ae->extract(to => $mibhome->parent->stringify);

      my $from = file($mibhome->parent->stringify, "netdisco-mibs-$ver");
      my $to = file($mibhome->parent->stringify, 'netdisco-mibs');

      if (-d $from) {
        File::Path::remove_tree($to, { verbose => 0 });
        File::Copy::move($from, $to);
      }
      unlink $file;
    }
    else { ++$fail }
  }
  else { ++$fail }

  if ($fail) {
    print color 'bold red';
    say 'MIB download failed!';
  }
  else {
    print color 'bold blue';
    say 'MIBs update complete.';
  }

  print color 'reset';
}

exit 0;