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