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