#!/usr/bin/perl -T # IceVault - An external password manager for firefox # Copyright © 2015 Guilhem Moulin # # 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 . 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, @GPG); 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; } sub mysystem(@) { system {$_[0]} @_; error "C<%s> exited with value %d", $_[0], ($? >> 8) if $? and $? != -1; } # 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 and validate the given configuration file sub loadConfig() { my $XDG_CONFIG_HOME = $ENV{XDG_CONFIG_HOME} // "$ENV{HOME}/.config"; my $XDG_DATA_HOME = $ENV{XDG_DATA_HOME} // "$ENV{HOME}/.local/share"; # load config my $configFile = "$XDG_CONFIG_HOME/icevault"; error "Missing configuration file C<%s>", $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 /^([-\@a-zA-Z0-9.]+)(?:\s*=\s*)(\p{Print}+)/ or error "Can't parse config line: C<%s>", $_; $CONFIG{$1} //= $2; } close $CONFIG; # set config defaults and validate $CONFIG{store} //= 'icevault'; $CONFIG{store} =~ s#\A~/#$ENV{HOME}#; $CONFIG{store} = "$XDG_DATA_HOME/$CONFIG{store}" unless $CONFIG{store} =~ /\A\//; $CONFIG{store} =~ /\A(\/\p{Print}+)\z/ or error "Insecure C<%s>", $CONFIG{store}; $CONFIG{store} = $1; # untaint $CONFIG{store} $CONFIG{template} //= '%s/%h/%i.gpg'; error "C<%s> must contain %%s, %%h and %%i placeholders", 'template' unless $CONFIG{template} =~ /%s/ and $CONFIG{template} =~ /%h/ and $CONFIG{template} =~ /%i/; $CONFIG{socket} //= 'socket'; $CONFIG{socket} =~ s#\A~/#$ENV{HOME}#; error "Missing keyid in configuration file" unless defined $CONFIG{keyid}; $CONFIG{keyid} = [ map { /^((?:0x)?\p{AHex}{16}|\p{AHex}{40})$/ or error "C<%s> is not a 64-bits key ID or fingerprint", $_; $1 } split /,/, $CONFIG{keyid} ]; $CONFIG{'max-password-length'} //= 32; error "C<%s> must be a positive integer", 'max-password-length' unless $CONFIG{'max-password-length'} =~ /\A\d+\z/ and $CONFIG{'max-password-length'} > 0; $CONFIG{pwgen} //= 'pwgen -s -cyn %d'; $CONFIG{pwgen} =~ s#\A~/#$ENV{HOME}#; error "Insecure C<%s>", $CONFIG{pwgen} unless $CONFIG{pwgen} =~ /\A([-_\@a-zA-Z0-9\.%\/= ]+)\z/; $CONFIG{pwgen} = $1; $CONFIG{gpg} //= 'gpg'; $CONFIG{gpg} =~ s#\A~/#$ENV{HOME}#; error "Insecure C<%s>", $CONFIG{gpg} unless $CONFIG{gpg} =~ /\A([-_\@a-zA-Z0-9\.%\/= ]+)\z/; $CONFIG{gpg} = $1; @GPG = split / /, $CONFIG{gpg}; } # 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}; $sockname =~ /\A(\/\p{Print}+)\z/ or error "Insecure C<%s>", $sockname; # untaint $sockname $sockname = $1; 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(); } # Glob over all form templates. Note that the output needs to be # $LOCALE-decode'ed. sub myglob(;$$$) { my ($s, $h, $i) = @_; my $store = $CONFIG{store}; my $template = $CONFIG{template}; require 'File/Glob.pm'; s/([\\\[\]\{\}\*\?\~])/\\$1/g foreach ($store, $template); $template =~ s{\%(.)}{ $1 eq '%' ? '%' : $1 eq 's' ? $s // '*' : $1 eq 'h' ? $h // '*' : $1 eq 'i' ? $i // '*' : die "Invalid placeholder %$1" }ge; my $glob = "$store/$template"; myprintf \*STDERR, "Using glob pattern C<%s>", $glob if $CONFIG{debug}; return File::Glob::bsd_glob($glob); } # 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; 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; # construct regexp to extract the URI compontents of the matching URIs my ($ps, $ph, $pi) = ($s, $h, $i); $ps = defined $h ? qr/(?\Q$s\E)/ : (defined $s and $s ne '') ? qr/(?\Q$s\E[A-Za-z0-9-]*)/ : qr/(?[A-Za-z0-9-]+)/; $ph = defined $i ? qr/(?\Q$h\E)/ : (defined $h and $h ne '') ? qr/(?\Q$h\E[^\P{Graph}\/]*)/ : qr/(?[^\P{Graph}\/]+)/; $pi = (defined $i and $i ne '') ? qr/(?\Q$i\E[^\P{Print}\/]*)/ : qr/(?[^\P{Print}\/]+)/; my $store = $LOCALE->encode($CONFIG{store}); my $template = $LOCALE->encode($CONFIG{template}); $template =~ s/(\%.)([^\%]*)\z/$1.quotemeta($2)/e; $template =~ 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; my $pattern = qr/\A\Q$store\/\E$template\z/; myprintf \*STDERR, "Using regexp C<%s>", "$pattern" if $CONFIG{debug}; my @matches; foreach my $filename (myglob($gs, $gh, $gi)) { next unless -f $filename; $LOCALE->decode($filename) =~ $pattern or die "$filename doesn't match $pattern"; 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 $template = $LOCALE->encode($CONFIG{template}); $template =~ s{\%(.)}{ $1 eq '%' ? '%' : $1 eq 's' ? $s : $1 eq 'h' ? $h : $1 eq 'i' ? $i : die "Invalid placeholder %$1" }ge; return "$CONFIG{store}/$template"; } # Decrypt the given identity file. In scalar context, return the # YAML-parsed form; in void context, must be given a file handle (closed # afterwards) where to dump the (unparsed) decrypted content. 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) , @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", $GPG[0], ($? >> 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; } # Encrypt a form into the given filename. If $form is a HASH # reference, its YAML-formatted (and UTF8-encoded) content is encrypted; # if $form is a GLOB reference, the file handle is duped, given as input # to gpg(1), and closed afterwards. 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'; if (ref $form eq 'HASH') { require 'YAML/Tiny.pm'; # XXX use Tiny::YAML instead? $form->{fields} = [ grep defined, @{$form->{fields}} ]; # remove undefined fields $form = encode_utf8(YAML::Tiny::Dump($form)); # dump the form as UTF8 } # don't encrypt directly into the destination file so we don't # end up with a messed up file if something goes wrong my $infh = "<&".fileno($form) if ref $form eq 'GLOB'; my $outfh = File::Temp->new(SUFFIX => '.gpg', UNLINK => 0, TMPDIR => 1) or die; my $pid = IPC::Open2::open2( ">&".$outfh->fileno, $infh , @GPG, qw/-o - --no-encrypt-to/ , (map {('--recipient', $_)} @{$CONFIG{keyid}}) , '--encrypt' ) or error "Can't fork: %s", $!; print $infh $form unless ref $form; close $infh; waitpid $pid, 0; error "C<%s> exited with value %d", $GPG[0], ($? >> 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 unless (File::Copy::move($outfh->filename, $filename)) { my $r = $!; unlink $outfh->filename or error "Can't unlink C<%s>: %s", $outfh->filename, $!; error "Can't move C<%s> to C<%s>: %s", $outfh->filename, $filename, $r; } # 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 = ; 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 = ; 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; } ####################################################################### usage(1) unless @ARGV; @ARGV = map { $LOCALE->decode($_) } @ARGV; my $confFilename = ($ENV{XDG_CONFIG_HOME} // "$ENV{HOME}/.data") . "/icevault"; GetOptions(\%CONFIG, qw/debug show-passwords|p socket|s=s help|? zero|0/) or usage(1); usage(0) if $CONFIG{help}; # Load configuration 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/Temp.pm'; error "C<%s> is not set", '$EDITOR' unless defined $ENV{EDITOR}; my $EDITOR = $ENV{EDITOR} // 'editor'; $EDITOR =~ /\A(\p{Print}+)\z/ or error "Insecure C<%s>", "\$EDITOR"; $EDITOR = $1; # untaint $EDITOR my $fh = File::Temp->new(SUFFIX => '.yaml', UNLINK => 0, TMPDIR => 1) or die; END { unlink $fh->filename if defined $fh; } # never leave cleartext lying around loadIdentityFile $filename, $fh; my $h = sha256_file $fh->filename; while (1) { mysystem $EDITOR, $fh->filename; error "C<%s> exited with value %d", $EDITOR, ($? >> 8) if $? and $? != -1; my $h2 = sha256_file $fh->filename; my $fh2; unless ($h eq $h2) { require 'YAML/Tiny.pm'; # XXX use Tiny::YAML instead? eval { my $str = YAML::Tiny::LoadFile($fh->filename) }; if ($@ eq '') { open $fh2, '<', $fh->filename or error "Can't open C<%s>: %s", $fh->filename, $!; } else { print STDERR $@; my $r = promptYN "Not a valid YAML file! Reedit?", 1; next if $r; } } unlink $fh->filename or error "Can't unlink C<%s>: %s", $fh->filename, $!; if ($h eq $h2) { print "No modification made\n"; } elsif (defined $fh2) { myprintf "Saving user changes for identity C<%s>", $id; saveIdentityFile($fh2, $filename); # use the FH we opened before unlinking } else { print "Aborting\n"; exit 1; } last; } } 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); }