aboutsummaryrefslogtreecommitdiffstats
path: root/icevault
diff options
context:
space:
mode:
authorGuilhem Moulin <guilhem@fripost.org>2015-03-21 17:13:32 +0100
committerGuilhem Moulin <guilhem@fripost.org>2015-03-23 12:54:09 +0100
commit80438cd2af17083d85bb12da6756961abfedecbb (patch)
treefa7f801395d3e38ceebc28cca7c14b97bbbfcbcc /icevault
parentce23c7053355aa3bdae387959eeeb2a67ced2ad3 (diff)
Move the CLI part to a dedicated dir, with a separate Makefile.
Diffstat (limited to 'icevault')
-rwxr-xr-xicevault907
1 files changed, 0 insertions, 907 deletions
diff --git a/icevault b/icevault
deleted file mode 100755
index 43b8e50..0000000
--- a/icevault
+++ /dev/null
@@ -1,907 +0,0 @@
-#!/usr/bin/perl -T
-
-# IceVault - An external password manager for firefox
-# Copyright © 2015 Guilhem Moulin <guilhem@fripost.org>
-#
-# 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 warnings;
-
-our $VERSION = '0.1';
-use Getopt::Long qw/:config posix_default no_ignore_case gnu_compat
- bundling auto_version/;
-use Encode qw/decode_utf8 encode_utf8/;
-use I18N::Langinfo ();
-use List::Util qw/all any first min none/;
-
-
-# Clean up PATH, and set TMPDIR to a ramdisk's mountpoint if possible
-$ENV{PATH} = join ':', qw{/usr/local/bin /usr/bin /bin};
-$ENV{TMPDIR} //= first { -d } qw{/dev/shm /run/shm /var/run/shm /tmp};
-delete @ENV{qw/IFS CDPATH ENV BASH_ENV/};
-
-my $LANGINFO = I18N::Langinfo::langinfo(I18N::Langinfo::CODESET());
-my $LOCALE = Encode::find_encoding $LANGINFO;
-my %CONFIG;
-my $SOCKET;
-
-
-#######################################################################
-# Utilities
-
-# myprintf [FILEHANDLE,] FORMAT, LIST
-# Like printf, but allows locale-dependent markup.
-sub myprintf($@) {
- my $fh = ref $_[0] eq 'GLOB' ? shift : \*STDOUT;
- my $format = shift;
- chomp $format;
- $LANGINFO =~ /^utf-?8$/aai ? $format =~ s/C<%s>/\N{U+2018}%s\N{U+2019}/g
- : $format =~ s/C<%s>/'%s'/g;
- $format =~ s/I<%s>/%s/g;
- $format =~ s/B<%s>/%s/g;
- die "Illegal markup '$1' in message:\n", $format if $format =~ /([A-Z])<%s>/;
- printf $fh map {$LOCALE->encode($_)} ($format."\n", @_);
-}
-
-# error FORMAT, LIST
-sub error($@) {
- myprintf \*STDERR, shift, @_;
- exit 1;
-}
-
-# warning FORMAT, LIST
-sub warning($@) {
- myprintf \*STDERR, shift, @_;
-}
-
-# Print usage and exit.
-sub usage($) {
- my $rv = shift;
- my $fh = $rv ? \*STDERR : \*STDOUT;
- print $fh "Usage: $0 [OPTIONS] [fill] scheme://hostname/identity\n"
- ." or: $0 [OPTIONS] insert [identity]\n"
- ." or: $0 [OPTIONS] dump scheme://hostname/identity\n"
- ." or: $0 [OPTIONS] clip scheme://hostname/identity\n"
- ." or: $0 [OPTIONS] edit scheme://hostname/identity\n"
- ." or: $0 [OPTIONS] ls [scheme://[hostname/[identity]]]\n"
- . "Consult the manual page for more information.\n";
- exit $rv;
-}
-
-# grepIdx BLOCK LIST
-# Evaluates the BLOCK for each element of LIST (locally setting $_ to
-# each element) and returns the list value consisting of the index of
-# those elements for which the expression evaluated to true.
-sub grepIdx(&@) {
- my ($code, @list) = @_;
- my @ret;
- for (my $i = 0; $i <= $#list; $i++) {
- local $_ = $list[$i];
- push @ret, $i if $code->();
- }
- return @ret;
-}
-
-# firstIdx BLOCK LIST
-# Evaluates the BLOCK for each element of LIST (locally setting $_ to
-# each element) and returns the first index of those elements for which
-# the expression evaluated to true. Or undef if the expression never
-# evaluates to true.
-sub firstIdx(&@) {
- my ($code, @list) = @_;
- for (my $i = 0; $i <= $#list; $i++) {
- local $_ = $list[$i];
- return $i if $code->();
- }
- return;
-}
-
-sub groupByName(@) {
- my @fields = @_;
- my %indices;
- for (my $i = 0; $i <= $#fields; $i++) {
- push @{$indices{$fields[$i]->{name}}}, $i;
- }
- return %indices;
-}
-
-sub delete($$) {
- my ($x, $l) = @_;
- @$l = grep { $_ ne $x } @$l;
-}
-
-
-#######################################################################
-
-# Load the given configuration file
-sub loadConfig($) {
- my $configFile = shift;
- error "Configuration file C<%s> doesn't exist", $configFile unless -f $configFile;
- open my $CONFIG, '<', $configFile or error "Can't open C<%s>: %s", $configFile, $!;
- while (<$CONFIG>) {
- chomp;
- s/#.*//; # ignore comments
- next if /^\s*$/; # ignore empty and blank lines
- /^([-\@\w.]+)(?:\s*=\s*)(\p{print}+)/ or error "Can't parse config line: C<%s>", $_;
- $CONFIG{$1} //= $2;
- }
- close $CONFIG;
-}
-
-# Connect to the given socket and assign the IO::Socket object to
-# $SOCKET. If the socket path is relative, prepend the default Firefox
-# profile (or the first profile found if there is no default profile).
-# Returns "scheme://hostname:port" (the ":port" part is optional)
-sub connect($) {
- my $sockname = shift;
-
- if ($sockname !~ /^\//) { # relative path
- my $ffdir = "$ENV{HOME}/.mozilla/firefox";
- opendir my $dh, $ffdir or error "Can't open directory C<%s>: %s", $ffdir, $!;
- my $profile;
- while (readdir $dh) {
- next if $_ eq '.' or $_ eq '..';
- next unless -d "$ffdir/$_";
- if (/\.default$/) { # default profile takes precedence
- $profile = $_;
- last;
- }
- $profile //= $_;
- }
- closedir $dh;
- error "No Firefox profile found under C<%s>", $ffdir unless defined $profile;
- $sockname = "$ffdir/$profile/$sockname";
- myprintf \*STDERR, "Using socket C<%s>", $sockname if $CONFIG{debug};
- }
-
- require 'IO/Socket/UNIX.pm';
- $SOCKET = IO::Socket::UNIX->new( Type => IO::Socket::UNIX::SOCK_STREAM(), Peer => $sockname )
- or error "Can't connect to socket C<%s>: %s", $sockname, $!;
-
- # get the URI greeting; don't perform domain validation (it's done
- # by the browser), but ensure that it doesn't contain non-graphical
- # chars, : or /
- require 'JSON.pm';
- my $uri = getResponse();
- $uri =~ s/\A([A-Za-z0-9-]+:\/\/[^\P{Graph}:\/]+(?::\d+)?)(?:\/.*)?\z/$1/
- or error "Invalid URI C<%s>", $uri;
-
- my $scheme = $uri =~ s/:\/\/.*//r;
- warning "Warning: Insecure (%s://) connection! Form values can be stolen", $scheme
- unless $scheme eq 'https';
-
- return lc $uri;
-}
-
-# Read a response line on the socket, and return the decoded scalar or
-# object.
-sub getResponse() {
- my $buf = $SOCKET->getline;
- chomp $buf;
- myprintf \*STDERR, "S: %s", decode_utf8 $buf if $CONFIG{debug};
- my ($code, $msg) = split / /, $buf, 2;
- # allow $msg to be decoded to a string
- $msg = JSON->new->utf8->allow_nonref->decode($msg) if defined $msg;
- if ($code eq 'OK') {
- return $msg;
- }
- elsif ($code eq 'BYE') {
- # terminates the connection
- $SOCKET->close;
- undef $SOCKET;
- }
- elsif ($code eq 'ERROR') {
- error "Server said: C<%s>", 'ERROR ' . decode_utf8 $msg;
- }
- else {
- error "Unexpected response from server: C<%s>", decode_utf8 $msg;
- }
-}
-
-# Send the given UTF8 string (with a linefeed appended) on to the
-# socket, flush the handle, then return the server response.
-sub sendCommand(@) {
- my $command = join(' ',@_);
- myprintf \*STDERR, "C: %s", Encode::decode_utf8 $command if $CONFIG{debug};
- $command .= "\n";
- for (my $offset = 0; $offset < length $command;) {
- $offset += $SOCKET->syswrite($command, length($command) - $offset, $offset);
- }
- $SOCKET->flush;
- getResponse();
-}
-
-# Get all identities with the given $prefix. If there are multiple
-# matches and $all is false, limit the output to one depth more than the
-# longuest common prefix.
-sub complete($;$) {
- my $prefix = shift // '';
- my $all = shift;
- require 'File/Glob.pm';
-
- my $pat = $CONFIG{store};
- my ($s, $h, $i); # extract URI components from the prefix
- if ($prefix =~ /\A([A-Za-z0-9-]+):\/\/([^\P{Graph}:\/]+(?::\d+)?)\/([^\P{Print}\/]*)\z/) {
- ($s, $h, $i) = ($1, $2, $3);
- } elsif ($prefix =~ /\A([A-Za-z0-9-]+):\/\/([^\P{Graph}\/]*)\z/) {
- ($s, $h, $i) = ($1, $2, undef);
- } elsif ($prefix =~ /\A([A-Za-z0-9-]*)(:\/?)?\z/) {
- ($s, $h, $i) = ($1, (defined $2 ? '' : undef), undef);
- } else {
- exit;
- }
-
- # construct a glob pattern with these URI components
- my ($gs, $gh, $gi) = ($s, $h, $i);
- s/([\\\[\]\{\}\*\?\~])/\\$1/g foreach grep defined, ($gs, $gh, $gi); # escape meta chars
-
- # add trailing wildcards
- $gs .= '*' if defined $gs and !defined $gh;
- $gh .= '*' if defined $gh and !defined $gi;
- $gi .= '*' if defined $gi;
-
- my $glob = $pat;
- $glob =~ s/([\\\[\]\{\}\*\?\~])/\\$1/g;
- $glob =~ s{\%(.)}{ $1 eq '%' ? '%' :
- $1 eq 's' ? $gs // '*' :
- $1 eq 'h' ? $gh // '*' :
- $1 eq 'i' ? $gi // '*' :
- die "Invalid placeholder %$1" }ge;
-
- # construct regexp to extract the URI compontents of the matching URIs
- my ($ps, $ph, $pi) = ($s, $h, $i);
- $ps = defined $h ? qr/(?<s>\Q$s\E)/ : (defined $s and $s ne '') ? qr/(?<s>\Q$s\E[A-Za-z0-9-]*)/ : qr/(?<s>[A-Za-z0-9-]+)/;
- $ph = defined $i ? qr/(?<h>\Q$h\E)/ : (defined $h and $h ne '') ? qr/(?<h>\Q$h\E[^\P{Graph}\/]*)/ : qr/(?<h>[^\P{Graph}\/]+)/;
- $pi = (defined $i and $i ne '') ? qr/(?<i>\Q$i\E[^\P{Print}\/]*)/ : qr/(?<i>[^\P{Print}\/]+)/;
-
- $pat =~ s/(\%.)([^\%]*)\z/$1.quotemeta($2)/e;
- $pat =~ s{(.*?)\%(.)}{$2 eq '%' ? '%' :
- $2 eq 's' ? quotemeta($1).$ps :
- $2 eq 'h' ? quotemeta($1).$ph :
- $2 eq 'i' ? quotemeta($1).$pi :
- die "Invalid placeholder %$1"}ge;
- $pat = qr/\A$pat\z/;
-
- myprintf \*STDERR, "Using glob pattern C<%s>", $glob if $CONFIG{debug};
- myprintf \*STDERR, "Using regexp C<%s>", "$pat" if $CONFIG{debug};
-
- my @matches;
- foreach my $filename (File::Glob::bsd_glob($glob)) {
- $LOCALE->decode($filename) =~ $pat or die "$filename doesn't match $pat";
- push @matches, "$+{s}://$+{h}/$+{i}";
- }
- return @matches if $all or $#matches < 1;
-
- # find the longest common prefix to determine the depth level of completion
- $matches[0] =~ /\A([A-Za-z0-9-]+):\/\/([^\P{Graph}:\/]+(?::\d+)?)\// or die;
- ($s, $h) = ($1, $2);
-
- if (all { /\A\Q$s\E:\/\/\Q$h\E\// } @matches) { # common host: list all ids
- } elsif (all { /\A\Q$s\E:\/\// } @matches) { # common scheme: list only hosts
- s#/[^\P{Print}\/]+\z#/# foreach @matches;
- } else { # no common scheme: list only schemes
- s#://[^\P{Graph}\/]+/[^\P{Print}\/]+\z#://# foreach @matches;
- }
-
- my %matches = map {( $_ => 1 )} @matches;
- return sort keys %matches;
-}
-
-# Redact passwords, unless $CONFIG{'show-passwords'} is set.
-sub safeValue($;$) {
- my $field = shift;
- my $value = shift // $field->{value};
- return ($field->{type} eq 'password' and !$CONFIG{'show-passwords'}) ?
- ('x' x length $value) : $value;
-}
-
-# Send a FILL command with the given form index and field values.
-sub fill($$@) {
- my $idx = shift;
- my $form = shift;
- my @fill = @_;
-
- return if none {defined} @fill; # noop
- for (my $i = 0; $i <= $#fill; $i++) {
- myprintf "Filling field C<%s>, value C<%s>",
- $form->{fields}->[$i]->{name},
- safeValue($form->{fields}->[$i], $fill[$i])
- if defined $fill[$i];
- }
-
- sendCommand('FILL', $idx, JSON::encode_json(\@fill));
-}
-
-# Parse a scheme://hostname(:port)?/identity, and return the associated
-# file.
-sub getIdentityFile($) {
- my $id = shift;
- $id =~ /\A([A-Za-z0-9-]+):\/\/([^\P{Graph}:\/]+(?::\d+)?)\/([^\P{Print}\/]+)\z/
- or error "Invalid identity C<%s>", $id;
- my ($s, $h, $i) = ($1, $2, $3);
-
- my $filename = $CONFIG{store};
- $filename =~ s{\%(.)}{ $1 eq '%' ? '%' :
- $1 eq 's' ? $s :
- $1 eq 'h' ? $h :
- $1 eq 'i' ? $i :
- die "Invalid placeholder %$1" }ge;
- return $filename;
-}
-
-# Decrypt the given identity file and return the YAML-parsed form.
-open my $NULL, '<', '/dev/null';
-sub loadIdentityFile($;$) {
- my ($filename, $fh) = @_;
- myprintf \*STDERR, "Decrypting identity file C<%s>", $filename if $CONFIG{debug};
-
- require 'IPC/Open2.pm';
- my $pid = IPC::Open2::open2( (defined wantarray ? $fh : ">&".$fh->fileno)
- , "<&".fileno($NULL)
- , $CONFIG{gpg}, qw/-o - --decrypt --/, $filename)
- or error "Can't fork: %s", $!;
- my $str = do { local $/ = undef; <$fh> } if defined wantarray;
- waitpid $pid, 0;
- error "C<%s> exited with value %d", $CONFIG{gpg}, ($? >> 8) if $? and $? != -1;
- close $fh;
-
- return unless defined wantarray;
-
- # the cleartext's charset is always UTF8
- require 'YAML/Tiny.pm'; # XXX use Tiny::YAML instead?
- return YAML::Tiny::Load(decode_utf8 $str) if defined wantarray;
-}
-
-# Dump and encrypt a form into the given filename.
-sub saveIdentityFile($$) {
- my ($form, $filename) = @_;
- myprintf \*STDERR, "Saving identity file C<%s>", $filename if $CONFIG{debug};
-
- require 'File/Copy.pm';
- require 'File/Path.pm';
- require 'File/Temp.pm';
- require 'IPC/Open2.pm';
- require 'YAML/Tiny.pm' if ref $form; # XXX use Tiny::YAML instead?
-
- # don't encrypt directly into the destination file so we don't
- # end up with a messed up file if something goes wrong
- my $outfh = File::Temp->new(SUFFIX => '.gpg', UNLINK => 0, TMPDIR => 1);
- my $pid = IPC::Open2::open2( ">&".$outfh->fileno
- , (ref $form ? my $infh : "<&".fileno($NULL))
- , $CONFIG{gpg}, qw/-o - --no-encrypt-to --recipient/, $CONFIG{keyid}
- , '--encrypt', '--', (ref $form ? () : $form)
- )
- or error "Can't fork: %s", $!;
-
- if (ref $form) {
- $form->{fields} = [ grep defined, @{$form->{fields}} ]; # remove undefined fields
- print $infh encode_utf8(YAML::Tiny::Dump($form)); # dump the form as UTF8
- close $infh;
- }
- waitpid $pid, 0;
- error "C<%s> exited with value %d", $CONFIG{gpg}, ($? >> 8) if $? and $? != -1;
- $outfh->close;
-
- my $parent_dir = $filename =~ s/\/[^\/]+$//r;
- File::Path::make_path($parent_dir) unless -d $parent_dir; # create parent directories recursively
- File::Copy::move($outfh->filename, $filename) or error "Can't move C<%s>: %s", $outfh->filename, $!;
-
- # TODO: git add $filename; git commit
-}
-
-# Get the visible form list from the server, and croak if it's empty.
-sub getForms() {
- my $forms = sendCommand 'GETFORMS';
- error "No (visible) form found" unless @$forms;
- return @$forms;
-}
-
-# Guess which form is to be filled: take the first form with a password
-# field if there are any, otherwise the first non-empty form. If the
-# first argument is defined, only consider forms with a matching base
-# URI.
-sub findForm($@) {
- my $myform = shift;
- my @forms = @_;
-
- if (defined $myform) {
- # ignore forms with non-matching action
- @forms = map { $_->{action} =~ /\A\Q$myform->{baseURI}\E(?:\/.*)?\z/ ? $_ : undef } @forms;
- my @formIdx = grepIdx { defined $_ } @forms;
- error "No form found with action matching known base URI C<%s>", $myform->{baseURI}
- unless @formIdx;
- return $formIdx[0] if $#formIdx == 0; # single match
- }
-
- my $idx = firstIdx { defined $_ and any {$_->{type} eq 'password'} @{$_->{fields}} } @forms;
- $idx //= firstIdx { defined $_ and any {$_->{value} ne ''} @{$_->{fields}} } @forms;
- error 'Dunno which form to '. (defined $myform ? 'fill' : 'import') unless defined $idx;
- return $idx;
-}
-
-# For a page with two or three passwords, try to guess from their value
-# which are the old and new/confirm fields. Returns a list of indices
-# (old, new, confirm).
-sub guessPasswordPage(@) {
- my ($pw0, $pw1, $pw2) = @_;
- my ($idx0, $idx1, $idx2);
-
- if (!defined $pw2) {
- if ($pw0->{value} eq $pw1->{value}) {
- ($idx0, $idx1, $idx2) = (undef, 0, 1)
- }
- }
- else {
- if ($pw1->{value} eq $pw2->{value}) {
- ($idx0, $idx1, $idx2) = (0, 1, 2);
- }
- elsif ($pw0->{value} eq $pw1->{value}) {
- ($idx0, $idx1, $idx2) = (2, 0, 1);
- }
- elsif ($pw0->{value} eq $pw2->{value}) {
- ($idx0, $idx1, $idx2) = (1, 0, 2);
- }
- }
- return ($idx0, $idx1, $idx2);
-}
-
-# Generate a (single) random password for the given fields, with the
-# maximum possible length.
-sub pwgen(@) {
- my @fields = @_;
- return unless @fields;
- my $pwgen = $CONFIG{pwgen};
-
- # see how long the password is allowed to be
- my $l = $CONFIG{'max-password-length'};
- $l = min (map { my $x = $1 if defined $_->{maxLength} and $_->{maxLength} =~ /^(\d+)$/;
- (defined $x and $x > 0 and $x < $l) ? $x : $l } @fields);
- $pwgen =~ s/%d/$l/g;
- myprintf "Generating $l-char long random value for field".($#fields > 0 ? '(s) ' : ' ')
- .join(',', map {'C<%s>'} @fields),
- map {$_->{name}} @fields;
-
- my @pw = `$pwgen`;
- error "Can't exec C<%s>: %s", $pwgen, $! unless @pw;
- chomp $pw[$#pw]; # remove the last \n, but keep the others
- $_->{value} = join ('', @pw) foreach @fields;
-}
-
-# Prompt a question with an optional defaut response.
-sub prompt($;$) {
- my ($prompt, $default) = @_;
- $prompt .= " [$default]" if defined $default;
- print $LOCALE->encode($prompt), " ";
-
- my $r = <STDIN>;
- die "\n" unless defined $r;
- chomp $r;
- return ($r eq '' and defined $default) ? $default : $LOCALE->decode($r);
-}
-
-# Prompt a Yes/No question.
-sub promptYN($;$) {
- my $prompt = shift;
- my $default = shift // 0;
-
- while (1) {
- print $LOCALE->encode($prompt), " [", ($default ? 'Y/n' : 'y/N'), "] ";
- my $r = <STDIN>;
- die "\n" unless defined $r;
- chomp $r;
-
- if (lc $r eq 'y' or lc $r eq 'yes' or ($r eq '' and $default)) {
- return 1
- }
- elsif (lc $r eq 'n' or lc $r eq 'no' or ($r eq '' and !$default)) {
- return 0
- }
- myprintf \*STDERR, "Answer: C<%s> or C<%s>", 'y', 'n';
- }
-}
-
-# Get the SHA-256 digest of the given file.
-sub sha256_file($) {
- my $filename = shift;
-
- require 'Digest.pm';
- my $sha256 = Digest->new('SHA-256');
- open my $fh, '<', $filename or error "Can't open C<%s>: %s", $filename, $!;
- $sha256->addfile($fh);
- close $fh;
- return $sha256->digest;
-}
-
-
-#######################################################################
-
-GetOptions(\%CONFIG, qw/debug show-passwords|p socket|s=s help|? zero|0/) or usage(1);
-usage(0) if $CONFIG{help};
-
-# Load configuration
-my $XDG_CONFIG_HOME = $ENV{XDG_CONFIG_HOME} // "$ENV{HOME}/.config";
-my $XDG_DATA_HOME = $ENV{XDG_DATA_HOME} // "$ENV{HOME}/.data";
-loadConfig "$XDG_CONFIG_HOME/icevault";
-
-# Default options
-$CONFIG{gpg} //= 'gpg';
-$CONFIG{socket} //= 'S.IceVault';
-$CONFIG{store} //= "$XDG_DATA_HOME/icevault/%s/%h/%i.gpg";
-$CONFIG{pwgen} //= 'pwgen -s -cyn %d';
-$CONFIG{'max-password-length'} //= 32;
-$CONFIG{keyid} // error "Missing keyid in configuration file";
-error "C<%s> is not a 64-bits key ID or fingerprint", $CONFIG{keyid}
- unless $CONFIG{keyid} =~ /^(?:(?:0x)?\p{AHex}{16}|\p{AHex}{40})$/;
-
-usage(1) unless @ARGV;
-@ARGV = map { $LOCALE->decode($_) } @ARGV;
-my $command = $ARGV[0] =~ /\A[A-Za-z0-9-]+:\/\//aa ? 'fill' : shift;
-
-# Process the commands
-if ($command eq '_complete') {
- # used internaly for auto-completion
- usage(1) unless $#ARGV == 0;
- my $delim = $CONFIG{zero} ? "\0" : "\n";
- print $LOCALE->encode($_), $delim foreach complete(shift @ARGV);
- exit;
-}
-
-elsif ($command eq '_geturi') {
- # used internaly for auto-completion
- usage(1) if @ARGV;
- print $LOCALE->encode( &connect($CONFIG{socket}) ), "\n";
- sendCommand 'QUIT';
- exit;
-}
-elsif ($command eq 'insert') {
- usage(1) unless $#ARGV < 1;
- my $uri = &connect($CONFIG{socket});
- myprintf "Importing HTML form from URI C<%s>", $uri;
-
- my @forms = getForms();
- my $formIdx = findForm undef, @forms;
- my $form = $forms[$formIdx];
- my @fill = map {undef} (0 .. $#{$form->{fields}});
-
- if (defined $form->{action}) {
- $form->{baseURI} = delete $form->{action};
- # perform minimal validation on the action URI (ensure that it
- # doesn't contain non-graphical chars, " or /)
- $form->{baseURI} =~ s/\A([A-Za-z0-9-]+:\/\/[^\P{Graph}:\/]+(?::\d+)?)(?:\/.*)?\z/$1/
- or error "Invalid form action: C<%s>", $form->{baseURI};
- my $scheme = $uri =~ s/:\/\/.*//r;
- warning "Warning! Form action scheme C<%s> doesn't match the URI's", $scheme
- unless $uri =~ /\A\Q$scheme\E:\/\//;
- }
-
- my $id = shift;
- unless (defined $id) {
- # no identity was provided from command line: try to use the
- # last non-empty text field before the first password, and
- # fallback to the first non-empty text field altogether
- my $pwIdx = firstIdx { $_->{type} eq 'password' } @{$form->{fields}};
- my $idx = first { $form->{fields}->[$_]->{value} ne '' and
- ($form->{fields}->[$_]->{type} eq 'text' or $form->{fields}->[$_]->{type} eq 'email')
- } ($pwIdx-1 .. 0)
- if defined $pwIdx;
- $idx //= firstIdx { $_->{value} ne '' and ($_->{type} eq 'text' or $_->{type} eq 'email') } @{$form->{fields}};
- $id = $form->{fields}->[$idx]->{value} if defined $idx;
- while (1) {
- # ask for confirmation
- my $r = prompt 'Identity name?', $id;
- if ($r !~ /\A[^\P{Print}\/]+\z/) {
- myprintf \*STDERR, "Invalid identity: C<%s>", $r;
- }
- elsif (-e getIdentityFile "$uri/$r") {
- myprintf \*STDERR, "Identity C<%s> already exists", "$uri/$r";
- }
- else {
- $id = $r;
- last;
- }
- }
- }
-
- my $filename = getIdentityFile "$uri/$id";
- error "Identity C<%s> already exists", "$uri/$id" if -e $filename;
-
- my @passIdx = grepIdx { $_->{type} eq 'password' } @{$form->{fields}};
- my @dontsave;
- if ($#passIdx == 0) { # single password in the form
- if ($form->{fields}->[$passIdx[0]]->{value} eq '') {
- warning "Warning! Empty password for field C<%s>", $form->{fields}->[$passIdx[0]]->{name};
- exit 1 unless promptYN "Continue?";
- }
- }
- elsif ($#passIdx < 3) { # 2 or 3 passwords in the form
- my ($idx0, $idx1, $idx2) = map {defined $_ ? $passIdx[$_] : undef}
- guessPasswordPage(@{$form->{fields}}[@passIdx]);
- my ($pw0, $pw1, $pw2) = map {defined $_ ? $form->{fields}->[$_] : undef}
- ($idx0, $idx1, $idx2);
-
- if (defined $idx1 and defined $idx2) {
- # it can also be a password changing page when !defined
- # $pw0, but it doesn't matter here as all values are the
- # same
- print STDERR "Assuming a ".(defined $pw0 ? 'password changing' : 'signup')." page\n";
- if ($pw1->{value} eq '') { # generate a password for the two fields
- pwgen ($pw1, $pw2);
- $fill[$_] = $form->{fields}->[$_]->{value} foreach ($idx1, $idx2);
- }
-
- if (defined $pw0) {
- # keep only the first field, but use the second field's value
- $pw0->{value} = $pw1->{value};
- push @dontsave, $idx1, $idx2;
- } else {
- # keep only the first field
- push @dontsave, $idx2;
- }
-
- }
- }
- elsif ($#passIdx >= 3) {
- print STDERR "Assuming all ".scalar(@passIdx)." passwords are independent\n";
- foreach my $i (@passIdx) {
- next unless $form->{fields}->[$i]->{value} eq '';
- pwgen $form->{fields}->[$i];
- $fill[$i] = $form->{fields}->[$i]->{value};
- }
- }
-
- fill $formIdx, $form, @fill;
- sendCommand 'QUIT';
-
- undef @{$form->{fields}}[@dontsave] if @dontsave; # remove the field we don't want to save
- myprintf "Saving identity C<%s>", "$uri/$id";
- saveIdentityFile $form, $filename;
-}
-
-elsif ($command eq 'fill') {
- usage(1) unless $#ARGV == 0;
- my $id = shift;
- my $filename = getIdentityFile $id;
- error "No such identity C<%s>", $id unless -f $filename;
-
- my $uri = &connect($CONFIG{socket});
- error "Possible phishing attempt! (URI C<%s> doesn't match identity.) Aborting.", $uri
- unless $id =~ /\A\Q$uri\E(?:\/.*)\z/;
-
- # get the list of forms and load the known form from disk
- my @forms = getForms();
- my $myform = loadIdentityFile $filename;
- my $formIdx = findForm $myform, @forms;
- my $form = $forms[$formIdx];
- my @fill = map {undef} (0 .. $#{$form->{fields}});
-
- # map each field name to the list of its indices; this allows
- # multivalued names
- my %fields = groupByName @{$form->{fields}};
- my %myfields = groupByName @{$myform->{fields}};
- my $changed = 0;
-
- my @mypassIdx = grepIdx { $_->{type} eq 'password' } @{$myform->{fields}};
- my @passIdx = grepIdx { $_->{type} eq 'password' } @{$form->{fields}};
- if ($#mypassIdx == 0 and $#passIdx == 0 and
- $#{$myfields{$myform->{fields}->[$mypassIdx[0]]->{name}}} == 0 and
- $#{$fields{$form->{fields}->[$passIdx[0]]->{name}}} == 0) {
- # there is a single password on both the know form and that we
- # want to fill, and both field names are unique in these forms:
- # assume this is the password to be filled regardless of the
- # name
-
- my $mypass = $myform->{fields}->[$mypassIdx[0]];
- my $pass = $form->{fields}->[$passIdx[0]];
- delete $myfields{$mypass->{name}}; # don't process these names later
- delete $fields{$pass->{name}};
-
- if ($mypass->{name} ne $pass->{name}) { # use the new name
- myprintf "Renaming field C<%s> as C<%s>",
- $mypass->{name}, $pass->{name};
- $mypass->{name} = $pass->{name};
- $changed = 1;
- }
-
- if ($pass->{value} eq '') { # fill the password with the known value
- $fill[$passIdx[0]] = $mypass->{value};
- }
- elsif ($mypass->{value} ne $pass->{value}) { # update the password
- myprintf "Updating field C<%s> to C<%s> (former value: C<%s>)",
- $mypass->{name}, safeValue($pass), safeValue($mypass);
- $mypass->{value} = $pass->{value};
- $changed = 1;
- }
- }
- elsif ($#mypassIdx == 0 and $#passIdx > 0 and $#passIdx < 3) {
- # there is a single known password, but two or three fields to
- # fill: probably a password changing page
- my $mypass = $myform->{fields}->[$mypassIdx[0]];
- my ($idx0, $idx1, $idx2) = map {defined $_ ? $passIdx[$_] : undef}
- guessPasswordPage(@{$form->{fields}}[@passIdx]);
- my ($pw0, $pw1, $pw2) = map {defined $_ ? $form->{fields}->[$_] : undef}
- ($idx0, $idx1, $idx2);
-
- if (defined $pw1 and defined $pw2) {
- print STDERR "Assuming a password changing page\n";
- if ($pw1->{value} eq '') {
- pwgen ($pw1, $pw2);
- $fill[$_] = $form->{fields}->[$_]->{value} foreach ($idx1, $idx2);
- }
-
- # fill the first password field with the known value
- $fill[$idx0] = $mypass->{value} if defined $idx0 and $pw0->{value} eq '';
-
- if ($mypass->{value} ne $pw1->{value}) {
- # update the known password with the new value
- $mypass->{value} = $pw1->{value};
- $changed = 1;
- }
-
- # don't process these fields later
- &delete($mypassIdx[0], $myfields{$mypass->{name}});
- &delete($_, $fields{$form->{fields}->[$_]->{name}}) foreach grep defined, ($idx0, $idx1, $idx2);
- }
- }
-
- # walk through each names in both %myfields and %fields, and fill
- # the values in the order they are found
- foreach my $name (keys %myfields) {
- next unless exists $fields{$name};
- while (@{$myfields{$name}} and @{$fields{$name}}) {
- my $myidx = shift @{$myfields{$name}};
- my $idx = shift @{$fields{$name}};
- next unless defined $myidx and defined $idx; # was taken care of before
- if ($form->{fields}->[$idx]->{value} eq '' and $myform->{fields}->[$myidx]->{value} ne '') {
- # fill with the known value
- $fill[$idx] = $myform->{fields}->[$myidx]->{value};
- }
- elsif ($myform->{fields}->[$myidx]->{value} ne $form->{fields}->[$idx]->{value}) {
- # update the known value with that found in the page
- myprintf "Updating field C<%s> to C<%s> (former value: C<%s>)",
- $myform->{fields}->[$myidx]->{name},
- safeValue($form->{fields}->[$idx]),
- safeValue($myform->{fields}->[$myidx]);
- $myform->{fields}->[$myidx]->{value} = $form->{fields}->[$idx]->{value};
- $changed = 1;
- }
- }
- }
- # add the fields that were found in the page, but not in our form
- foreach my $name (keys %fields) {
- my @fieldIdx = grep defined, @{$fields{$name}};
- my $i;
- for ($i = $#fieldIdx; $i >= 0; $i--) {
- last unless $form->{fields}->[$i]->{value} eq '';
- }
- # don't store empty values (unless a later value is non-empty,
- # to preserve the order)
- @fieldIdx = @fieldIdx[(0 .. $i)] if $i >= 0;
- next unless @fieldIdx and $i >= 0;
- myprintf "Adding field C<%s>, value".($#fieldIdx > 0 ? '(s) ' : ' ').
- join(',', map {'C<%s>'} @fieldIdx),
- $name, map {safeValue $form->{fields}->[$_]} @fieldIdx;
- push @{$myform->{fields}}, @{$form->{fields}}[@fieldIdx];
- $changed = 1;
- }
- foreach my $name (keys %myfields) {
- my @fieldIdx = grep defined, @{$myfields{$name}};
- next unless @fieldIdx;
- myprintf "Deleting field C<%s>, value".($#fieldIdx > 0 ? '(s) ' : ' ').
- join(',', map {'C<%s>'} @fieldIdx),
- $name, map {safeValue $myform->{fields}->[$_]} @fieldIdx;
- undef $myform->{fields}->[$_] foreach @fieldIdx;
- $changed = 1;
- }
-
- fill $formIdx, $form, @fill;
- sendCommand 'QUIT';
-
- if ($changed) {
- my $r = promptYN "Save changes?", 0;
- saveIdentityFile ($myform, $filename) if $r;
- }
-}
-
-elsif ($command eq 'dump') {
- usage(1) unless $#ARGV == 0;
- my $id = shift;
- my $filename = getIdentityFile $id;
- error "No such identity C<%s>", $id unless -f $filename;
-
- my $form = loadIdentityFile $filename;
- $_->{value} = safeValue($_) foreach @{$form->{fields}}; # redact the passwords
-
- my $str = YAML::Tiny::Dump($form);
- print STDOUT (defined $LOCALE ? $LOCALE->encode($str) : $str)
-}
-
-elsif ($command eq 'edit') {
- usage(1) unless $#ARGV == 0;
- my $id = shift;
- my $filename = getIdentityFile $id;
- error "No such identity C<%s>", $id unless -f $filename;
- require 'File/Copy.pm';
- require 'File/Temp.pm';
-
- error "C<%s> is not set", '$EDITOR' unless defined $ENV{EDITOR};
- $ENV{EDITOR} =~ /\A(\p{Print}+)\z/ or error "Insecure C<%s>", "\$EDITOR";
- my $EDITOR = $1; # untaint $EDITOR
-
- my $fh = File::Temp->new(SUFFIX => '.yaml', UNLINK => 0, TMPDIR => 1);
- END { unlink $fh->filename if defined $fh; } # never leave cleartext lying around
- loadIdentityFile $filename, $fh;
-
- my $h = sha256_file $fh->filename;
- system $EDITOR, $fh->filename;
- error "C<%s> exited with value %d", $EDITOR, ($? >> 8) if $? and $? != -1;
-
- if ($h eq sha256_file $fh->filename) {
- print "No modification made\n";
- }
- else {
- myprintf "Saving user changes for identity C<%s>", $id;
- saveIdentityFile( $fh->filename, $filename);
- }
-}
-
-elsif ($command eq 'clip') {
- usage(1) unless $#ARGV == 0;
- my $id = shift;
- my $filename = getIdentityFile $id;
- error "No such identity C<%s>", $id unless -f $filename;
-
- my $form = loadIdentityFile $filename;
- my $pw = first { $_->{type} eq 'password' } @{$form->{fields}};
- error "No password found in C<%s>", $id unless defined $pw;
-
- my $pid = open my $fh, '|-', qw/xclip -loop 1 -selection clipboard/
- or error "Can't fork: %s", $!;
- print $fh encode_utf8($pw->{value});
- close $fh;
- waitpid $pid, 0;
- error "C<%s> exited with value %d", 'xclip', ($? >> 8) if $? and $? != -1;
- exit 0;
-}
-
-elsif ($command eq 'ls') {
- usage(1) if $#ARGV > 0;
- my $prefix = shift @ARGV;
- my @matches = complete $prefix // '', 1;
-
- if (!defined $prefix) {
- s/:\/\/.*// foreach @matches;
- } elsif ($prefix =~ /\A[A-Za-z0-9-]+:\/\/[^\P{Graph}:\/]+(?::\d+)?\/[^\P{Print}\/]+\z/) {
- @matches = grep /\A\Q$prefix\E\z/, @matches;
- } elsif ($prefix =~ /\A([A-Za-z0-9-]+:\/\/[^\P{Graph}\/]+)\/?\z/) {
- my $x = $1;
- @matches = grep defined, map { !s/\A\Q$x\E\/// ? undef : $_ } @matches;
- } elsif ($prefix =~ /\A([A-Za-z0-9-]+)(:\/{0,2})?\z/) {
- my $x = $1;
- @matches = grep defined, map { !s/\A\Q$x\E:\/\/// ? undef :
- !s/\/[^\P{Print}\/]+\z// ? undef : $_ } @matches;
- } else {
- @matches = ();
- }
- error "No such identity C<%s>", $prefix // '' unless @matches;
-
- my $delim = $CONFIG{zero} ? "\0" : "\n";
- my %matches = map {($_ => 1)} @matches;
- print $LOCALE->encode($_), $delim foreach sort keys %matches;
-}
-
-else {
- myprintf "Unknown command: C<%s>", $command;
- usage(1);
-}