Annotation of loncom/LondConnection.pm, revision 1.56
1.2 albertel 1: # This module defines and implements a class that represents
2: # a connection to a lond daemon.
3: #
1.56 ! raeburn 4: # $Id: LondConnection.pm,v 1.55 2017/10/20 20:20:21 raeburn Exp $
1.2 albertel 5: #
6: # Copyright Michigan State University Board of Trustees
7: #
8: # This file is part of the LearningOnline Network with CAPA (LON-CAPA).
9: #
10: # LON-CAPA is free software; you can redistribute it and/or modify
11: # it under the terms of the GNU General Public License as published by
12: # the Free Software Foundation; either version 2 of the License, or
13: # (at your option) any later version.
14: #
15: # LON-CAPA is distributed in the hope that it will be useful,
16: # but WITHOUT ANY WARRANTY; without even the implied warranty of
17: # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
18: # GNU General Public License for more details.
19: #
20: # You should have received a copy of the GNU General Public License
21: # along with LON-CAPA; if not, write to the Free Software
22: # Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
23: #
24: # /home/httpd/html/adm/gpl.txt
25: #
26: # http://www.lon-capa.org/
1.1 foxr 27: #
1.14 foxr 28:
1.1 foxr 29: package LondConnection;
30:
1.10 foxr 31: use strict;
1.1 foxr 32: use IO::Socket;
33: use IO::Socket::INET;
34: use IO::Handle;
35: use IO::File;
36: use Fcntl;
37: use POSIX;
38: use Crypt::IDEA;
1.31 foxr 39: use LONCAPA::lonlocal;
40: use LONCAPA::lonssl;
1.14 foxr 41:
1.1 foxr 42:
1.32 foxr 43: my $DebugLevel=0;
1.12 foxr 44: my %perlvar;
1.54 raeburn 45: my %secureconf;
1.56 ! raeburn 46: my %badcerts;
1.54 raeburn 47: my %hosttypes;
1.31 foxr 48: my $InsecureOk;
1.1 foxr 49:
1.14 foxr 50: #
1.16 foxr 51: # Set debugging level
52: #
53: sub SetDebug {
54: $DebugLevel = shift;
55: }
56:
57: #
1.14 foxr 58: # The config read is done in this way to support the read of
59: # the non-default configuration file in the
60: # event we are being used outside of loncapa.
61: #
62:
63: my $ConfigRead = 0;
64:
1.1 foxr 65: # Read the configuration file for apache to get the perl
1.31 foxr 66: # variables set.
1.1 foxr 67:
1.12 foxr 68: sub ReadConfig {
1.31 foxr 69: Debug(8, "ReadConfig called");
70:
1.14 foxr 71: my $perlvarref = read_conf('loncapa.conf');
1.12 foxr 72: %perlvar = %{$perlvarref};
1.17 foxr 73: $ConfigRead = 1;
1.54 raeburn 74:
1.31 foxr 75: $InsecureOk = $perlvar{loncAllowInsecure};
1.54 raeburn 76:
77: unless (lonssl::Read_Connect_Config(\%secureconf,\%perlvar) eq 'ok') {
78: Debug(1,"Failed to retrieve secureconf hash.\n");
79: }
80: unless (lonssl::Read_Host_Types(\%hosttypes,\%perlvar) eq 'ok') {
81: Debug(1,"Failed to retrieve hosttypes hash.\n");
82: }
1.56 ! raeburn 83: undef(%badcerts);
1.54 raeburn 84: }
85:
86: sub ResetReadConfig {
87: $ConfigRead = 0;
1.15 foxr 88: }
1.1 foxr 89:
90: sub Debug {
1.30 foxr 91:
92: my ($level, $message) = @_;
93:
1.1 foxr 94: if ($level < $DebugLevel) {
1.31 foxr 95: print STDERR ($message."\n");
1.1 foxr 96: }
97: }
1.3 albertel 98:
99: =pod
100:
101: =head2 Dump
102:
1.12 foxr 103: Dump the internal state of the object: For debugging purposes, to stderr.
1.3 albertel 104:
1.1 foxr 105: =cut
106:
107: sub Dump {
108: my $self = shift;
1.32 foxr 109: my $level = shift;
1.35 foxr 110: my $now = time;
111: my $local = localtime($now);
1.32 foxr 112:
1.37 albertel 113: if ($level >= $DebugLevel) {
1.32 foxr 114: return;
115: }
116:
1.35 foxr 117:
1.10 foxr 118: my $key;
119: my $value;
1.35 foxr 120: print STDERR "[ $local ] Dumping LondConnectionObject:\n";
1.37 albertel 121: print STDERR join(':',caller(1))."\n";
1.1 foxr 122: while(($key, $value) = each %$self) {
1.22 foxr 123: print STDERR "$key -> $value\n";
1.1 foxr 124: }
1.23 foxr 125: print STDERR "-------------------------------\n";
1.1 foxr 126: }
127:
128: =pod
1.3 albertel 129:
130: Local function to do a state transition. If the state transition
131: callback is defined it is called with two parameters: the self and the
132: old state.
133:
1.1 foxr 134: =cut
1.3 albertel 135:
1.1 foxr 136: sub Transition {
1.30 foxr 137:
138: my ($self, $newstate) = @_;
139:
1.1 foxr 140: my $oldstate = $self->{State};
141: $self->{State} = $newstate;
142: $self->{TimeoutRemaining} = $self->{TimeoutValue};
143: if($self->{TransitionCallback}) {
144: ($self->{TransitionCallback})->($self, $oldstate);
145: }
146: }
147:
1.3 albertel 148:
1.14 foxr 149:
1.1 foxr 150: =pod
1.3 albertel 151:
152: =head2 new
153:
154: Construct a new lond connection.
155:
156: Parameters (besides the class name) include:
157:
158: =item hostname
159:
160: host the remote lond is on. This host is a host in the hosts.tab file
161:
162: =item port
163:
164: port number the remote lond is listening on.
165:
1.1 foxr 166: =cut
1.3 albertel 167:
1.1 foxr 168: sub new {
1.44 albertel 169: my ($class, $DnsName, $Port, $lonid) = @_;
1.14 foxr 170:
171: if (!$ConfigRead) {
172: ReadConfig();
173: $ConfigRead = 1;
174: }
1.45 albertel 175: &Debug(4,$class."::new( ".$DnsName.",".$Port.",".$lonid.")\n");
1.1 foxr 176:
1.56 ! raeburn 177: my ($conntype,$gotconninfo,$allowinsecure);
! 178: if ((ref($secureconf{'connto'}) eq 'HASH') &&
! 179: (exists($hosttypes{$lonid}))) {
! 180: $conntype = $secureconf{'connto'}{$hosttypes{$lonid}};
! 181: if ($conntype ne '') {
! 182: if ($conntype ne 'req') {
! 183: $allowinsecure = 1;
! 184: }
! 185: $gotconninfo = 1;
! 186: }
! 187: }
! 188: unless ($gotconninfo) {
! 189: $allowinsecure = $InsecureOk;
! 190: }
! 191:
1.1 foxr 192: # The host must map to an entry in the hosts table:
193: # We connect to the dns host that corresponds to that
194: # system and use the hostname for the encryption key
195: # negotion. In the objec these become the Host and
196: # LoncapaHim fields of the object respectively.
197: #
1.36 albertel 198: # if it is me use loopback for connection
1.44 albertel 199: if ($DnsName eq &main::my_hostname()) { $DnsName="127.0.0.1"; }
200: Debug(9, "Connecting to $DnsName");
1.1 foxr 201: # Now create the object...
202: my $self = { Host => $DnsName,
1.44 albertel 203: LoncapaHim => $lonid,
1.24 foxr 204: Port => $Port,
205: State => "Initialized",
1.31 foxr 206: AuthenticationMode => "",
1.56 ! raeburn 207: InsecureOK => $allowinsecure,
1.24 foxr 208: TransactionRequest => "",
209: TransactionReply => "",
1.39 albertel 210: NextRequest => "",
1.24 foxr 211: InformReadable => 0,
212: InformWritable => 0,
213: TimeoutCallback => undef,
214: TransitionCallback => undef,
215: Timeoutable => 0,
1.49 raeburn 216: TimeoutValue => 30,
1.24 foxr 217: TimeoutRemaining => 0,
1.31 foxr 218: LocalKeyFile => "",
1.24 foxr 219: CipherKey => "",
220: LondVersion => "Unknown",
1.52 foxr 221: Cipher => undef,
222: ClientData => undef};
1.1 foxr 223: bless($self, $class);
224: unless ($self->{Socket} = IO::Socket::INET->new(PeerHost => $self->{Host},
1.27 foxr 225: PeerPort => $self->{Port},
226: Type => SOCK_STREAM,
227: Proto => "tcp",
228: Timeout => 3)) {
1.36 albertel 229: Debug(8, "Error? \n$@ \n$!");
1.1 foxr 230: return undef; # Inidicates the socket could not be made.
231: }
1.31 foxr 232: my $socket = $self->{Socket}; # For local use only.
1.51 foxr 233: $socket->sockopt(SO_KEEPALIVE, 1); # Turn on keepalive probes when idle.
1.33 foxr 234: # If we are local, we'll first try local auth mode, otherwise, we'll try
235: # the ssl auth mode:
1.31 foxr 236:
237: my $key;
238: my $keyfile;
1.36 albertel 239: if ($DnsName eq '127.0.0.1') {
1.31 foxr 240: $self->{AuthenticationMode} = "local";
241: ($key, $keyfile) = lonlocal::CreateKeyFile();
242: Debug(8, "Local key: $key, stored in $keyfile");
243:
244: # If I can't make the key file fall back to insecure if
245: # allowed...else give up right away.
246:
247: if(!(defined $key) || !(defined $keyfile)) {
1.54 raeburn 248: my $canconnect = 0;
249: if (ref($secureconf{'connto'}) eq 'HASH') {
250: unless ($secureconf{'connto'}->{'dom'} eq 'req') {
251: $canconnect = 1;
252: }
253: } else {
254: $canconnect = $InsecureOk;
255: }
256: if ($canconnect) {
1.31 foxr 257: $self->{AuthenticationMode} = "insecure";
258: $self->{TransactionRequest} = "init\n";
259: }
260: else {
261: $socket->close;
262: return undef;
263: }
264: }
265: $self->{TransactionRequest} = "init:local:$keyfile\n";
266: Debug(9, "Init string is init:local:$keyfile");
267: if(!$self->CreateCipher($key)) { # Nothing's going our way...
268: $socket->close;
269: return undef;
270: }
271:
1.42 albertel 272: } else {
1.33 foxr 273: # Remote peer: I'd like to do ssl, but if my host key or certificates
274: # are not all installed, my only choice is insecure, if that's
275: # allowed:
276:
277: my ($ca, $cert) = lonssl::CertificateFile;
278: my $sslkeyfile = lonssl::KeyFile;
279:
1.56 ! raeburn 280: if (($conntype ne 'no') && (defined($ca)) && (defined($cert)) && (defined($sslkeyfile)) &&
! 281: (!exists($badcerts{$self->{LoncapaHim}}))) {
1.33 foxr 282: $self->{AuthenticationMode} = "ssl";
1.47 raeburn 283: $self->{TransactionRequest} = "init:ssl:$perlvar{'lonVersion'}\n";
1.56 ! raeburn 284: } elsif ($self->{InsecureOK}) {
1.54 raeburn 285: # Allowed to do insecure:
286: $self->{AuthenticationMode} = "insecure";
287: $self->{TransactionRequest} = "init::$perlvar{'lonVersion'}\n";
1.33 foxr 288: } else {
1.54 raeburn 289: # Not allowed to do insecure...
290: $socket->close;
291: return undef;
1.33 foxr 292: }
1.31 foxr 293: }
294:
1.1 foxr 295: #
296: # We're connected. Set the state, and the events we'll accept:
297: #
298: $self->Transition("Connected");
299: $self->{InformWritable} = 1; # When socket is writable we send init
1.9 foxr 300: $self->{Timeoutable} = 1; # Timeout allowed during startup negotiation.
1.31 foxr 301:
1.1 foxr 302:
303: #
304: # Set socket to nonblocking I/O.
305: #
1.31 foxr 306: my $flags = fcntl($socket, F_GETFL,0);
307: if(!$flags) {
1.1 foxr 308: $socket->close;
309: return undef;
310: }
1.31 foxr 311: if(!fcntl($socket, F_SETFL, $flags | O_NONBLOCK)) {
1.1 foxr 312: $socket->close;
313: return undef;
314: }
315:
316: # return the object :
317:
1.31 foxr 318: Debug(9, "Initial object state: ");
1.32 foxr 319: $self->Dump(9);
1.31 foxr 320:
1.1 foxr 321: return $self;
322: }
1.3 albertel 323:
1.1 foxr 324: =pod
1.3 albertel 325:
326: =head2 Readable
327:
328: This member should be called when the Socket becomes readable. Until
329: the read completes, action is state independet. Data are accepted into
330: the TransactionReply until a newline character is received. At that
331: time actionis state dependent:
332:
333: =item Connected
334:
335: in this case we received challenge, the state changes to
336: ChallengeReceived, and we initiate a send with the challenge response.
337:
338: =item ReceivingReply
339:
340: In this case a reply has been received for a transaction, the state
341: goes to Idle and we disable write and read notification.
342:
343: =item ChallengeReeived
344:
345: we just got what should be an ok\n and the connection can now handle
346: transactions.
1.1 foxr 347:
348: =cut
1.3 albertel 349:
1.1 foxr 350: sub Readable {
351: my $self = shift;
352: my $socket = $self->{Socket};
353: my $data = '';
1.27 foxr 354: my $rv;
1.31 foxr 355: my $ConnectionMode = $self->{AuthenticationMode};
356:
1.27 foxr 357: if ($socket) {
358: eval {
359: $rv = $socket->recv($data, POSIX::BUFSIZ, 0);
360: }
361: } else {
362: $self->Transition("Disconnected");
363: return -1;
364: }
1.1 foxr 365: my $errno = $! + 0; # Force numeric context.
366:
1.8 foxr 367: unless (defined($rv) && length $data) {# Read failed,
1.1 foxr 368: if(($errno == POSIX::EWOULDBLOCK) ||
369: ($errno == POSIX::EAGAIN) ||
1.8 foxr 370: ($errno == POSIX::EINTR)) {
1.1 foxr 371: return 0;
372: }
373:
374: # Connection likely lost.
375: &Debug(4, "Connection lost");
376: $self->{TransactionRequest} = '';
377: $socket->close();
378: $self->Transition("Disconnected");
379: return -1;
380: }
1.53 foxr 381: # If we actually got data, reset the timeout.
382:
383: if (length $data) {
384: $self->{TimeoutRemaining} = $self->{TimeoutValue}; # getting data resets the timeout period.
385: }
1.1 foxr 386: # Append the data to the buffer. And figure out if the read is done:
387:
388: &Debug(9,"Received from host: ".$data);
389: $self->{TransactionReply} .= $data;
1.29 albertel 390: if($self->{TransactionReply} =~ m/\n$/) {
1.1 foxr 391: &Debug(8,"Readable End of line detected");
1.31 foxr 392:
393:
1.1 foxr 394: if ($self->{State} eq "Initialized") { # We received the challenge:
1.31 foxr 395: # Our init was replied to. What happens next depends both on
396: # the actual init we sent (AuthenticationMode member data)
397: # and the response:
398: # AuthenticationMode == local:
399: # Response ok: The key has been exchanged and
400: # the key file destroyed. We can jump
401: # into setting the host and requesting the
402: # Later we'll also bypass key exchange.
403: # Response digits:
404: # Old style lond. Delete the keyfile.
405: # If allowed fall back to insecure mode.
406: # else close connection and fail.
407: # Response other:
408: # Failed local auth
409: # Close connection and fail.
410: #
411: # AuthenticationMode == ssl:
412: # Response ok:ssl
413: # Response digits:
414: # Response other:
415: # Authentication mode == insecure
416: # Response digits
417: # Response other:
418:
419: my $Response = $self->{TransactionReply};
420: if($ConnectionMode eq "local") {
421: if($Response =~ /^ok:local/) { # Good local auth.
422: $self->ToVersionRequest();
423: return 0;
424: }
425: elsif ($Response =~/^[0-9]+/) { # Old style lond.
426: return $self->CompleteInsecure();
427:
428: }
429: else { # Complete flop
430: &Debug(3, "init:local : unrecognized reply");
431: $self->Transition("Disconnected");
432: $socket->close;
433: return -1;
434: }
435: }
436: elsif ($ConnectionMode eq "ssl") {
437: if($Response =~ /^ok:ssl/) { # Good ssl...
1.56 ! raeburn 438: my $sslresult = $self->ExchangeKeysViaSSL();
! 439: if ($sslresult == 1) { # Success skip to vsn stuff
1.31 foxr 440: # Need to reset to non blocking:
441:
442: my $flags = fcntl($socket, F_GETFL, 0);
443: fcntl($socket, F_SETFL, $flags | O_NONBLOCK);
444: $self->ToVersionRequest();
445: return 0;
446: }
447: else { # Failed in ssl exchange.
1.56 ! raeburn 448: if (($sslresult == -1) && ($self->{InsecureOK})) {
! 449: $badcerts{$self->{LoncapaHim}} = 1;
! 450: }
1.31 foxr 451: &Debug(3,"init:ssl failed key negotiation!");
452: $self->Transition("Disconnected");
453: $socket->close;
454: return -1;
455: }
456: }
457: elsif ($Response =~ /^[0-9]+/) { # Old style lond.
458: return $self->CompleteInsecure();
459: }
460: else { # Complete flop
461: }
462: }
463: elsif ($ConnectionMode eq "insecure") {
464: if($self->{TransactionReply} eq "refused\n") { # Remote doesn't have
465:
466: $self->Transition("Disconnected"); # in host tables.
467: $socket->close();
468: return -1;
469:
470: }
471: return $self->CompleteInsecure();
472: }
473: else {
474: &Debug(1,"Authentication mode incorrect");
475: die "BUG!!! LondConnection::Readable invalid authmode";
1.1 foxr 476: }
1.27 foxr 477:
1.31 foxr 478:
1.28 albertel 479: } elsif ($self->{State} eq "ChallengeReplied") {
480: if($self->{TransactionReply} ne "ok\n") {
481: $self->Transition("Disconnected");
482: $socket->close();
483: return -1;
484: }
1.31 foxr 485: $self->ToVersionRequest();
1.28 albertel 486: return 0;
1.31 foxr 487:
1.28 albertel 488: } elsif ($self->{State} eq "ReadingVersionString") {
1.38 albertel 489: chomp($self->{TransactionReply});
490: $self->{LondVersion} = $self->{TransactionReply};
1.28 albertel 491: $self->Transition("SetHost");
492: $self->{InformReadable} = 0;
493: $self->{InformWritable} = 1;
494: my $peer = $self->{LoncapaHim};
495: $self->{TransactionRequest}= "sethost:$peer\n";
496: return 0;
1.24 foxr 497: } elsif ($self->{State} eq "HostSet") { # should be ok.
1.28 albertel 498: if($self->{TransactionReply} ne "ok\n") {
499: $self->Transition("Disconnected");
500: $socket->close();
501: return -1;
502: }
1.31 foxr 503: # If the auth mode is insecure we must still
504: # exchange session keys. Otherwise,
505: # we can just transition to idle.
506:
507: if($ConnectionMode eq "insecure") {
508: $self->Transition("RequestingKey");
509: $self->{InformReadable} = 0;
510: $self->{InformWritable} = 1;
511: $self->{TransactionRequest} = "ekey\n";
512: return 0;
513: }
514: else {
515: $self->ToIdle();
516: return 0;
517: }
1.1 foxr 518: } elsif ($self->{State} eq "ReceivingKey") {
519: my $buildkey = $self->{TransactionReply};
520: my $key = $self->{LoncapaHim}.$perlvar{'lonHostID'};
521: $key=~tr/a-z/A-Z/;
522: $key=~tr/G-P/0-9/;
523: $key=~tr/Q-Z/0-9/;
1.31 foxr 524: $key =$key.$buildkey.$key.$buildkey.$key.$buildkey;
525: $key = substr($key,0,32);
526: if(!$self->CreateCipher($key)) {
1.1 foxr 527: $self->Transition("Disconnected");
528: $socket->close();
529: return -1;
530: } else {
1.31 foxr 531: $self->ToIdle();
1.1 foxr 532: return 0;
533: }
534: } elsif ($self->{State} eq "ReceivingReply") {
535:
536: # If the data are encrypted, decrypt first.
537:
538: my $answer = $self->{TransactionReply};
539: if($answer =~ /^enc\:/) {
540: $answer = $self->Decrypt($answer);
1.34 foxr 541: $self->{TransactionReply} = "$answer\n";
1.1 foxr 542: }
1.39 albertel 543: # if we have a NextRequest do it immeadiately
544: if ($self->{NextRequest}) {
545: $self->{TransactionRequest} = $self->{NextRequest};
546: undef( $self->{NextRequest} );
547: $self->{TransactionReply} = "";
548: $self->{InformWritable} = 1;
549: $self->{InformReadable} = 0;
550: $self->{Timeoutable} = 1;
551: $self->Transition("SendingRequest");
552: return 0;
553: } else {
1.1 foxr 554: # finish the transaction
555:
1.39 albertel 556: $self->ToIdle();
557: return 0;
558: }
1.1 foxr 559: } elsif ($self->{State} eq "Disconnected") { # No connection.
560: return -1;
561: } else { # Internal error: Invalid state.
562: $self->Transition("Disconnected");
563: $socket->close();
564: return -1;
565: }
566: }
567:
568: return 0;
1.27 foxr 569:
1.1 foxr 570: }
571:
572:
573: =pod
1.3 albertel 574:
575: This member should be called when the Socket becomes writable.
576:
577: The action is state independent. An attempt is made to drain the
578: contents of the TransactionRequest member. Once this is drained, we
579: mark the object as waiting for readability.
1.1 foxr 580:
581: Returns 0 if successful, or -1 if not.
1.3 albertel 582:
1.1 foxr 583: =cut
584: sub Writable {
585: my $self = shift; # Get reference to the object.
586: my $socket = $self->{Socket};
1.26 albertel 587: my $nwritten;
588: if ($socket) {
589: eval {
590: $nwritten = $socket->send($self->{TransactionRequest}, 0);
591: }
1.27 foxr 592: } else {
593: # For whatever reason, there's no longer a socket left.
594:
595:
596: $self->Transition("Disconnected");
597: return -1;
1.26 albertel 598: }
1.1 foxr 599: my $errno = $! + 0;
600: unless (defined $nwritten) {
601: if($errno != POSIX::EINTR) {
602: $self->Transition("Disconnected");
603: return -1;
604: }
605:
606: }
1.10 foxr 607: if (($nwritten >= 0) ||
1.1 foxr 608: ($errno == POSIX::EWOULDBLOCK) ||
609: ($errno == POSIX::EAGAIN) ||
610: ($errno == POSIX::EINTR) ||
611: ($errno == 0)) {
1.50 foxr 612: $self->{TimeoutRemaining} = $self->{TimeoutValue};
1.1 foxr 613: substr($self->{TransactionRequest}, 0, $nwritten) = ""; # rmv written part
1.50 foxr 614: if(length $self->{TransactionRequest} == 0) {
615: $self->{InformWritable} = 0;
616: $self->{InformReadable} = 1;
617: $self->{TransactionReply} = '';
618: #
619: # Figure out the next state:
620: #
621: if($self->{State} eq "Connected") {
622: $self->Transition("Initialized");
623: } elsif($self->{State} eq "ChallengeReceived") {
624: $self->Transition("ChallengeReplied");
625: } elsif($self->{State} eq "RequestingVersion") {
626: $self->Transition("ReadingVersionString");
627: } elsif ($self->{State} eq "SetHost") {
628: $self->Transition("HostSet");
629: } elsif($self->{State} eq "RequestingKey") {
630: $self->Transition("ReceivingKey");
1.24 foxr 631: # $self->{InformWritable} = 0;
632: # $self->{InformReadable} = 1;
633: # $self->{TransactionReply} = '';
1.50 foxr 634: } elsif ($self->{State} eq "SendingRequest") {
635: $self->Transition("ReceivingReply");
636: $self->{TimeoutRemaining} = $self->{TimeoutValue};
637: } elsif ($self->{State} eq "Disconnected") {
638: return -1;
639: }
640: return 0;
641: }
642: } else { # The write failed (e.g. partner disconnected).
643: $self->Transition("Disconnected");
644: $socket->close();
645: return -1;
646: }
647:
1.1 foxr 648: }
649: =pod
1.3 albertel 650:
651: =head2 Tick
652:
1.1 foxr 653: Tick is called every time unit by the event framework. It
1.3 albertel 654:
655: =item 1 decrements the remaining timeout.
656:
657: =item 2 If the timeout is zero, calls TimedOut indicating that the current operation timed out.
1.1 foxr 658:
659: =cut
660:
661: sub Tick {
662: my $self = shift;
663: $self->{TimeoutRemaining}--;
664: if ($self->{TimeoutRemaining} < 0) {
665: $self->TimedOut();
666: }
667: }
1.3 albertel 668:
1.1 foxr 669: =pod
670:
1.3 albertel 671: =head2 TimedOut
672:
673: called on a timeout. If the timeout callback is defined, it is called
674: with $self as its parameters.
675:
676: =cut
677:
1.1 foxr 678: sub TimedOut {
679:
680: my $self = shift;
681: if($self->{TimeoutCallback}) {
682: my $callback = $self->{TimeoutCallback};
683: my @args = ( $self);
684: &$callback(@args);
685: }
686: }
1.3 albertel 687:
1.1 foxr 688: =pod
1.3 albertel 689:
690: =head2 InitiateTransaction
691:
692: Called to initiate a transaction. A transaction can only be initiated
693: when the object is idle... otherwise an error is returned. A
694: transaction consists of a request to the server that will have a
695: reply. This member sets the request data in the TransactionRequest
696: member, makes the state SendingRequest and sets the data to allow a
697: timout, and to request writability notification.
698:
1.1 foxr 699: =cut
1.3 albertel 700:
1.1 foxr 701: sub InitiateTransaction {
1.30 foxr 702:
703: my ($self, $data) = @_;
1.1 foxr 704:
1.4 foxr 705: Debug(1, "initiating transaction: ".$data);
1.1 foxr 706: if($self->{State} ne "Idle") {
1.4 foxr 707: Debug(0," .. but not idle here\n");
1.1 foxr 708: return -1; # Error indicator.
709: }
710: # if the transaction is to be encrypted encrypt the data:
1.39 albertel 711: (my $sethost, my $server,$data)=split(/:/,$data,3);
1.1 foxr 712:
713: if($data =~ /^encrypt\:/) {
714: $data = $self->Encrypt($data);
715: }
716:
717: # Setup the trasaction
1.39 albertel 718: # currently no version of lond supports inlining the sethost
1.40 albertel 719: if ($self->PeerVersion() <= 321) {
1.39 albertel 720: if ($server ne $self->{LoncapaHim}) {
721: $self->{NextRequest} = $data;
722: $self->{TransactionRequest} = "$sethost:$server\n";
723: $self->{LoncapaHim} = $server;
724: } else {
725: $self->{TransactionRequest} = $data;
726: }
727: } else {
1.40 albertel 728: $self->{LoncapaHim} = $server;
1.39 albertel 729: $self->{TransactionRequest} = "$sethost:$server:$data";
730: }
1.1 foxr 731: $self->{TransactionReply} = "";
732: $self->{InformWritable} = 1;
733: $self->{InformReadable} = 0;
734: $self->{Timeoutable} = 1;
735: $self->{TimeoutRemaining} = $self->{TimeoutValue};
736: $self->Transition("SendingRequest");
737: }
738:
739:
740: =pod
1.3 albertel 741:
742: =head2 SetStateTransitionCallback
743:
744: Sets a callback for state transitions. Returns a reference to any
745: prior established callback, or undef if there was none:
746:
1.1 foxr 747: =cut
1.3 albertel 748:
1.1 foxr 749: sub SetStateTransitionCallback {
750: my $self = shift;
751: my $oldCallback = $self->{TransitionCallback};
752: $self->{TransitionCallback} = shift;
753: return $oldCallback;
754: }
1.3 albertel 755:
1.1 foxr 756: =pod
1.3 albertel 757:
758: =head2 SetTimeoutCallback
759:
760: Sets the timeout callback. Returns a reference to any prior
761: established callback or undef if there was none.
762:
1.1 foxr 763: =cut
1.3 albertel 764:
1.1 foxr 765: sub SetTimeoutCallback {
1.30 foxr 766:
767: my ($self, $callback) = @_;
768:
1.1 foxr 769: my $oldCallback = $self->{TimeoutCallback};
770: $self->{TimeoutCallback} = $callback;
771: return $oldCallback;
772: }
773:
774: =pod
1.3 albertel 775:
1.5 foxr 776: =head2 Shutdown:
777:
778: Shuts down the socket.
779:
780: =cut
781:
782: sub Shutdown {
783: my $self = shift;
784: my $socket = $self->GetSocket();
1.20 albertel 785: Debug(5,"socket is -$socket-");
786: if ($socket) {
787: # Ask lond to exit too. Non blocking so
788: # there is no cost for failure.
789: eval {
790: $socket->send("exit\n", 0);
791: $socket->shutdown(2);
792: }
793: }
1.50 foxr 794: $self->{Timeoutable} = 0; # Shutdown sockets can't timeout.
1.5 foxr 795: }
796:
797: =pod
798:
1.3 albertel 799: =head2 GetState
800:
801: selector for the object state.
802:
1.1 foxr 803: =cut
1.3 albertel 804:
1.1 foxr 805: sub GetState {
806: my $self = shift;
807: return $self->{State};
808: }
1.3 albertel 809:
1.1 foxr 810: =pod
1.3 albertel 811:
812: =head2 GetSocket
813:
814: selector for the object socket.
815:
1.1 foxr 816: =cut
1.3 albertel 817:
1.1 foxr 818: sub GetSocket {
819: my $self = shift;
820: return $self->{Socket};
821: }
1.3 albertel 822:
1.5 foxr 823:
1.1 foxr 824: =pod
1.3 albertel 825:
826: =head2 WantReadable
827:
828: Return the state of the flag that indicates the object wants to be
829: called when readable.
830:
1.1 foxr 831: =cut
1.3 albertel 832:
1.1 foxr 833: sub WantReadable {
834: my $self = shift;
835:
836: return $self->{InformReadable};
837: }
1.3 albertel 838:
1.1 foxr 839: =pod
1.3 albertel 840:
841: =head2 WantWritable
842:
843: Return the state of the flag that indicates the object wants write
844: notification.
845:
1.1 foxr 846: =cut
1.3 albertel 847:
1.1 foxr 848: sub WantWritable {
849: my $self = shift;
850: return $self->{InformWritable};
851: }
1.3 albertel 852:
1.1 foxr 853: =pod
1.3 albertel 854:
855: =head2 WantTimeout
856:
857: return the state of the flag that indicates the object wants to be
858: informed of timeouts.
859:
1.1 foxr 860: =cut
1.3 albertel 861:
1.1 foxr 862: sub WantTimeout {
863: my $self = shift;
864: return $self->{Timeoutable};
865: }
866:
867: =pod
1.3 albertel 868:
869: =head2 GetReply
870:
871: Returns the reply from the last transaction.
872:
1.1 foxr 873: =cut
1.3 albertel 874:
1.1 foxr 875: sub GetReply {
876: my $self = shift;
877: return $self->{TransactionReply};
878: }
879:
880: =pod
1.3 albertel 881:
882: =head2 Encrypt
883:
884: Returns the encrypted version of the command string.
885:
886: The command input string is of the form:
887:
1.1 foxr 888: encrypt:command
1.3 albertel 889:
890: The output string can be directly sent to lond as it is of the form:
891:
1.1 foxr 892: enc:length:<encodedrequest>
1.3 albertel 893:
1.1 foxr 894: =cut
1.3 albertel 895:
1.1 foxr 896: sub Encrypt {
1.30 foxr 897:
898: my ($self, $request) = @_;
1.1 foxr 899:
900:
901: # Split the encrypt: off the request and figure out it's length.
902: # the cipher works in blocks of 8 bytes.
903:
904: my $cmd = $request;
905: $cmd =~ s/^encrypt\://; # strip off encrypt:
906: chomp($cmd); # strip off trailing \n
907: my $length=length($cmd); # Get the string length.
908: $cmd .= " "; # Pad with blanks so we can fill out a block.
909:
910: # encrypt the request in 8 byte chunks to create the encrypted
911: # output request.
912:
913: my $Encoded = '';
914: for(my $index = 0; $index <= $length; $index += 8) {
915: $Encoded .=
916: unpack("H16",
917: $self->{Cipher}->encrypt(substr($cmd,
918: $index, 8)));
919: }
920:
921: # Build up the answer as enc:length:$encrequest.
922:
923: $request = "enc:$length:$Encoded\n";
924: return $request;
925:
926:
927: }
1.3 albertel 928:
929: =pod
930:
931: =head2 Decrypt
932:
933: Decrypt a response from the server. The response is in the form:
934:
935: enc:<length>:<encrypted data>
936:
1.1 foxr 937: =cut
1.3 albertel 938:
1.1 foxr 939: sub Decrypt {
1.30 foxr 940:
941: my ($self, $encrypted) = @_;
1.1 foxr 942:
943: # Bust up the response into length, and encryptedstring:
944:
945: my ($enc, $length, $EncryptedString) = split(/:/,$encrypted);
946: chomp($EncryptedString);
947:
948: # Decode the data in 8 byte blocks. The string is encoded
949: # as hex digits so there are two characters per byte:
950:
1.10 foxr 951: my $decrypted = "";
1.1 foxr 952: for(my $index = 0; $index < length($EncryptedString);
953: $index += 16) {
954: $decrypted .= $self->{Cipher}->decrypt(
955: pack("H16",
956: substr($EncryptedString,
957: $index,
958: 16)));
959: }
960: # the answer may have trailing pads to fill out a block.
961: # $length tells us the actual length of the decrypted string:
962:
963: $decrypted = substr($decrypted, 0, $length);
1.34 foxr 964: Debug(9, "Decrypted $EncryptedString to $decrypted");
1.1 foxr 965:
966: return $decrypted;
967:
968: }
1.31 foxr 969: # ToIdle
970: # Called to transition to idle... done enough it's worth subbing
971: # off to ensure it's always done right!!
972: #
973: sub ToIdle {
974: my $self = shift;
975:
976: $self->Transition("Idle");
977: $self->{InformWritiable} = 0;
978: $self->{InformReadable} = 0;
979: $self->{Timeoutable} = 0;
980: }
981:
982: # ToVersionRequest
983: # Called to transition to "RequestVersion" also done a few times
984: # so worth subbing out.
985: #
986: sub ToVersionRequest {
987: my $self = shift;
988:
989: $self->Transition("RequestingVersion");
990: $self->{InformReadable} = 0;
991: $self->{InformWritable} = 1;
992: $self->{TransactionRequest} = "version\n";
993:
994: }
995: #
996: # CreateCipher
997: # Given a cipher key stores the key in the object context,
998: # creates the cipher object, (stores that in object context),
999: # This is done a couple of places, so it's worth factoring it out.
1000: #
1001: # Parameters:
1002: # (self)
1003: # key - The Cipher key.
1004: #
1005: # Returns:
1006: # 0 - Failure to create IDEA cipher.
1007: # 1 - Success.
1008: #
1009: sub CreateCipher {
1010: my ($self, $key) = @_; # According to coding std.
1011:
1012: $self->{CipherKey} = $key; # Save the text key...
1013: my $packedkey = pack ("H32", $key);
1014: my $cipher = new IDEA $packedkey;
1015: if($cipher) {
1016: $self->{Cipher} = $cipher;
1017: Debug("Cipher created dumping socket: ");
1.32 foxr 1018: $self->Dump(9);
1.31 foxr 1019: return 1;
1020: }
1021: else {
1022: return 0;
1023: }
1024: }
1025: # ExchangeKeysViaSSL
1026: # Called to do cipher key exchange via SSL.
1027: # The socket is promoted to an SSL socket. If that's successful,
1028: # we read out cipher key through the socket and create an IDEA
1029: # cipher object.
1030: # Parameters:
1031: # (self)
1032: # Returns:
1033: # true - Success.
1034: # false - Failure.
1035: #
1036: # Assumptions:
1037: # 1. The ssl session setup has timeout logic built in so we don't
1038: # have to worry about DOS attacks at that stage.
1039: # 2. If the ssl session gets set up we are talking to a legitimate
1040: # lond so again we don't have to worry about DOS attacks.
1041: # All this allows us just to call
1042: sub ExchangeKeysViaSSL {
1043: my $self = shift;
1044: my $socket = $self->{Socket};
1.56 ! raeburn 1045: my $peer = $self->{LoncapaHim};
1.31 foxr 1046:
1047: # Get our signed certificate, the certificate authority's
1048: # certificate and our private key file. All of these
1049: # are needed to create the ssl connection.
1050:
1051: my ($SSLCACertificate,
1052: $SSLCertificate) = lonssl::CertificateFile();
1053: my $SSLKey = lonssl::KeyFile();
1054:
1055: # Promote our connection to ssl and read the key from lond.
1056:
1057: my $SSLSocket = lonssl::PromoteClientSocket($socket,
1058: $SSLCACertificate,
1059: $SSLCertificate,
1.56 ! raeburn 1060: $SSLKey,
! 1061: $peer);
1.31 foxr 1062: if(defined $SSLSocket) {
1063: my $key = <$SSLSocket>;
1064: lonssl::Close($SSLSocket);
1065: if($key) {
1066: chomp($key); # \n is not part of the key.
1067: return $self->CreateCipher($key);
1068: }
1069: else {
1070: Debug(3, "Failed to read ssl key");
1071: return 0;
1072: }
1073: }
1074: else {
1075: # Failed!!
1076: Debug(3, "Failed to negotiate SSL connection!");
1.56 ! raeburn 1077: return -1;
1.31 foxr 1078: }
1079: # should not get here
1080: return 0;
1081:
1082: }
1083:
1084:
1085:
1086: #
1087: # CompleteInsecure:
1088: # This function is called to initiate the completion of
1089: # insecure challenge response negotiation.
1090: # To do this, we copy the challenge string to the transaction
1091: # request, flip to writability and state transition to
1092: # ChallengeReceived..
1093: # All this is only possible if InsecureOk is true.
1094: # Parameters:
1095: # (self) - This object's context hash.
1096: # Return:
1097: # 0 - Ok to transition.
1098: # -1 - Not ok to transition (InsecureOk not ok).
1099: #
1100: sub CompleteInsecure {
1101: my $self = shift;
1.56 ! raeburn 1102: if ($self->{InsecureOK}) {
1.31 foxr 1103: $self->{AuthenticationMode} = "insecure";
1104: &Debug(8," Transition out of Initialized:insecure");
1105: $self->{TransactionRequest} = $self->{TransactionReply};
1106: $self->{InformWritable} = 1;
1107: $self->{InformReadable} = 0;
1108: $self->Transition("ChallengeReceived");
1109: $self->{TimeoutRemaining} = $self->{TimeoutValue};
1110: return 0;
1111:
1112:
1113: }
1114: else {
1115: &Debug(3, "Insecure key negotiation disabled!");
1116: my $socket = $self->{Socket};
1117: $socket->close;
1118: return -1;
1119: }
1120: }
1.1 foxr 1121:
1.14 foxr 1122: ###########################################################
1123: #
1124: # The following is an unashamed kludge that is here to
1125: # allow LondConnection to be used outside of the
1126: # loncapa environment (e.g. by lonManage).
1127: #
1128: # This is a textual inclusion of pieces of the
1129: # Configuration.pm module.
1130: #
1131:
1132:
1.43 raeburn 1133: my @confdirs=('/etc/httpd/conf/','/etc/apache2/');
1.14 foxr 1134:
1135: # ------------------- Subroutine read_conf: read LON-CAPA server configuration.
1136: # This subroutine reads PerlSetVar values out of specified web server
1137: # configuration files.
1138: sub read_conf
1139: {
1140: my (@conf_files)=@_;
1.43 raeburn 1141: my (%perlvar,%configdirs);
1142: foreach my $filename (@conf_files,'loncapa_apache.conf') {
1143: my $configdir = '';
1144: $configdirs{$filename} = [@confdirs];
1145: while ($configdir eq '' && @{$configdirs{$filename}} > 0) {
1146: my $testdir = shift(@{$configdirs{$filename}});
1147: if (-e $testdir.$filename) {
1148: $configdir = $testdir;
1149: }
1150: }
1151: if ($configdir eq '') {
1152: die("Couldn't find a directory containing $filename");
1153: }
1154: if($DebugLevel > 3) {
1155: print STDERR ("Going to read $configdir.$filename\n");
1156: }
1157: open(CONFIG,'<'.$configdir.$filename) or
1158: die("Can't read $configdir$filename");
1159: while (my $configline=<CONFIG>) {
1160: if ($configline =~ /^[^\#]*PerlSetVar/) {
1161: my ($unused,$varname,$varvalue)=split(/\s+/,$configline);
1.14 foxr 1162: chomp($varvalue);
1163: $perlvar{$varname}=$varvalue;
1.43 raeburn 1164: }
1165: }
1.14 foxr 1166: close(CONFIG);
1.43 raeburn 1167: }
1.21 foxr 1168: if($DebugLevel > 3) {
1.31 foxr 1169: print STDERR "Dumping perlvar:\n";
1.21 foxr 1170: foreach my $var (keys %perlvar) {
1.31 foxr 1171: print STDERR "$var = $perlvar{$var}\n";
1.21 foxr 1172: }
1173: }
1.14 foxr 1174: my $perlvarref=\%perlvar;
1.21 foxr 1175: return $perlvarref;
1176: }
1.14 foxr 1177:
1.24 foxr 1178: #
1179: # Get the version of our peer. Note that this is only well
1180: # defined if the state machine has hit the idle state at least
1181: # once (well actually if it has transitioned out of
1182: # ReadingVersionString The member data LondVersion is returned.
1183: #
1184: sub PeerVersion {
1185: my $self = shift;
1.40 albertel 1186: my ($version) = ($self->{LondVersion} =~ /Revision: 1\.(\d+)/);
1187: return $version;
1.24 foxr 1188: }
1.1 foxr 1189:
1.52 foxr 1190: #
1191: # Manipulate the client data field
1192: #
1193: sub SetClientData {
1194: my ($self, $newData) = @_;
1195: $self->{ClientData} = $newData;
1196: }
1197: #
1198: # Get the current client data field.
1199: #
1200: sub GetClientData {
1201: my $self = shift;
1202: return $self->{ClientData};
1203: }
1204:
1.55 raeburn 1205: #
1206: # Get the HostID of our peer
1207: #
1208:
1209: sub PeerLoncapaHim {
1210: my $self = shift;
1211: return $self->{LoncapaHim};
1212: }
1213:
1.1 foxr 1214: 1;
1215:
1216: =pod
1.3 albertel 1217:
1.1 foxr 1218: =head1 Theory
1219:
1.3 albertel 1220: The lond object is a state machine. It lives through the following states:
1221:
1222: =item Connected:
1223:
1224: a TCP connection has been formed, but the passkey has not yet been
1225: negotiated.
1226:
1227: =item Initialized:
1228:
1229: "init" sent.
1230:
1231: =item ChallengeReceived:
1232:
1233: lond sent its challenge to us.
1234:
1235: =item ChallengeReplied:
1236:
1237: We replied to lond's challenge waiting for lond's ok.
1238:
1239: =item RequestingKey:
1240:
1241: We are requesting an encryption key.
1242:
1243: =item ReceivingKey:
1244:
1245: We are receiving an encryption key.
1246:
1247: =item Idle:
1248:
1249: Connection was negotiated but no requests are active.
1250:
1251: =item SendingRequest:
1252:
1253: A request is being sent to the peer.
1254:
1255: =item ReceivingReply:
1256:
1257: Waiting for an entire reply from the peer.
1258:
1259: =item Disconnected:
1260:
1261: For whatever reason, the connection was dropped.
1262:
1263: When we need to be writing data, we have a writable event. When we
1264: need to be reading data, a readable event established. Events
1265: dispatch through the class functions Readable and Writable, and the
1266: watcher contains a reference to the associated object to allow object
1267: context to be reached.
1.1 foxr 1268:
1269: =head2 Member data.
1270:
1.3 albertel 1271: =item Host
1272:
1273: Host socket is connected to.
1274:
1275: =item Port
1276:
1277: The port the remote lond is listening on.
1278:
1279: =item Socket
1280:
1281: Socket open on the connection.
1282:
1283: =item State
1284:
1285: The current state.
1286:
1.31 foxr 1287: =item AuthenticationMode
1288:
1289: How authentication is being done. This can be any of:
1290:
1291: o local - Authenticate via a key exchanged in a file.
1292: o ssl - Authenticate via a key exchaned through a temporary ssl tunnel.
1293: o insecure - Exchange keys in an insecure manner.
1294:
1295: insecure is only allowed if the configuration parameter loncAllowInsecure
1296: is nonzero.
1297:
1.3 albertel 1298: =item TransactionRequest
1299:
1300: The request being transmitted.
1301:
1302: =item TransactionReply
1303:
1304: The reply being received from the transaction.
1305:
1306: =item InformReadable
1307:
1308: True if we want to be called when socket is readable.
1309:
1310: =item InformWritable
1311:
1312: True if we want to be informed if the socket is writable.
1313:
1314: =item Timeoutable
1315:
1316: True if the current operation is allowed to timeout.
1317:
1318: =item TimeoutValue
1319:
1320: Number of seconds in the timeout.
1321:
1322: =item TimeoutRemaining
1323:
1324: Number of seconds left in the timeout.
1325:
1326: =item CipherKey
1327:
1328: The key that was negotiated with the peer.
1329:
1330: =item Cipher
1331:
1332: The cipher obtained via the key.
1.1 foxr 1333:
1334:
1335: =head2 The following are callback like members:
1.3 albertel 1336:
1337: =item Tick:
1338:
1339: Called in response to a timer tick. Used to managed timeouts etc.
1340:
1341: =item Readable:
1342:
1343: Called when the socket becomes readable.
1344:
1345: =item Writable:
1346:
1347: Called when the socket becomes writable.
1348:
1349: =item TimedOut:
1350:
1351: Called when a timed operation timed out.
1352:
1.1 foxr 1353:
1354: =head2 The following are operational member functions.
1.3 albertel 1355:
1356: =item InitiateTransaction:
1357:
1358: Called to initiate a new transaction
1359:
1360: =item SetStateTransitionCallback:
1361:
1362: Called to establish a function that is called whenever the object goes
1363: through a state transition. This is used by The client to manage the
1364: work flow for the object.
1365:
1366: =item SetTimeoutCallback:
1367:
1368: Set a function to be called when a transaction times out. The
1369: function will be called with the object as its sole parameter.
1370:
1371: =item Encrypt:
1372:
1373: Encrypts a block of text according to the cipher negotiated with the
1374: peer (assumes the text is a command).
1375:
1376: =item Decrypt:
1377:
1378: Decrypts a block of text according to the cipher negotiated with the
1379: peer (assumes the block was a reply.
1.5 foxr 1380:
1381: =item Shutdown:
1382:
1383: Shuts off the socket.
1.1 foxr 1384:
1385: =head2 The following are selector member functions:
1386:
1.3 albertel 1387: =item GetState:
1388:
1389: Returns the current state
1390:
1391: =item GetSocket:
1392:
1393: Gets the socekt open on the connection to lond.
1394:
1395: =item WantReadable:
1396:
1397: true if the current state requires a readable event.
1398:
1399: =item WantWritable:
1400:
1401: true if the current state requires a writable event.
1402:
1403: =item WantTimeout:
1404:
1405: true if the current state requires timeout support.
1406:
1.1 foxr 1407: =cut
FreeBSD-CVSweb <freebsd-cvsweb@FreeBSD.org>
![[BACK]](/icons/back.gif){kind=icon}
Return to LondConnection.pm CVS log ![[TXT]](/icons/text.gif){kind=icon}
![[DIR]](/icons/dir.gif){kind=icon}
Up to [LON-CAPA] / loncom