Mercurial > hg > monetdb-perl

comparison MonetDB-CLI-MapiPP/MonetDB/CLI/Mapi.pm @ 1:f899cb48b4cc

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
Turned into independent repository. Updated version numbers to 1.00; added Fedora spec file; added top-level Makefile.
author Sjoerd Mullender <sjoerd@acm.org>
date Mon, 19 Sep 2016 15:20:16 +0200 (2016-09-19)
parents Mapi.pm@cedccb7e0143
children a0ec9e080a5b
comparison
equal deleted inserted replaced
0:cedccb7e0143 1:f899cb48b4cc
1 # This Source Code Form is subject to the terms of the Mozilla Public
2 # License, v. 2.0. If a copy of the MPL was not distributed with this
3 # file, You can obtain one at http://mozilla.org/MPL/2.0/.
4 #
5 # Copyright 1997 - July 2008 CWI, August 2008 - 2016 MonetDB B.V.
6
7 package MonetDB::CLI::Mapi;
8
9 use strict;
10 use Socket;
11 use IO::Socket;
12 use Digest::MD5 'md5_hex';
13 use Digest::SHA qw(sha1_hex sha256_hex sha512_hex);
14
15 our $VERSION = '1.00';
16
17 sub pass_chal {
18 my ($passwd, @challenge) = @_;
19 if ($challenge[2] == 9) {
20 my $pwhash = $challenge[5];
21 if ($pwhash eq 'SHA512') {
22 $passwd = sha512_hex($passwd);
23 } elsif ($pwhash eq 'SHA256') {
24 $passwd = sha256_hex($passwd);
25 } elsif ($pwhash eq 'SHA1') {
26 $passwd = sha1_hex($passwd);
27 } elsif ($pwhash eq 'MD5') {
28 $passwd = md5_hex($passwd);
29 } else {
30 warn "unsupported password hash: ".$pwhash;
31 return;
32 }
33 } else {
34 warn "unsupported protocol version: ".$challenge[2];
35 return;
36 }
37
38 my @cyphers = split(/,/, $challenge[3]);
39 my $chal;
40 foreach (@cyphers) {
41 if ($_ eq 'SHA512') {
42 $chal = "{$_}".sha512_hex($passwd.$challenge[0]);
43 last;
44 } elsif ($_ eq 'SHA256') {
45 $chal = "{$_}".sha256_hex($passwd.$challenge[0]);
46 last;
47 } elsif ($_ eq 'SHA1') {
48 $chal = "{$_}".sha1_hex($passwd.$challenge[0]);
49 last;
50 } elsif ($_ eq 'MD5') {
51 $chal = "{$_}".md5_hex($passwd.$challenge[0]);
52 last;
53 }
54 }
55 if (!$chal) {
56 warn "unsupported hash algorithm necessary for login: ".$challenge[3];
57 return;
58 }
59
60 return $chal;
61 }
62
63 sub new {
64 my $mapi = shift;
65 my $host = shift || 'localhost';
66 my $port = shift || 50000;
67 my $user = shift || 'monetdb';
68 my $passwd = shift || 'monetdb';
69 my $lang = shift || 'sql';
70 my $db = shift || '';
71 my $trace = shift || 0;
72 my $self = {};
73
74 bless( $self, $mapi );
75
76 $self->{trace} = $trace;
77
78 print "new:$host,$port,$user,$passwd,$lang,$db\n" if ($self->{trace});
79 $self->{host} = $host;
80 $self->{port} = $port;
81 $self->{user} = $user;
82 $self->{passwd} = $passwd;
83 $self->{lang} = $lang;
84 $self->{db} = $db;
85 $self->{socket} = IO::Socket::INET->new(
86 PeerAddr => $host,
87 PeerPort => $port,
88 Proto => 'tcp'
89 ) || die "!ERROR can't connect to $host:$port $!";
90 $self->{piggyback} = [];
91 $self->{skip_in} = 0;
92
93 #binmode($self->{socket},":utf8");
94
95 #block challenge:mserver:9:cypher(s):content_byteorder(BIG/LIT):pwhash\n");
96 my $block = $self->getblock();
97 my @challenge = split(/:/, $block);
98 print "Connection to socket established ($block)\n" if ($self->{trace});
99
100 my $passchal = pass_chal($passwd, @challenge) || die;
101
102 # content_byteorder(BIG/LIT):user:{cypher_algo}mypasswordchallenge_cyphered:lang:database:
103 $self->putblock("LIT:$user:$passchal:$lang:$db:\n");
104 my $prompt = $self->getblock();
105 if ($prompt =~ /^\^mapi:monetdb:/) {
106 # full reconnect
107 $self->{socket}->close;
108 print "Following redirect: $prompt\n" if ($self->{trace});
109 my @tokens = split(/[\n\/:\?]+/, $prompt); # dirty, but it's Perl anyway
110 return new MonetDB::CLI::Mapi($tokens[3], $tokens[4], $user, $passwd, $lang, $tokens[5], $trace);
111 } elsif ($prompt =~ /^\^mapi:merovingian:\/\/proxy/) {
112 # proxied redirect
113 do {
114 print "Being proxied by $host:$port\n" if ($self->{trace});
115 $block = $self->getblock();
116 @challenge = split(/:/, $block);
117 $passchal = pass_chal($passwd, @challenge) || die;
118 $self->putblock("LIT:$user:$passchal:$lang:$db:\n");
119 $prompt = $self->getblock();
120 } while ($prompt =~ /^\^mapi:merovingian:proxy/);
121 } # TODO: don't die on warnings (#)
122 die $prompt if ($prompt ne "");
123 print "Logged on $user\@$db with $lang\n" if ($self->{trace});
124 return $self;
125 }
126
127 # How to create a duplicate
128 sub clone {
129 my ($self,$src)= @_;
130 bless($self,"MonetDB::CLI::Mapi");
131 print "cloning\n" if ($self->{trace});
132 $self->{host} = $src->{host};
133 $self->{port} = $src->{port};
134 $self->{user} = $src->{user};
135 $self->{passwd} = $src->{passwd};
136 $self->{lang} = $src->{lang};
137 $self->{db} = $src->{db};
138 $self->{socket} = $src->{socket};
139 $self->resetState();
140 }
141
142 sub mapiport_intern {
143 my $mapiport = 'localhost:50000';
144 $mapiport = $ENV{'MAPIPORT'} if defined($ENV{'MAPIPORT'});
145 return $mapiport;
146 }
147
148 sub hostname {
149 my ($hostname) = mapiport_intern() =~ /([^:]*)/;
150 $hostname = 'localhost' if ($hostname eq '');
151 return $hostname;
152 }
153
154 sub portnr {
155 my ($portnr) = mapiport_intern() =~ /:([^:]*)/;
156 $portnr = 50000 if ($portnr eq '');
157 return $portnr;
158 }
159
160 sub disconnect {
161 my ($self) = @_;
162 print "disconnect\n" if ($self->{trace});
163 $self->{socket}->close;
164 print "Disconnected from server\n" if ($self->{trace});
165 }
166
167 sub showState {
168 my ($self) = @_;
169 if ($self->{trace}) {
170 print "mapi.error :".$self->{error}."\n";
171 print "mapi.errstr:".$self->{errstr}."\n";
172 print "mapi.active:".$self->{active}."\n";
173 print "mapi.row[".length($self->{row})."]:".$self->{row}."\n";
174 }
175 }
176
177 sub resetState {
178 my ($self) = @_;
179 print "resetState\n" if ($self->{trace});
180 $self->{errstr}="";
181 $self->{error}=0;
182 $self->{active}=0;
183 }
184
185 #packge the request and ship it, the back-end reads blocks!
186 sub doRequest {
187 my($self,$cmd) = @_;
188
189 $cmd = "S" . $cmd if $self->{lang} eq 'sql';
190 # even if the query ends with a ;, this never hurts and fixes the -- on last line bug
191 $cmd = $cmd . "\n;\n";
192 print "doRequest:$cmd\n" if ($self->{trace});
193 $self->putblock($cmd); # TODO handle exceptions || die "!ERROR can't send $cmd: $!";
194 $self->resetState();
195 }
196
197 # Analyse a single line for errors
198 sub error {
199 my ($self,$line) = @_;
200 my $err = $self->{errstr};
201 $err = "$err\n" if (length($err) > 0);
202 $line =~ s/^\!//;
203 $self->{errstr} = $err . $line;
204 # $self->showState();
205 $self->{row}= "";
206 $self->{error} = 1;
207 print "Error found $self->{error}\n" if ($self->{trace});
208 }
209
210 # analyse commentary lines for auxiliary information
211 sub propertyTest {
212 my ($self) =@_;
213 my $err= $self->{error};
214 my $row= $self->{row};
215 # $self->showState();
216 if ($row =~ /^\#---/) {
217 $self->{row}= "";
218 return 1;
219 }
220 if ($row =~ /^\#.*\#/) {
221 $self->{row}= "";
222 return 1;
223 }
224 return 0;
225 }
226
227
228 sub getRow {
229 my ($self)= @_;
230 my $row = $self->{lines}[$self->{next}++];
231 my @chars = split(//, $row,3);
232
233 if ($chars[0] eq '!') {
234 $self->error($row);
235 my $i = 1;
236 while ($self->{lines}[$i] =~ '!') {
237 $self->error($self->{lines}[$i]);
238 $i++;
239 }
240 $self->{active} = 0;
241 return -1
242 } elsif ($chars[0] eq '&') {
243 # not expected
244 } elsif ($chars[0] eq '%') {
245 # header line
246 } elsif ($chars[0] eq '[') {
247 # row result
248 $self->{row} = $row;
249 if ($self->{nrcols} < 0) {
250 $self->{nrcols} = () = $row =~ /,\t/g;
251 $self->{nrcols}++;
252 }
253 $self->{active} = 1;
254 } elsif ($chars[0] eq '=') {
255 # xml result line
256 $self->{row} = substr($row, 1); # skip =
257 $self->{active} = 1;
258 } elsif ($chars[0] eq '^') {
259 # ^ redirect, ie use different server
260 } elsif ($chars[0] eq '#') {
261 # warnings etc, skip, and return what follows
262 return $self->getRow;
263 }
264 return $self->{active};
265 }
266
267 sub getBlock {
268 my ($self)= @_;
269 print "getBlock $self->{active}\n" if ($self->{trace});
270 my $block = $self->getblock();
271 @{$self->{lines}} = split(/\n/, $block);
272
273 # skip diagnostic messages before the header
274 shift @{$self->{lines}} while @{$self->{lines}} && $self->{lines}[0] =~ /\A#/;
275
276 die "implausible return from MonetDB: $self->{lines}[0]\n" if $self->{lines}[0] =~ /\A[^ -~]/;
277
278 my $header = $self->{lines}[0];
279 my @chars = split(//, $header);
280
281 $self->{id} = -1;
282 $self->{nrcols} = -1;
283 $self->{replysize} = scalar(@{$self->{lines}});
284 $self->{active} = 0;
285 $self->{skip} = 0; # next+skip is current result row
286 $self->{next} = 0; # all done
287 $self->{offset} = 0;
288 $self->{hdrs} = [];
289
290 if ($chars[0] eq '&') {
291 if ($chars[1] eq '1' || $chars[1] eq 6) {
292 if ($chars[1] eq '1') {
293 # &1 id result-count nr-cols rows-in-this-block
294 my ($dummy,$id,$cnt,$nrcols,$replysize) = split(' ', $header);
295 $self->{id} = $id;
296 $self->{count} = $cnt;
297 $self->{nrcols} = $nrcols;
298 $self->{replysize} = $replysize;
299 } else {
300 # &6 id nr-cols,rows-in-this-block,offset
301 my ($dummy,$id,$nrcols,$replysize,$offset) = split(' ', $header);
302 $self->{id} = $id;
303 $self->{nrcols} = $nrcols;
304 $self->{replysize} = $replysize;
305 $self->{offset} = $offset;
306 }
307 # for now skip table header information
308 my $i = 1;
309 while ($self->{lines}[$i] =~ /\A%/) {
310 $self->{hdrs}[$i - 1] = $self->{lines}[$i];
311 $i++;
312 }
313 $self->{skip} = $i;
314 $self->{next} = $i;
315 $self->{row} = $self->{lines}[$self->{next}++];
316
317 $self->{active} = 1;
318 } elsif ($chars[1] eq '2') { # updates
319 my ($dummy,$cnt) = split(' ', $header);
320 $self->{count} = $cnt;
321 $self->{nrcols} = 1;
322 $self->{replysize} = 1;
323 $self->{row} = "" . $cnt;
324 $self->{next} = $cnt; # all done
325 return -2;
326 } elsif ($chars[1] eq '3') { # transaction
327 # nothing todo
328 } elsif ($chars[1] eq '4') { # auto_commit
329 my ($dummy,$ac) = split(' ', $header);
330 if ($ac eq 't') {
331 $self->{auto_commit} = 1;
332 } else {
333 $self->{auto_commit} = 0;
334 }
335 } elsif ($chars[1] eq '5') { # prepare
336 my ($dummy,$id,$cnt,$nrcols,$replysize) = split(' ', $header);
337 # TODO parse result, rows (type, digits, scale)
338 $self->{count} = $cnt;
339 $self->{nrcols} = $nrcols;
340 $self->{replysize} = $replysize;
341 $self->{row} = "";
342 $self->{next} = $cnt; # all done
343 }
344 } else {
345 return $self->getRow();
346 }
347 return $self->{active};
348 }
349
350 sub getReply {
351 my ($self)= @_;
352
353 if ($self->{active} == 0) {
354 return $self->getBlock();
355 } elsif ($self->{next} < $self->{replysize} + $self->{skip}) {
356 return $self->getRow();
357 } elsif (${self}->{offset} + $self->{replysize} < $self->{count}) {
358 # get next slice
359 my $rs = $self->{replysize};
360 my $offset = $self->{offset} + $rs;
361 $self->putblock("Xexport $self->{id} $offset $rs");
362 return $self->getBlock();
363 } else {
364 # close large results, but only send on next query
365 if ($self->{id} > 0 && $self->{count} != $self->{replysize}) {
366 push @{$self->{piggyback}}, "Xclose $self->{id}";
367 $self->{skip_in}++;
368 }
369 $self->{active} = 0;
370 }
371 return $self->{active};
372
373 }
374
375 sub readFromSocket {
376 my ($self, $ref, $count) = @_;
377
378 die "invalid buffer reference" unless (ref($ref) eq 'SCALAR');
379
380 my $rcount = 0;
381 $$ref ||= "";
382
383 while ($count > 0) {
384 $rcount = $self->{socket}->sysread($$ref, $count, length($$ref));
385
386 die "read error: $!" unless (defined($rcount));
387 die "no more data on socket" if ($rcount == 0);
388
389 $count -= $rcount;
390 }
391 }
392
393 sub getblock {
394 my ($self) = @_;
395
396 # now read back the same way
397 my $result = "";
398 my $last_block = 0;
399 do {
400 my $flag;
401
402 $self->readFromSocket(\$flag, 2); # read block info
403
404 my $unpacked = unpack( 'v', $flag ); # unpack (little endian short)
405 my $len = ( $unpacked >> 1 ); # get length
406 $last_block = $unpacked & 1; # get last-block-flag
407
408 print "getblock: $last_block $len\n" if ($self->{trace});
409 if ($len > 0 ) {
410 my $data;
411 $self->readFromSocket(\$data, $len); # read
412 $result .= $data;
413 print "getblock: $data\n" if ($self->{trace});
414 }
415 } while ( !$last_block );
416 print "IN:\n$result\n" if $ENV{MAPI_TRACE};
417
418 if ($self->{skip_in}) {
419 $self->{skip_in}--;
420 goto &getblock;
421 }
422
423 return $result;
424 }
425
426 sub putblock {
427 my $self = shift;
428
429 # there maybe something in the piggyback buffer
430 my @blocks = (\(@{ $self->{piggyback} }), \(@_));
431 @{ $self->{piggyback} } = ();
432
433 # create blocks of data with max 0xffff length,
434 # then loop over the data and send it.
435 my $out = '';
436 for my $blk (@blocks) {
437 print "OUT:\n$$blk\n" if $ENV{MAPI_TRACE};
438 utf8::downgrade($$blk); # deny wide chars
439 my $pos = 0;
440 my $last_block = 0;
441 my $blocksize = 0x7fff >> 1; # max len per block
442 my $data;
443
444 while ( !$last_block ) {
445 my $data = substr($$blk, 0, $blocksize, "");
446 my $len = length($data);
447 # set last-block-flag
448 $last_block = 1 if !length $$blk;
449 my $flag = pack( 'v', ( $len << 1 ) + $last_block );
450 print "putblock: $last_block ".$data."\n" if ($self->{trace});
451 $out .= $flag . $data;
452 }
453 }
454 $self->{socket}->syswrite($out); #send it
455 }
456
457 1;
458
459 # vim: set ts=2 sw=2 expandtab: