Mercurial > hg > monetdb-perl

comparison Mapi.pm @ 0:cedccb7e0143

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