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