#!/usr/local/bin/perl
## $Id: ckpasswd,v 1.23 1994/10/20 23:54:52 mikew Exp $
## ========================================================================
## ckpasswd -- Password checker
## Author          : Mike Williams <mikew@gopher.dosli.govt.nz>
## ========================================================================

# Copyright (C) 1994 Mike Williams
# 
# 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.

# ckpasswd is a utility that will check the "safety" of a candidate
# password.  If is found to be "bad", ckpasswd explains why.
#
# Basically, ckpasswd screens candidate passwords against one or more
# bad-password dictionaries.  It checks not only the word itself, but also
# various transformations of the word (ala cracklib).  A number of
# different dictionary formats are recognised, including sorted & unsorted
# ASCII files, dbm databases, ispell dictionaries and Bloom-filter hash
# tables.

#--- Includes -------------------------------------------------------------

require 'syscall.ph';
require 'getopts.pl';
require 'shellwords.pl';
require 'open2.pl';
require 'look.pl';

#--- Configuration --------------------------------------------------------

$MINLENGTH = 6;
$ISPELL = '/usr/local/bin/ispell';

$LIBDIR = '/usr/local/lib/ckpasswd';
$default_config = "$LIBDIR/ckpasswd.conf";

@transformers =
    ('strip',
     'downcase',
     'deNumberPlate',
#     'unprefix',
#     'unsuffix',
#     'unsuffix_e',
     'unrepeat',
     'unreflect',
     'reverse',
     'capitalise',
     );

#--- Parse options --------------------------------------------------------

$usage = "usage: ckpasswd\n";

&Getopts('C:v');
die ($usage) if (@ARGV);

($opt_C = $default_config) if (!$opt_C && -e $default_config);
if ($opt_C) {
    &readConfig($opt_C);
} else {
    @dictionaries = ('/usr/dict/words');
    $dictionaryType{'/usr/dict/words'} = 'sorted-f';
    $dictionaryDesc{'/usr/dict/words'} = 
	'it matches a word from /usr/dict/words';
}

#--- Initialisation -------------------------------------------------------

chdir ($LIBDIR) || warn "can't cd to '$LIBDIR': $!\n";

# Get user information
$user = getlogin unless $user;
if ($user) {
    ($user,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell)
	= getpwnam($user);
} else {
    ($user,$passwd,$uid,$gid,$quota,$comment,$gcos,$home,$shell)
	= getpwuid($<);
}
die "can't get user info" unless $user;

# @names are all the words from the gcos field
$names = $gcos;
$names =~ s/,.*//;		# strip punctuation
$names =~ s/^\s+//;		# remove leading blanks
@names = split(' ', $names);

# $names_re matches any word in @names which has at least 3 characters
$names_re = (@names 
	     ? '(' . join('|', grep (length($_) > 2, @names)) . ')'
	     : '^$');

# $initials_re matches concatenation of first letters of @names
$initials_re = ((@names >= 3)
	     ? '(' . join('', grep ($_ = substr($_,0,1), @names)) . ')'
	     : '^$');

# Initialise dictionary packages
for $pkg ('lsearch', 'bsearch', 'bloom', 'dbm', 'ispell') {
    eval "&${pkg}'init";
}

#--- Inhibit core dumps ---------------------------------------------------

# Leaving a core dump around could be a security problem (as it will
# probably contain the user's password).  So, we catch the signals which
# normally produce core dumps, and exit gracefully.

for $sig ('QUIT', 'ILL', 'TRAP', 'IOT', 'EMT',
	  'FPE', 'BUS', 'SEGV', 'SYS') {
    $SIG{$sig} = 'sigexit';
}

sub sigexit {
    warn "\ncaught fatal signal - no core dump\n";
    exit 99;
}

#--- Read & check password ------------------------------------------------

chop ($_ = <STDIN>);
if ($reason = &badpw($_)) {
    print "$reason\n";
    exit 1;
}
exit 0;

#--- Debugging ------------------------------------------------------------

sub trace 
{
    print STDERR (@_) if ($opt_v);
}

#--- Read config file -----------------------------------------------------

sub readConfig
{
    local ($config) = @_;

    &trace ("reading config file '$config'\n");

    open (CONFIG, "< $config") || do {
	warn "ckpasswd: error opening $config: $!\n";
	return ();
    };

    while (<CONFIG>) {
	chop;
	while (/\\$/) {		# handle continuation lines
	    chop;
	    ($_ .= <CONFIG>) || last;
	    chop;
	}
	s/#.*//;		# ignore comments
	next if /^\s*$/;	# skip blank lines
	if (/^\s*define\s/) {
	    local ($header, $var, $val) = &shellwords($_);
	    eval "\$$var = '$val'";
	} elsif (/^\s*dict\s/) {
	    local ($header, $dict, $type, $desc) = &shellwords($_);
	    if (!$type) {
		warn "ckpasswd: $config:$.: no type specified\n";
		next;
	    }
	    @dictionaries = grep ($_ ne $dict, @dictionaries);
	    push (@dictionaries, $dict);
	    $dictionaryType{$dict} = $type;
	    $dictionaryDesc{$dict} = $desc;
	} elsif (/^\s*reject\s/) {
	    local ($header, $pattern, $desc) = &shellwords($_);
	    $badpats{$pattern} = $desc;
	}
    }
    
    close (CONFIG);
}

#--- Password checking ----------------------------------------------------

sub badpw
# Check PASSWORD for safety.  It it is determined to be bad, return a
# string explaining why.
{
    local ($_) = @_;
    local ($reason);

    # Check against hard-coded bad patterns
    study;
    return "it was blank!" if (/^\s*$/);
    return "please use at least $MINLENGTH characters"
	if (length($_) < $MINLENGTH);
    return "it looks like a date"
	if (m:^\d{1,2}[/-]\d{1,2}[/-]\d{2,4}$: ||
	    (($mo) = /^\d+ *([a-zA-Z]{3,}) *\d+$/) &&
	    ($mo =~ /^(jan|feb|mar|apr|may|jun)/i ||
	     $mo =~ /^(jul|aug|sep|oct|nov|dec)/i) );
    return "it looks like a phone number"
	if (/\d\d\d[ -]?\d[ -]?\d\d\d$/);
    return "it looks like a license plate"
	if (/^[a-z]{2} ?\d{2,5}$/i);

    # Check against user information in /etc/passwd
    return "it contains your username" if (/$user/i);
    return "it contains part of your name" if (/$names_re/i);
    return "it contains your initials" if (/$initials_re/i);

    # Check against patterns from config file
    while (($pattern, $reason) = each %badpats) {
	return $reason if (/$pattern/);
    }

    # Try looking it up
    return $reason if ($reason = &lookup($_));

    # Try munging it various ways, and doing a lookup
    if (@descs = &transformLookup($_, @transformers)) {
	local ($reason) = pop(@descs);
	local ($last_desc) = pop(@descs);
	local ($desc) = 
	    join (",\n  and ",
		  (@descs ? join(",\n      ", @descs) : ()), 
		  $last_desc);
	return "after $desc,\n$reason";
    }

    # Well, it must be okay
    ();
}

#--- Dictionary lookup ----------------------------------------------------

sub lookup
# Lookup PASSWORD in all dictionaries, returning explanation if found.  
# Use list of TRANSFORMATIONS applied to PASSWORD to veto lookup, if
# required.
{    
    local ($_, @transformations) = @_;

    return $lookup{$_} if (defined ($lookup{$_}));
    
    &trace ("  lookup '$_'\n");

    # Misc other checks
    return ($lookup{$_} = "it's an alphabetic sequence")
	if (&alphabeticP ($_));
    return ($lookup{$_} = "it looks like a QWERTY keyboard sequence")
	if (&qwertySequenceP ($_));
    return ($lookup{$_} = "it's the name of a host")
	if (@info = gethostbyname($_));

    # Check against dictionaries
    local ($type, $desc);
    for $dict (@dictionaries) {
	$type = $dictionaryType{$dict};
	$desc = $dictionaryDesc{$dict};
	if ($type eq 'random' || $type eq 'unsorted') {
	    return ($lookup{$_} = $desc) if (&lsearch'find($dict,$_));
	} elsif ($type eq 'sorted') {
	    return ($lookup{$_} = $desc) if (&bsearch'find($dict,$_));
	} elsif ($type eq 'sorted-f') {
	    return ($lookup{$_} = $desc) if (&bsearch'find($dict,$_,1));
	} elsif ($type eq 'bloom') {
	    return ($lookup{$_} = $desc) if (&bloom'find($dict,$_));
	} elsif ($type eq 'dbm') {
	    return ($lookup{$_} = $desc) if (&dbmdict'find($dict,$_));
	} elsif ($type eq 'ispell') {
	    return ($lookup{$_} = $desc) if (&ispell'find($dict,$_));
	} else {
	    warn "ckpasswd: invalid dictionary type $type ('$dict')\n";
	}
    }

    # Well it must be okay
    $lookup{$_} = 0;
}

sub alphabeticP
# Return true if ARG is an alphabetic sequence
{
    local ($_) = @_;
    local (@chars) = unpack ('C*', $_);
    local ($diff);
    for $i (0 .. $#chars-1) {
	$diff = $chars[$i+1] - $chars[$i];
	return () if ($diff > 1 || $diff < -1);
    }
    return 1;
}

sub qwertySequenceP
# Return true if ARG is a QWERTY keyboard sequence
{
    local ($_) = @_;
    tr/A-Z/a-z/;
    tr/qwertyuiop[]{}asdfghjkl;\':\"zxcvbnm,.\/<>?/a-lkla-kjka-jhij/;
    tr/1234567890\-=/a-l/;
    tr/!@#\$%^&*()_+/a-l/;
    &alphabeticP ($_);
}

#--- Transformation driver ------------------------------------------------

sub transformLookup
{
    local ($_, @transformers) = @_;
    local ($trans, $munged, $desc, $found, @descs);

    ($trans = shift @transformers) || return ();
    if ((($munged, $desc) = &$trans ($_)) && ($munged ne $_)) {
	&trace ("  $trans: '$_' -> '$munged'\n");
	return ($desc, $found) if ($found = &lookup($munged, $trans));
	return ($desc, @descs) 
	    if (@descs = &transformLookup($munged,@transformers));
    }
    &transformLookup($_,@transformers);
}

#--- Transformations ------------------------------------------------------

sub strip {			# strip leading/trailing 
    local ($_) = @_;		#   whitespace/digit/punctuation

    return ($_, 'stripping leading whitespace') if (s/^\s+//);
    return ($_, 'stripping trailing whitespace') if (s/\s+$//);

    return ($_, 'stripping leading digit') if (s/^\d//);
    return ($_, 'stripping trailing digit') if (s/\d$//);

    local ($punc) = '!"#$%&\'()\*+,-./:;<=>?[\\]^_`{|}~';
    return ($_, 'stripping leading punctuation') if (s/^[$punc]//);
    return ($_, 'stripping trailing punctuation') if (s/[$punc]$//);

    ();
}

sub downcase {			# convert to lowercase
    local ($_) = @_;
    tr/A-Z/a-z/ || return (); 
    ($_, 'converting to lowercase');
}

sub deNumberPlate {		# convert digits to characters
    local ($_) = @_;
    study;
    s/1/i/g; 
    s/2/to/g; 
    s/3/e/g;
    s/4/for/g;
    s/8/ate/g;
    s/0/o/g;
    ($_, 'de-numberplatifying');
}

sub reverse {			# invert word
    local ($_) = @_;
    $_ = reverse $_;
    ($_, 'reversing');
}

sub unprefix {			# remove common prefixes
    local ($_) = @_;
    study;
    (s/^over-?// ||
     s/^under-?// ||
     s/^un-?// ||
     s/^de-?// ||
     s/^re-?// ||
     return ());
    ($_, 'removing a common prefix');
}

sub unsuffix {			# remove common suffixes
    local ($_) = @_;
    study;
    (s/ies$/y/ ||
     s/s$// ||
     s/ed$// ||
     s/er$// ||
     s/ly$// ||
     s/ing$// ||
     s/able$// ||
     return ());
    ($_, 'removing a common suffix');
}

sub unsuffix_e {		# replace common suffixes with 'e'
    local ($_) = @_;
    study;
    (s/es$/e/ ||
     s/ed$/e/ ||
     s/er$/e/ ||
     s/ing$/e/ ||
     s/able$/e/ ||
     s/tion$/te/ ||
     return ());
    ($_, 'removing a common suffix');
}

sub unrepeat {			# undo repetition, eg. "blahblah"
    local ($_) = @_;
    study;
    s/^(..+)\1\1\1/\1/ || s/^(..+)\1\1/\1/ || s/^(..+)\1/\1/
	|| return ();
    ($_, 'removing repeated character sequence');
}

sub halve {
    local ($_) = @_;
    local ($len) = length($_);
    local ($half) = int($len/2);
    (substr ($_, 0, $len-$half), substr ($_, $half));
}

sub unreflect {			# collapse palindromes, eg. "baddab"
    local ($_) = @_;
    local ($head, $tail) = &halve($_);
    return ($head, 'removing reflected character sequence')
	if ($head eq reverse($tail));
    ();
}

sub capitalise {		# capitalise
    local ($_) = @_;
    (substr ($_,0,1) =~ tr/a-z/A-Z/) || return (); 
    ($_, 'capitalising');
}

#==========================================================================
#=== Bloom filter =========================================================

package bloom;

#--- Check word -----------------------------------------------------------

sub find
# Return true if word is present in bloom filter
{
    local ($filter, $word) = @_;
    local ($variant);
    &open ($filter, $filter) unless (defined ($VARIANTS{$filter}));
    for $variant (1 .. $VARIANTS{$filter}) {
	&getBit( $filter, &hash($SIZE{$filter},$word,$variant) ) || return ();
    }
    return 1;
}

#--- Open bloom filter ----------------------------------------------------

sub init {
    $HSIZE = 8;			# Size of filter-file header
    $MAGIC = 'BF1';		# Magic-string
}

sub open
{
    local ($fh, $filter) = @_;

    # Read header
    open ($fh, "< $filter") || do {
	warn "ckpasswd: error opening $filter: $!\n";
	return ();
    };
    seek ($fh, 0, 0);
    local ($buffer);
    sysread ($fh, $buffer, $HSIZE) || do {
	warn "ckpasswd: error reading $filter: $!\n";
	return ();
    };
    (substr($buffer,0,3) eq $MAGIC) || do {
	warn "ckpasswd: bad magic number in $filter\n";
	return ();
    };
    ($VARIANTS{$fh}) = unpack ('C', substr($buffer,3,1));
    ($SIZE{$fh})     = unpack ('N', substr($buffer,4,4));

    $fh;
}

#--- Hash function --------------------------------------------------------

sub rotl
# Rotate BYTE left N bits
{
    local ($byte, $n) = @_;
    $byte = int($byte << ($n % 8));
    ((($byte) & 0xff00) >> 8) | (($byte) & 0xff);
}

sub maxShift
# Determine maximum amount of shift for a given hash SIZE
{
    local ($size) = @_;
    return $MAXSHIFT{$size} if defined ($MAXSHIFT{$size});
    local ($maxShift);
    for ($maxShift = 1; (1 << $maxShift) < $size; $maxShift++) {};
    $MAXSHIFT{$fh} = $maxShift;
}

sub hash
# Hash STR in hash table of given SIZE, using specified hash function VARIANT
{
    local ($size, $str, $variant) = @_;
    defined($variant) || ($variant = 1);
    local ($hashval, $shift);
    local ($shift_inc) = 8 - int($variant / 8);
    local ($maxShift) = &maxShift($size);

    for $char (unpack('C*', $str)) {
	$char = &rotl ($char, $variant);  # Rotate the character $variant bits
	$hashval += ($char << $shift);	  # Shift it over, and add to hashval
	$shift += $shift_inc;		  # Determine the shift for next time
	$shift %= $maxShift;
    }
    ($hashval % $size);
}

#--- Access functions -----------------------------------------------------

sub lseek
{
    local ($fh, $byte) = @_;
    syscall (&main'SYS_lseek, fileno($fh), $byte, 0);
}

sub getBit
{
    local ($fh, $bit) = @_;
    local ($offset, $relbit) = (int($bit/8)+$HSIZE, ($bit%8));

    local ($byte);
    &lseek ($fh, $offset); sysread ($fh, $byte, 1);
    vec($byte,$relbit,1);
}

#==========================================================================
#=== Linear search ========================================================

package lsearch;

sub find 
# Search unsorted DICTIONARY and return true if WORD is present.  
{
    local ($dictionary, $word) = @_;

    open (DICT, "<$dictionary") || do {
	warn "ckpasswd: error opening $dictionary: $!\n";
	return ();
    };
    local ($_);
    while (<DICT>) {
	chop;
 	if ($_ eq $word) {
	    close(DICT);
	    return 1;
	}
    }
    close(DICT);
    ();
}

#==========================================================================
#=== Binary search ========================================================

package bsearch;

sub find 
# Search sorted DICTIONARY and return true if WORD is present.  
# Assume case was ignored for sorting if CASEFOLD is true.
{
    local ($dictionary, $word, $fold) = @_;

    # Open dictionary
    unless ($opened{$dictionary}) {
	open ($dictionary, "<$dictionary") || do {
	    warn "ckpasswd: error opening $dictionary: $!\n";
	    return ();
	};
	$opened{$dictionary}++;
    }

    # Search for word
    local ($_);
    &main'look ($dictionary, $word, 0, $fold);
    chop ($_ = <$dictionary>);

    $_ eq $word;
}

#==========================================================================
#=== DBM search ===========================================================

package dbmdict;

sub find 
# Search dbm-file DICTIONARY and return true if WORD is present
{
    local ($dictionary, $word) = @_;
    local (%dict);

    (-e "$dictionary.dir") || do {
	warn "ckpasswd: dbm file $dictionary does not exist\n";
	return ();
    };
    (dbmopen (%dict, $dictionary, 0644)) || do {
	warn "ckpasswd: error opening $dictionary: $!\n";
	return ();
    };
    local ($found) = $dict{"$word\0"};
    dbmclose (%dict);
    defined($found);
}

#==========================================================================
#=== ispell lookup ========================================================

package ispell;

sub find 
# Feed word to ispell, and return true if word is spelled correctly.
{
    local ($dictionary, $word) = @_;

    # Only check real words
    return () unless ($word =~ /^[A-Za-z]+$/); 

    # Open ispell connection
    local ($IN, $OUT, $_);
    $IN = "IN_$dictionary";
    $OUT = "OUT_$dictionary";
    unless ($opened{$dictionary}) {
	eval {
	    &main'open2 ($OUT, $IN, $main'ISPELL, '-ald', $dictionary);
	};
	die "\nerror invoking ispell\n$@" if ($@);
	select ((select($IN), $| = 1)[0]);
	$_ = <$OUT>;		# Skip startup message
	$opened{$dictionary} = 1;
    }
	
    # Print word and get reply
    print $IN "$word\n";
    chop ($_ = <$OUT>); <$OUT>;
    /^\*/ || /^\+/;
}

##=== END of ckpasswd =====================================================
