examples/password-manager.p6

   1 #!/usr/bin/pugs
   2
   3 =begin pod
   4
   5 =NAME Perl6 Password Manager
   6 =AUTHOR Ryan "rhr" Richter <ryan@tau.solarneutrino.net>
   7
   8 =for DESCRIPTION
   9 This program will generate, store, and retrieve passwords.
  10 It uses B<xclip> to transfer passwords through the X11 clipboard,
  11 so in normal use you will never even need to see your (unique,
  12 randomly generated) passwords.  Although it uses a terminal
  13 L<ReadLine|perl5:Term::ReadLine> interface, it is designed
  14 to be used mostly with the mouse, via cut-n-paste.
  15 It can even generate random Unicode passwords!
  16
  17 =begin SYNOPSIS
  18 =begin input
  19 T<<> >>.h                                                       I<# display usage information>
  20 T<<> >>.n       R<account-name>         R       R<username>     I<# add a new account with a random password>
  21 T<<> >>/R<account>                                              I<# search database for matching account names>
  22 T<<> >>R<account>                                               I<# xclip password for R<account> and exit>
  23 =end input
  24 This last command ignores leading and trailing whitespace,
  25 so that you can sloppily select the account name from the
  26 output of the C</> command.
  27 =end SYNOPSIS
  28
  29 =begin USAGE
  30                 <account>       xclip account password and exit
  31                 /<regex>        search accounts
  32                 .n              new account
  33                 .d              delete account
  34                 .p              print account password
  35                 .x              xclip account password
  36                 .c              commit changes
  37                 .r              xclip random password
  38                 .R              print random password
  39                 .a              switch to alphanum
  40                 .A              switch to all printable
  41                 .u              switch to unicode
  42                 .U              switch to ASCII
  43                 .l              change random password length
  44                 .h              help
  45 =end USAGE
  46
  47 =end pod
  48
  49 use perl5:Term::ReadLine;
  50
  51 regex alphanum  { ^ <!before \t><alnum> $ }
  52 regex printable { ^ <!before \t><print> $ }
  53 my Regex $pwchar := &alphanum;
  54 my Range $ascii = 0..127;
  55 my Range $unicode = 0..0x10ffff;
  56 my Range $charset := $ascii;
  57 my Int $len = 8;
  58 my Bool $changed = False;
  59 my Hash of Str %pw;
  60
  61 sub help(--> Void) { warn $=USAGE; }
  62
  63 my Code &abort := -> Str $err { warn "$err\n"; return; }
  64
  65 sub search(Str $pat --> Void) {
  66         for %pw.keys -> $k { say %pw{$k}<user>, "\t", $k if $k ~~ /<$pat>/ }
  67 }
  68
  69 sub mk(Str $acct, Str $pass is copy, Str $user --> Void) {
  70         $changed = True;
  71         $pass = randpass if $pass eq 'R';
  72         %pw{$acct}<pass user> = $pass, $user;
  73 }
  74
  75 sub del(Str $acct --> Void) {
  76         abort "No account $acct" unless %pw{$acct}.:exists;
  77         $changed = True;
  78         %pw{$acct}.:delete;
  79 }
  80
  81 sub pr(Str $acct --> Void) {
  82         abort "No account $acct" unless %pw{$acct}.:exists;
  83         say %pw{$acct}<user pass>.join("\t");
  84 }
  85
  86 sub wxclip(Str $acct --> Void) {
  87         abort "No account $acct" unless %pw{$acct}.:exists;
  88         xclip %pw{$acct}<pass>;
  89 }
  90
  91 sub xclip(Str $s --> Void) {
  92         my IO $xclip = Pipe.to: 'xclip' orelse abort 'No xclip - use .p';
  93         $xclip.print: $s;
  94         $xclip.close;
  95 }
  96
  97 sub sx(Str $s --> Void) {
  98         my Str $pw = %pw{$s}<pass> //
  99                 first Str, (%pw{$_}<pass> if /$s/ for %pw.keys)
 100                 orelse abort "Couldn't find account $s";
 101         xclip $pw;
 102         cmt if $changed;
 103         sleep 10;
 104         xclip '';
 105         exit;
 106 }
 107
 108 sub randpass(--> Str) {
 109         my Str $c;
 110         # < TimToady> and 9 developers out of 10 will shoot you if you use that construct. :)
 111         # < TimToady> at least, if you use it uncommented...
 112         my Str @password := gather while @password < $len {
 113                 if ($c = $charset.pick.chr) ~~ $pwchar { take $c }
 114         }
 115         return [~] @password;
 116 }
 117
 118 sub cmt(--> Void) {
 119         unlink 'pwd.gpg.old' orelse abort "Couldn't unlink: $!";
 120         rename 'pwd.gpg', 'pwd.gpg.old' orelse abort "Couldn't rename: $!";
 121         my IO $pwd = Pipe.to: 'gpg --symmetric --force-mdc --cipher-algo AES256 --output pwd.gpg'
 122                 orelse abort "Couldn't encrypt: $!";
 123         for %pw.keys -> $k { $pwd.say: $k, "\t", %pw{$k}<pass user>.join("\t") }
 124         if $pwd.close {
 125                 $changed = False;
 126         } else {
 127                 abort "Couldn't write pwd: $!";
 128         }
 129 }
 130
 131 regex cmd {
 132         ^^
 133         [ '/' $<pat> = [ \N* ] { search $<pat> }
 134         | \s* <!before '.'> $<acct> = [ \T+? ] \s* $$ { sx $<acct> }
 135         | '.'   [ n     [ \t $<acct> = [ \T+ ] \t $<pass> = [ \T+ ] \t $<user> = [ \T+ ] $$
 136                                 { mk $<acct>, $<pass>, $<user> }
 137                         | { warn ".n [tab] account [tab] password [tab] username\n" } <commit> <fail>
 138                         ]
 139                 | d     [ \s+ $<acct> = [ \T+? ] \s* $$ { del $<acct> }
 140                         | { warn ".d account\n" } <commit> <fail>
 141                         ]
 142                 | p     [ \s+ $<acct> = [ \T+? ] \s* $$ { pr $<acct> }
 143                         | { warn ".p account\n" } <commit> <fail>
 144                         ]
 145                 | x     [ \s+ $<acct> = [ \T+? ] \s* $$ { wxclip $<acct> }
 146                         | { warn ".x account\n" } <commit> <fail>
 147                         ]
 148                 | l     [ \s+ $<len> = [ \d+ ] \s* $$ { $len = $<len> }
 149                         | { warn ".l length\nlength is $len\n" } <commit> <fail>
 150                         ]
 151                 | c { cmt }
 152                 | r { xclip randpass }
 153                 | R { say randpass }
 154                 | a { $pwchar := &alphanum }
 155                 | A { $pwchar := &printable }
 156                 | u { $charset := $unicode }
 157                 | u { $charset := $ascii }
 158                 | h { help }
 159                 | { warn "Bad command\n"; help; } <commit> <fail>
 160                 ]
 161         ]
 162 }
 163
 164 regex pwent {
 165         ^^ $<acct> = [ \T+ ] \t $<pass> = [ \T+ ] \t $<user> = [ \T+ ] $$
 166 }
 167
 168 %*ENV<PATH> = '/bin:/usr/bin:/usr/bin/X11';
 169 umask 0o77;
 170 chdir "$+HOME/pw" orelse die "Couldn't cd: $!";
 171 my IO $pwd = Pipe.from: 'gpg --output - --decrypt pwd.gpg' orelse die "Couldn't decrypt: $!";
 172 for =$pwd {
 173         /<pwent>/ or die 'Malformed line ', $pwd.linenum, ": $_\n";
 174         %pw{$<pwent><acct>}<pass user> = $<pwent><pass user>;
 175 }
 176 $pwd.close;
 177
 178 my $term = new Term::ReadLine: 'pw';
 179 my $attribs = $term.Attribs;
 180 $attribs<completion_entry_function> = $attribs<list_completion_function>;
 181 $attribs<completion_word> = %pw.keys;
 182
 183 while defined $_ = $term.readline('> ')  {
 184         /<cmd>/;
 185         NEXT { $attribs<completion_word> = %pw.keys; }
 186 }
 187 cmt if $changed;