scripts/cap_sasl_xchat.pl

   1 # based on cap_sasl.pl by Michael Tharp and Jilles Tjoelker
   2 # ported to X-Chat 2 by Lian Wan Situ
   3 #
   4 # license: GNU General Public License
   5 # Latest version at http://lwsitu.com/xchat/cap_sasl_xchat.pl
   6
   7 ### Configuration #######
   8 # How long to wait between authentication messages
   9 my $AUTHENTICATION_TIMEOUT = 15;
  10 ### End Configuration ###
  11
  12 use strict;
  13 use warnings;
  14 use Xchat qw(:all);
  15
  16 use MIME::Base64;
  17
  18 register(
  19         "CAP SASL",
  20         "1.0107",
  21         "Implements PLAIN SASL authentication mechanism for use with charybdis ircds, and enables CAP MULTI-PREFIX IDENTIFY-MSG",
  22         \&cmd_sasl_save,
  23 );
  24
  25
  26 my %timeouts;
  27 my %processing_cap;
  28 hook_print( "Connected", \&event_connected );
  29
  30 hook_server( 'CAP', \&event_cap);
  31 hook_server( 'AUTHENTICATE', \&event_authenticate);
  32 hook_server( '900', sub {
  33         cap_out( substr( $_[1][5], 1, ) );
  34         timeout_remove();
  35         return EAT_XCHAT;
  36 });
  37 hook_server( '903', \&event_saslend);
  38 hook_server( '904', \&event_saslend);
  39 hook_server( '905', \&event_saslend);
  40 hook_server( '906', \&event_saslend);
  41 hook_server( '907', \&event_saslend);
  42
  43 hook_command( 'SASL', \&cmd_sasl, { help_text => cmd_sasl_help_text() } );
  44
  45 my $AUTH_TIMEOUT;
  46 if( $AUTHENTICATION_TIMEOUT ) {
  47         $AUTH_TIMEOUT = $AUTHENTICATION_TIMEOUT * 1_000;
  48 } else {
  49         $AUTH_TIMEOUT = 5_000;
  50 }
  51
  52 my %sasl_auth = ();
  53 my %mech = ();
  54
  55 sub send_raw {
  56         commandf( "QUOTE %s", $_[0] );
  57 }
  58
  59 sub cap {
  60         send_raw( "CAP " . $_[0] );
  61 }
  62
  63 sub cap_end{
  64         delete $processing_cap{ get_info "id" };
  65         cap( "END" );
  66 }
  67
  68 sub connected {
  69         my $flags = context_info->{flags};
  70         return  $flags & 1 || $flags & 2;
  71 }
  72
  73 sub get_config_file {
  74         return get_info( "xchatdirfs" )."/sasl.auth";
  75 }
  76
  77 sub network_name {
  78         return lc get_info( "network" );
  79 }
  80
  81 # switch to the server tab for the current connection
  82 # return true if successful
  83 sub switch_to_server {
  84         my $connection_id = shift;
  85
  86         for my $tab( get_list "channels") {
  87                 if( $tab->{id} == $connection_id && $tab->{type} == 1 ) {
  88                         return set_context( $tab->{context} );
  89                 }
  90         }
  91
  92         return;
  93 }
  94
  95 sub cap_out {
  96         my $output = shift;
  97         switch_to_server( get_info "id" );
  98
  99         prnt( $output );
 100 }
 101
 102 sub event_connected {
 103         cap( "LS" );
 104
 105         # reset everything for new connection
 106         timeout_remove();
 107         delete $processing_cap{ get_info( "id" ) };
 108         return EAT_NONE;
 109 }
 110
 111 sub event_cap {
 112         my $tosend = '';
 113         my $subcmd = uc $_[0][3];
 114         my $caps = $_[1][4];
 115         $caps =~ s/^://;
 116
 117         if ($subcmd eq 'LS') {
 118                 my $id = get_info "id";
 119                 if( $processing_cap{ $id } ) {
 120                         return EAT_XCHAT;
 121                 }
 122                 $processing_cap{ $id } = 1;
 123                 $tosend .= ' multi-prefix' if $caps =~ /\bmulti-prefix\b/xi;
 124
 125                 if( $caps =~ /\bsasl\b/xi ) {
 126                         if( defined($sasl_auth{network_name()}) ) {
 127                                 $tosend .= ' sasl';
 128                         } else {
 129                                 cap_out( "\cC05SASL is supported but there is no authentication information set for this network(\cC02".network_name()."\cC05)." );
 130                         }
 131                 }
 132
 133                 $tosend .= ' identify-msg' if $caps =~ /\bidentify-msg\b/;
 134                 $tosend =~ s/^ //;
 135                 cap_out( "CLICAP: supported by server: $caps" );
 136
 137                 if ( connected() ) {
 138                         if ($tosend eq '') {
 139                                 cap_end();
 140                         } else {
 141                                 cap_out( "CLICAP: requesting: $tosend" );
 142                                 cap( "REQ :$tosend" );
 143                         }
 144                 }
 145         } elsif( $subcmd eq 'ACK' ) {
 146                 cap_out( "CLICAP: now enabled: $caps" );
 147
 148                 if( $caps =~ /\bidentify-msg\b/i ) {
 149                         commandf( "RECV %s 290 %s :IDENTIFY-MSG",
 150                                 $_[0][0], get_info( "nick" ) );
 151                 }
 152
 153                 if( $caps =~ /\bsasl\b/i ) {
 154                         $sasl_auth{network_name()}{buffer} = '';
 155                         if($mech{$sasl_auth{network_name()}{mech}}) {
 156                                 send_raw( "AUTHENTICATE "
 157                                         . $sasl_auth{network_name()}{mech}
 158                                 );
 159
 160                                 timeout_start();
 161                         } else {
 162                                 cap_out( 'SASL: attempted to start unknown mechanism "%s"',
 163                                         $sasl_auth{network_name()}{mech}
 164                                 );
 165                         }
 166                 } elsif( connected() ) {
 167                         cap_end;
 168                 }
 169         } elsif( $subcmd eq 'NAK' ) {
 170                 cap_out( "CLICAP: refused:$caps" );
 171                 if ( connected() ) {
 172                         cap_end;
 173                 }
 174         } elsif( $subcmd eq 'LIST' ) {
 175                 cap_out( "CLICAP: currently enabled:$caps" );
 176         }
 177
 178         return EAT_XCHAT;
 179 }
 180
 181 sub event_authenticate {
 182         my $args = $_[1][1] || "";
 183
 184         my $sasl = $sasl_auth{network_name()};
 185         return EAT_XCHAT unless $sasl && $mech{$sasl->{mech}};
 186
 187         $sasl->{buffer} .= $args;
 188         timeout_reset();
 189         return EAT_XCHAT if length($args) == 400;
 190
 191         my $data = $sasl->{buffer} eq '+' ? '' : decode_base64($sasl->{buffer});
 192         my $out = $mech{$sasl->{mech}}($sasl, $data);
 193         $out = '' unless defined $out;
 194         $out = $out eq '' ? '+' : encode_base64($out, '');
 195
 196         while(length $out >= 400) {
 197                 my $subout = substr($out, 0, 400, '');
 198                 send_raw("AUTHENTICATE $subout");
 199         }
 200         if(length $out) {
 201                 send_raw("AUTHENTICATE $out");
 202         }else{ # Last piece was exactly 400 bytes, we have to send some padding to indicate we're done
 203                 send_raw("AUTHENTICATE +");
 204         }
 205
 206         $sasl->{buffer} = '';
 207         return EAT_XCHAT;
 208 }
 209
 210 sub event_saslend {
 211         my $data = $_[1][1];
 212         $data =~ s/^\S+ :?//;
 213
 214         if (connected()) {
 215                 cap_end();
 216         }
 217
 218         return EAT_XCHAT;
 219 }
 220
 221 sub timeout_start {
 222         $timeouts{ context_info->{id} }
 223                 = hook_timer( $AUTH_TIMEOUT, sub { timeout(); return REMOVE; } );
 224 }
 225
 226 sub timeout_remove {
 227         unhook( $timeouts{ context_info->{id} } ) if $timeouts{ context_info->{id} };
 228 }
 229
 230 sub timeout_reset {
 231         timeout_remove();
 232         timeout_start();
 233 }
 234
 235 sub timeout {
 236         my $id = get_info "id";
 237         delete $processing_cap{ $id };
 238
 239         if( connected() ) {
 240                 cap_out( "SASL: authentication timed out" );
 241                 cap_end();
 242         }
 243 }
 244
 245 my %sasl_actions = (
 246         load => \&cmd_sasl_load,
 247         save => \&cmd_sasl_save,
 248         set => \&cmd_sasl_set,
 249         delete => \&cmd_sasl_delete,
 250         show => \&cmd_sasl_show,
 251         help => \&cmd_sasl_help,
 252         mechanisms => \&cmd_sasl_mechanisms,
 253 );
 254
 255 sub cmd_sasl {
 256         my $action = $_[0][1];
 257
 258         if( $action and my $action_code = $sasl_actions{ $action } ) {
 259                 $action_code->( @_ );
 260         } else {
 261                 $sasl_actions{ help }->( @_ );
 262         }
 263
 264         return EAT_XCHAT;
 265 }
 266
 267 sub cmd_sasl_help_text {
 268         return <<"HELP_TEXT";
 269 SASL [action] [action paramters]
 270     actions:
 271     load        reload SASL information from disk
 272     save        save the current SASL information to disk
 273     set         set the SASL information for a particular network
 274         set <net> <user> <passord or keyfile> <mechanism>
 275     delete      delete the SASL information for a particular network
 276         delete <net>
 277
 278     show        display which networks have SASL information set
 279     mechanisms  display supported mechanisms
 280
 281     help        show help message
 282 HELP_TEXT
 283
 284 }
 285
 286 sub cmd_sasl_set {
 287         my $data = $_[1][2] || "";
 288
 289         if (my($net, $u, $p, $m) = $data =~ /^(\S+) (\S+) (\S+) (\S+)$/) {
 290                 if($mech{uc $m}) {
 291                         $net = lc $net;
 292                         $sasl_auth{$net}{user} = $u;
 293                         $sasl_auth{$net}{password} = $p;
 294                         $sasl_auth{$net}{mech} = uc $m;
 295                         prnt( "SASL: added $net: [$m] $sasl_auth{$net}{user} *" );
 296                 } else {
 297                         prnt( "SASL: unknown mechanism $m" );
 298                 }
 299         } elsif( $data =~ /^(\S+)$/) {
 300                 $net = lc $1;
 301                 if (defined($sasl_auth{$net})) {
 302                         delete $sasl_auth{$net};
 303                         prnt( "SASL: deleted $net" );
 304                 } else {
 305                         prnt( "SASL: no entry for $net" );
 306                 }
 307         } else {
 308                 prnt( "SASL: usage: /sasl set <net> <user> <password or keyfile> <mechanism>" );
 309         }
 310 }
 311
 312 sub cmd_sasl_delete {
 313         my $net = $_[0][2];
 314         prnt "Net: $net";
 315
 316         delete $sasl_auth{$net};
 317 }
 318
 319 sub cmd_sasl_show {
 320         foreach my $net (keys %sasl_auth) {
 321                 prnt( "SASL: $net: [$sasl_auth{$net}{mech}] $sasl_auth{$net}{user} *" );
 322         }
 323         prnt("SASL: no networks defined") if !%sasl_auth;
 324 }
 325
 326 sub cmd_sasl_save {
 327         my $file = get_config_file();
 328
 329         if( open my $fh, ">", $file ) {
 330
 331                 foreach my $net (keys %sasl_auth) {
 332                         printf $fh ("%s\t%s\t%s\t%s\n", lc $net, $sasl_auth{$net}{user}, $sasl_auth{$net}{password}, $sasl_auth{$net}{mech});
 333                 }
 334
 335                 prnt( "SASL: auth saved to $file" );
 336         } else {
 337                 prnt qq{Couldn't open '$file' to save auth data: $!};
 338         }
 339 }
 340
 341 sub cmd_sasl_load {
 342         #my ($data, $server, $item) = @_;
 343         my $file = get_config_file();
 344
 345         open FILE, "< $file" or return;
 346         %sasl_auth = ();
 347         while (<FILE>) {
 348                 chomp;
 349                 my ($net, $u, $p, $m) = split (/\t/, $_, 4);
 350                 $m ||= "PLAIN";
 351                 $net = lc $net;
 352                 if($mech{uc $m}) {
 353                         $sasl_auth{$net}{user} = $u;
 354                         $sasl_auth{$net}{password} = $p;
 355                         $sasl_auth{$net}{mech} = uc $m;
 356                 }else{
 357                         prnt( "SASL: unknown mechanism $m" );
 358                 }
 359         }
 360         close FILE;
 361         prnt( "SASL: auth loaded from $file" );
 362 }
 363
 364 sub cmd_sasl_mechanisms {
 365         prnt( "SASL: mechanisms supported: " . join(" ", keys %mech) );
 366 }
 367
 368 sub cmd_sasl_help {
 369         prnt( cmd_sasl_help_text() );
 370 }
 371
 372 $mech{PLAIN} = sub {
 373         my($sasl, $data) = @_;
 374         my $u = $sasl->{user};
 375         my $p = $sasl->{password};
 376
 377         join("\0", $u, $u, $p);
 378 };
 379
 380 # binary to BigInt
 381 sub bin2bi {
 382         return Crypt::OpenSSL::Bignum
 383                 ->new_from_bin(shift)
 384                 ->to_decimal;
 385 }
 386
 387 # BigInt to binary
 388 sub bi2bin {
 389         return Crypt::OpenSSL::Bignum
 390                 ->new_from_decimal((shift)->bstr)
 391                 ->to_bin;
 392 }
 393
 394 eval {
 395         require Crypt::OpenSSL::Bignum;
 396         require Crypt::DH;
 397         require Crypt::Blowfish;
 398         require Math::BigInt;
 399
 400         $mech{'DH-BLOWFISH'} = sub {
 401                 my($sasl, $data) = @_;
 402                 my $u = $sasl->{user};
 403                 my $pass = $sasl->{password};
 404
 405                 # Generate private key and compute secret key
 406                 my($p, $g, $y) = unpack("(n/a*)3", $data);
 407                 my $dh = Crypt::DH->new(p => bin2bi($p), g => bin2bi($g));
 408                 $dh->generate_keys;
 409
 410                 my $secret = bi2bin($dh->compute_secret(bin2bi($y)));
 411                 my $pubkey = bi2bin($dh->pub_key);
 412
 413                 # Pad the password to the nearest multiple of blocksize and encrypt
 414                 $pass .= "\0";
 415                 $pass .= chr(rand(256)) while length($pass) % 8;
 416
 417                 my $cipher = Crypt::Blowfish->new($secret);
 418                 my $crypted = '';
 419                 while(length $pass) {
 420                         my $clear = substr($pass, 0, 8, '');
 421                         $crypted .= $cipher->encrypt($clear);
 422                 }
 423
 424                 pack("n/a*Z*a*", $pubkey, $u, $crypted);
 425         };
 426 };
 427
 428 cmd_sasl_load();
 429
 430 # vim: ts=4