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