view release on metacpan or  search on metacpan

bin/hsxkpasswd  view on Meta::CPAN

# === Process Args ============================================================#
#

# parse the commandline options
my $verbose = 0;
my %cmd_args = ();
GetOptions(
    #
    # -- the 'do and exit' options --
    #
    'help|h' => sub{
        pod2usage(
            -exitval => 0,
            -verbose => 2,
        );
    },
    'version|v' => sub{
        pod2usage(
            -exitval => 0,
            -verbose => 99,
            -sections => 'NAME',
        );
    },
    'test-config|t=s' => sub{
        my ($opt_name, $val) = @_;
        unless(-f $val){
            byeee("file $val does not exist");
        }
        open my $CONFIG_FH, '<', $val or byee("failed to read file $val with error:\n* $OS_ERROR");
        my $json_string = do{local $/ = undef; <$CONFIG_FH>};
        close $CONFIG_FH;
        my $config;
        eval{
            $config = decode_json($json_string);
            1; # explicit evaluation
        }or do{
            byeee("failed to parse the config JSON string:\n* source file: $val\n* parse error: $EVAL_ERROR");
        };
        say 'Distilling the config down to just valid keys ...';
        $config = Crypt::HSXKPasswd->distil_to_config_keys($config, warn_invalid_key_names => 1);
        say q{}; # empty line
        say 'Validing the distilled config ...';
        my $is_valid = Config->check(Config->coerce($config));
        if($is_valid){
            say '** Config OK **';
        }else{
            say '** Config INVALID **';
            say Config->get_message($config);
            exit 1;
        }
        exit 0;
    },
    'test-rcfile=s' => sub{
        my ($opt_name, $val) = @_;
        unless(-f $val){
            byeee("file $val does not exist");
        }
        open my $RCFILE_FH, '<', $val or byee("failed to read file $val with error:\n* $OS_ERROR");
        my $json_string = do{local $/ = undef; <$RCFILE_FH>};
        close $RCFILE_FH;
        my $rcdata;
        eval{
            $rcdata = decode_json($json_string);
            1; # explicit evaluation
        }or do{
            byeee("failed to parse the hsxkpasswdrc file's content as JSON:\n* source file: $val\n* parse error: $EVAL_ERROR");
        };
        say 'Validing the converted datatsructure from the hsxkpasswdrc file ...';
        my $is_valid = RCFileData->check($rcdata);
        if($is_valid){
            say '** hsxkpasswdrc data OK **';
        }else{
            say '** hsxkpasswdrc data INVALID **';
            say RCFileData->get_message($rcdata);
            exit 1;
        }
        exit 0;
    },
    #
    # -- the delayed 'do and exit' options --
    #
    'list-presets|l' => sub{
        my ($opt_name, $val) = @_;
        $cmd_args{do_list_presets} = 1;
    },
    #
    # -- the regular data options --
    #
    'preset|p=s' => sub{
        my ($opt_name, $val) = @_;
        my $preset_name = uc $val; # convert to upper-case
        unless(UppercaseIdentifier->check($preset_name)){
            byeee("$val is not a valid preset name, should only contain un-accented letters, digits and underscores");
        }
        $cmd_args{preset} = $preset_name;
    },
    'overrides|o=s' => sub{
        my ($opt_name, $val) = @_;
        my $overrides = {};
        eval{
            $overrides = decode_json($val);
            1; # explicit evaluation
        }or do{
            byeee("failed to parse JSON preset overrides string with error:\n* $EVAL_ERROR");
        };
        unless(ConfigOverride->check(ConfigOverride->coerce($overrides))){
            byeee("invalid preset overrides:\n* ".ConfigOverride->get_message($overrides));
        }
        $cmd_args{preset_overrides} = $overrides;
    },
    'config-file|c=s' => sub{
        my ($opt_name, $val) = @_;
        unless(-f $val){
            byeee("file $val does not exist");
        }
        open my $CONFIG_FH, '<', $val or byee("failed to read file $val with error:\n* $OS_ERROR");
        my $json_string = do{local $/ = undef; <$CONFIG_FH>};
        close $CONFIG_FH;
        my $config = {};
        eval{
            $config = decode_json($json_string);
            1; # explicit evaluation
        }or do{
            byeee("failed to parse JSON config string from file $val with error:\n* $EVAL_ERROR");
        };
        unless(Config->check(Config->coerce($config))){
            byeee("invalid config from file $val:\n* ".Config->get_message($config));
        }
        $cmd_args{config} = $config;
    },
    'dict-file|d=s' => sub{
        my ($opt_name, $val) = @_;
        unless(NonEmptyString->check($val)){
            byee('--dict-file cannot specify an empty string');
        }
        unless(-f $val){
           byeee("file $val does not exist");
        }
        $cmd_args{'dict-file'} = $val;
    },
    'dict-pkg=s' => sub{
        my ($opt_name, $val) = @_;
        unless(PerlPackageName->check($val)){
            byeee("$val is not a valid Perl Package name");
        }
        $cmd_args{'dict-pkg'} = $val;
    },
    'dict-pkg-args=s' => sub{
        my ($opt_name, $val) = @_;
        my $args = [];
        eval{
            $args = decode_json($val);
            1; # explicit evaluation
        }or do{
            byeee("failed to parse --dict-pkg-args as JSON with error:\n* $EVAL_ERROR");
        };
        unless(ArrayRef->check($args)){
            byeee('--dict-pkg-args did not specify JSON representing an array');
        }
        $cmd_args{'dict-pkg-args'} = $args;
    },
    'rng-pkg|r=s' => sub{
        my ($opt_name, $val) = @_;
        unless(PerlPackageName->check($val)){
            byeee("$val is not a valid Perl Package name");
        }
        $cmd_args{'rng-pkg'} = $val;
    },
    'rng-pkg-args=s' => sub{
        my ($opt_name, $val) = @_;
        my $args = [];
        eval{
            $args = decode_json($val);
            1; # explicit evaluation
        }or do{
            byeee("failed to parse --rng-pkg-args as JSON with error:\n* $EVAL_ERROR");
        };
        unless(ArrayRef->check($args)){
            byeee('--rng-pkg-args did not specify JSON representing an array');
        }
        $cmd_args{'rng-pkg-args'} = $args;
    },
    'rcfile=s' => sub{
        my ($opt_name, $val) = @_;
        if($val eq 'NONE'){
            $cmd_args{no_rcdata} = 1;
        }else{
            $cmd_args{rcdata} = load_rcfile($val);
        }
    },
    'verbose' => \$verbose,
    'warn|w=s' => sub{
        my ($opt_name, $val) = @_;
        unless(EntropyWarningLevel->check($val)){
            byeee('invalid entropy warning level: '.EntropyWarningLevel->get_message($val));
        }
        $cmd_args{warn} = uc $val; # make sure it's upper case
    },
) or pod2usage(
    -exitval => 1,
    -verbose => 0,
);

# process the bare args
my $num_pwds = shift @ARGV;
if($num_pwds){
    # validate the passed number of args
    unless(NonZeroPositiveInteger->check($num_pwds)){
        say 'ERROR - invalid number of passwords requested:';
        say '* '.NonZeroPositiveInteger->get_message($num_pwds);
        exit 1;
    }
}else{
    $num_pwds = 1;
}

#
# === Try load an hsxkpasswdrc file if possible ================================#
#

# try determine the user's home dir and .hsxkpasswdrc file path
my @home_dir = File::Spec->splitdir(File::HomeDir->my_home());
my $dot_hsxkpasswdrc_path = File::Spec->catfile(@home_dir, '.hsxkpasswdrc');

# start with blank rcdata
my $rcdata = {};

# unless we're skipping rcdata completely, try from the args, then from ~/hsxkpasswdrc
if($cmd_args{no_rcdata}){
    note('loading of hsxkpasswdrc files disabled with --rcfile=NONE');
}else{
    if($cmd_args{rcdata}){
        $rcdata = $cmd_args{rcdata};
        note('using hsxkpasswdrc file from --rcfile option');
    }elsif(-f $dot_hsxkpasswdrc_path){
        $rcdata = load_rcfile($dot_hsxkpasswdrc_path);
        note("using hsxkpasswdrc file $dot_hsxkpasswdrc_path");
    }else{
        note('no hsxkpasswdrc file loaded');
    }
}

#
# === List presets and exit if --list-presets =================================#
#
if($cmd_args{do_list_presets}){
    # merge the presets into a single array
    my %preset_lookup = ();
    my %standard_preset_lookup = ();
    my %custom_preset_lookup = ();
    foreach my $preset (Crypt::HSXKPasswd->defined_presets()){
        $preset_lookup{$preset} = 1;
        $standard_preset_lookup{$preset} = 1;
    }
    if($rcdata->{custom_presets}){
        foreach my $preset (keys %{$rcdata->{custom_presets}}){
            $preset_lookup{$preset} = 1;
            $custom_preset_lookup{$preset} = 1;
        }
    }
    
    # if there are custom presets, print out the detail if in verbose mode
    if($verbose && $rcdata->{custom_presets}){
        note('custom presets (from hsxkpasswdrc file): '.(join q{, }, keys %custom_preset_lookup));
        my @unoverriden_standard_presets = ();
        my @overridden_standard_presets = ();
        foreach my $preset (sort keys %standard_preset_lookup){
            if($custom_preset_lookup{$preset}){
                push @overridden_standard_presets, $preset;
            }else{
                push @unoverriden_standard_presets, $preset;
            }
        }
        if(scalar @unoverriden_standard_presets){
            note('available standard presets: '.(join q{, }, @unoverriden_standard_presets));
        }
        if(scalar @overridden_standard_presets){
            note('UN-AVAILABLE standard presets (custom presets with same name): '.(join q{, }, @overridden_standard_presets));
        }
        say {*STDERR} q{}; # print a blank line to STDERR to make the output easier to read
    }
    
    # always print a de-duplicated list of all defined presets
    say join q{, }, sort keys %preset_lookup;
    
    # exit with success
    exit 0;
}

#
# === Set the Warning Level (if specified) ====================================#
#
if($cmd_args{warn}){
    Crypt::HSXKPasswd->module_config('ENTROPY_WARNINGS', $cmd_args{warn});
    note('using entropy warning level specified with --warn option');
}elsif($rcdata->{default_entropy_warnings}){
    Crypt::HSXKPasswd->module_config('ENTROPY_WARNINGS', $rcdata->{default_entropy_warnings});
    note('using entropy warning level specified in hsxkpasswdrc file');
}else{
    note('no custom entropy warning level set');
}

#
# === Assemble the options for the HSXKPasswd constructor =====================#
#

my %hsxkpwd_args = ();

# deal with the config - first try a directly specified config, then a preset,
# then fall back to the default config
if($cmd_args{config}){
    $hsxkpwd_args{config} = $cmd_args{config};
    note('using config from file specified with --config-file option');
}elsif($cmd_args{preset}){
    # if there is a matching custom preset, use it to generate a config,
    # otherwise treat the config as a standard config
    if($rcdata->{custom_presets} && $rcdata->{custom_presets}->{$cmd_args{preset}}){
        # we are a custom preset
        my $config = $rcdata->{custom_presets}->{$cmd_args{preset}}->{config};
        
        # apply any overrides if needed
        if($cmd_args{preset_overrides}){
            # save the keys into the config
            foreach my $key (keys %{$cmd_args{preset_overrides}}){
                $config->{$key} = $cmd_args{preset_overrides}->{$key};
            }
            # validate the resulting config
            unless(Config->check($config)){
                byeee('the custom preset combined with the specified overrides produces an invalid config: '.Config->get_message($config));
            }
        }
        
        # save to the hsxkpasswd arguments object
        $hsxkpwd_args{config} = $config;
        note(qq{using config from custom preset '$cmd_args{preset}'});
    }else{
        # treat as a standard config - make sure it exists, then use
        unless(PresetName->check($cmd_args{preset})){
            byeee("no preset exists with the name '$cmd_args{preset}' (you can see all defined presets with: hsxkpasswd --list-presets)");
        }
        $hsxkpwd_args{preset} = $cmd_args{preset};
        if($cmd_args{preset_overrides}){
            $hsxkpwd_args{preset_overrides} = $cmd_args{preset_overrides};
        }
        note(qq{using standard preset '$cmd_args{preset}'});
    }
}else{
    # if the preset DEFUALT is ovrridden by the rcdata, us it
    if($rcdata->{custom_presets} && $rcdata->{custom_presets}->{'DEFAULT'}){
        $hsxkpwd_args{config} = $rcdata->{custom_presets}->{'DEFAULT'}->{config};
        note('using custom default config from hsxkpasswdrc file');
    }else{
        note('using standard default config');
    }
}

# deal with the dictionary - the commandline takes precedence, then the rc file
if($cmd_args{'dict-file'}){
    $hsxkpwd_args{dictionary_file} = $cmd_args{'dict-file'};
    note('using dictionary file from --dict-file option');
}elsif($cmd_args{'dict-pkg'}){
    $hsxkpwd_args{dictionary} = load_dictionary(
        $cmd_args{'dict-pkg'},
        $cmd_args{'dict-pkg-args'} || [],
    );
    note('using dictionary package from --dict-pkg option');
}elsif($rcdata->{default_dictionary}){
    if($rcdata->{default_dictionary}->{file}){
        $hsxkpwd_args{dictionary_file} = $rcdata->{default_dictionary}->{file};
        note('using dictionary file from hsxkpasswdrc file');
    }elsif($rcdata->{default_dictionary}->{package}){
        $hsxkpwd_args{dictionary} = load_dictionary(
            $rcdata->{default_dictionary}->{package},
            $rcdata->{default_dictionary}->{package_constructor_args} || [],
        );
        note('using dictionary package from hsxkpasswdrc file');
    }else{
        # this should be impossible if the rcfile validation is working!
        note('using default word source');
    }
}else{
    note('using default word source');
}

# deal wit the rng - the commandline takes precedence, then the rc file
if($cmd_args{'rng-pkg'}){
    $hsxkpwd_args{rng} = load_rng(
        $cmd_args{'rng-pkg'},
        $cmd_args{'rng-pkg-args'} || [],
    );
    note('using rng package from --rng-pkg option');
}elsif($rcdata->{default_rng}){
    $hsxkpwd_args{rng} = load_rng(
        $rcdata->{default_rng}->{package},
        $rcdata->{default_rng}->{package_constructor_args} || [],
    );
    note('using rng package from hsxkpasswdrc file');
}else{
    note('using default rng');
}

#
# === Generate the Password(s) ================================================#
#

# try create an HSXKPasswd object
my $hsxkpwd_obj;
eval{
    $hsxkpwd_obj = Crypt::HSXKPasswd->new(%hsxkpwd_args);
    1; # explicit evaluation
}or do{
    say "ERROR - failed to initialise HSXKPasswd with error:\n* $EVAL_ERROR";
    exit 2;
};

# if in verbose mode, print the status of the password generator
if($verbose){
    say {*STDERR} "\n".$hsxkpwd_obj->status();
}

# genereate and print the passwords
say join "\n", $hsxkpwd_obj->passwords($num_pwds);

#
# === Helper Functions ========================================================#
#

#####-SUB-######################################################################
# Type       : SUBROUTINE
# Purpose    : Whine about bad user input and exit
# Returns    : nothing, since this function exists the script.
# Arguments  : 1) the message to depart with
# Throws     : NOTHING
# Notes      : Imagine the function name in Queenie from Black Adder's accent :)
# See Also   :
sub byeee{
    say q{ERROR - }.(shift);
    exit 1;
}

#####-SUB-######################################################################
# Type       : SUBROUTINE
# Purpose    : Print a verbose-mode-only message if appropriate
# Returns    : VOID (always returns 1 to keep perlcritic happy)
# Arguments  : 1) the message to print
# Throws     : NOTHING
# Notes      :
# See Also   :
sub note{
    say {*STDERR} q{*NOTE* }.(shift) if $verbose;
    return 1; # to keep perlcritic happy
}

#####-SUB-######################################################################
# Type       : SUBROUTINE
# Purpose    : Try load an hsxkpasswdrc file
# Returns    : A valid RDFileData hashref
# Arguments  : 1) the path to try load the data from
# Throws     : NOTHING - but does exit the script on error
# Notes      : Exits the script with a sane error message via byeee() on error.
# See Also   : byeee()
sub load_rcfile{
    my $rcfile_path = shift;
    
    # validate the args
    unless(NonEmptyString->check($rcfile_path)){
        byeee('load_rcfile(): invalid args, must pass a file path as the first argument');
    }
    unless(-f $rcfile_path){
        byeee("file $rcfile_path does not exist");
    }
    
    # try slurp the file
    open my $RCFILE_FH, '<', $rcfile_path or byee("failed to read file $rcfile_path with error:\n* $OS_ERROR");
    my $json_string = do{local $/ = undef; <$RCFILE_FH>};
    close $RCFILE_FH;
    
    # try parse the file to JSON
    my $loaded_rcdata = {};
    eval{
        $loaded_rcdata = decode_json($json_string);
        1; # explicit evaluation
    }or do{
        byeee("failed to parse JSON string from file $rcfile_path with error:\n* $EVAL_ERROR");
    };
    
    # validate the data structure represnted by the JSON
    unless(RCFileData->check($loaded_rcdata)){
        byeee("invalid hsxkpasswdrc data from file $rcfile_path:\n* ".RCFileData->get_message($loaded_rcdata));
    }
    
    # return the data
    return $loaded_rcdata;
}

#####-SUB-######################################################################
# Type       : SUBROUTINE
# Purpose    : Load a dictionary object form a package name
# Returns    : An object of a class that extends Crypt::HSXKPasswd::Dictionary
# Arguments  : 1) the Perl package name as a string
#              2) a reference to an array
# Throws     : NOTHING - exists the script if there is a problem
# Notes      : Exits the script with a sane error message via byeee() on error.
# See Also   : byeee()
sub load_dictionary{
    my $pkg_name = shift;
    my $args_ref = shift;
    
    # validate args
    unless(NonEmptyString->check($pkg_name)){
        byeee('load_dictionary(): invalid args, must pass a perl package name as the first argument');
    }
    unless(PerlPackageName->check($pkg_name)){
        byeee(PerlPackageName->get_message($pkg_name));
    }
    unless(ArrayRef->check($args_ref)){
        byeee('load_dictionary(): invalid args, must pass a reference to an array as the second argument');
    }
    
    # try instantiate an object with the passed class & args
    my $dict;
    eval{
        load $pkg_name;
        $dict = $pkg_name->new(@{$args_ref});
        1; # explicit evaluation
    }or do{
        byeee("failed to use '$pkg_name' to initialise a word source with error:\n* $EVAL_ERROR");
    };
    
    # return the object
    return $dict;
}

#####-SUB-######################################################################
# Type       : SUBROUTINE
# Purpose    : Load an rng object form a package name
# Returns    : An object of a class that extends Crypt::HSXKPasswd::RNG
# Arguments  : 1) the Perl package name as a string
#              2) a reference to an array
# Throws     : NOTHING - exists the script if there is a problem
# Notes      : Exits the script with a sane error message via byeee() on error.
# See Also   : byeee()
sub load_rng{
    my $pkg_name = shift;
    my $args_ref = shift;
    
    # validate args
    unless(NonEmptyString->check($pkg_name)){
        byeee('load_rng(): invalid args, must pass a perl package name as the first argument');
    }
    unless(PerlPackageName->check($pkg_name)){
        byeee(PerlPackageName->get_message($pkg_name));
    }