melo / bitflu

A Perl-based Bittorrent client

This URL has Read+Write access

bitflu / bitflu.pl
raw normal view history
3b5c9a66 » pab 2007-08-25 initial import 1 #!/usr/bin/perl -w
2 #
1b40ad37 » pab 2008-04-20 Schedule command and apiver... 3 # This file is part of 'Bitflu' - (C) 2006-2008 Adrian Ulrich
3b5c9a66 » pab 2007-08-25 initial import 4 #
5 # Released under the terms of The "Artistic License 2.0".
6 # http://www.perlfoundation.org/legal/licenses/artistic-2_0.txt
7 #
8
9 use strict;
10 use Data::Dumper;
752a0239 » pab 2007-11-25 Some cosmetic fixes and get... 11 use Getopt::Long;
3b5c9a66 » pab 2007-08-25 initial import 12
30afc404 » pab 2007-12-18 Added read-loop 13
bb56c9de » pab 2007-09-08 added renice option and som... 14 my $bitflu_run = undef; # Start as not_running and not_killed
752a0239 » pab 2007-11-25 Some cosmetic fixes and get... 15 my $getopts = { help => undef, config => '.bitflu.config', version => undef };
bb56c9de » pab 2007-09-08 added renice option and som... 16 $SIG{PIPE} = $SIG{CHLD} = 'IGNORE';
17 $SIG{INT} = $SIG{HUP} = $SIG{TERM} = \&HandleShutdown;
18
84c866d7 » pab 2008-02-15 daemon and logfile support 19 GetOptions($getopts, "help|h", "version", "plugins", "config=s", "daemon") or exit 1;
20 if($getopts->{help}) { die "Usage: $0 [--config=.bitflu.config --version --help --plugins --daemon]\n"; }
752a0239 » pab 2007-11-25 Some cosmetic fixes and get... 21
22
bb56c9de » pab 2007-09-08 added renice option and som... 23 # -> Create bitflu object
752a0239 » pab 2007-11-25 Some cosmetic fixes and get... 24 my $bitflu = Bitflu->new(configuration_file=>$getopts->{config}) or Carp::confess("Unable to create Bitflu Object");
25 if($getopts->{version}) { die $bitflu->_Command_Version->{MSG}->[0]->[1]."\n" }
26
27 my @loaded_plugins = $bitflu->LoadPlugins('Bitflu');
28 if($getopts->{plugins}) {
29 print "# Loaded Plugins: (from ".$bitflu->Configuration->GetValue('plugindir').")\n";
59365da4 » pab 2007-12-17 BitTorrent::run rewrite, so... 30 foreach (@loaded_plugins) { printf("File %-35s provides: %s\n", $_->{file}, $_->{package}); }
752a0239 » pab 2007-11-25 Some cosmetic fixes and get... 31 exit(0);
32 }
84c866d7 » pab 2008-02-15 daemon and logfile support 33 elsif($getopts->{daemon}) {
34 $bitflu->Daemonize();
35 }
752a0239 » pab 2007-11-25 Some cosmetic fixes and get... 36
bb56c9de » pab 2007-09-08 added renice option and som... 37 $bitflu->SysinitProcess();
25c08197 » pab 2008-05-24 The storage-plugin should n... 38 $bitflu->SetupDirectories();
3b5c9a66 » pab 2007-08-25 initial import 39 $bitflu->InitPlugins();
e6b5ae79 » pab 2007-09-15 Added command completition 40 $bitflu->PreloopInit();
1f6a66db » pab 2007-09-09 plugins is no longer a conf... 41
bb56c9de » pab 2007-09-08 added renice option and som... 42 $bitflu_run = 1 if !defined($bitflu_run); # Enable mainloop and sighandler if we are still not_killed
3b5c9a66 » pab 2007-08-25 initial import 43
84c866d7 » pab 2008-02-15 daemon and logfile support 44
45
bb56c9de » pab 2007-09-08 added renice option and som... 46 while($bitflu_run == 1) {
bfb43a2a » pab 2008-09-07 Bump apiversion due to _Run... 47 my $NOW = $bitflu->Network->GetTime;
48 foreach my $rx (@{$bitflu->{_Runners}}) {
49 next if $rx->{runat} > $NOW;
50 $rx->{runat} = $NOW + $rx->{target}->run();
3b5c9a66 » pab 2007-08-25 initial import 51 }
c664d5a6 » pab 2007-12-19 More cleanups 52 select(undef,undef,undef,$bitflu->Configuration->GetValue('sleeper'));
3b5c9a66 » pab 2007-08-25 initial import 53 }
54
b5c4ffa6 » pab 2008-01-18 Fixed a crashbug and save b... 55 $bitflu->Storage->terminate;
56
752a0239 » pab 2007-11-25 Some cosmetic fixes and get... 57 $bitflu->info("-> Shutdown completed after running for ".(int(time())-$bitflu->{_BootTime})." seconds");
bb56c9de » pab 2007-09-08 added renice option and som... 58 exit(0);
3b5c9a66 » pab 2007-08-25 initial import 59
60
bb56c9de » pab 2007-09-08 added renice option and som... 61 sub HandleShutdown {
62 my($sig) = @_;
63 if(defined($bitflu_run) && $bitflu_run == 1) {
64 # $bitflu is running, so we can use ->info
65 $bitflu->info("-> Starting shutdown... (signal $sig received)");
66 }
5dfdd76f » pab 2007-12-17 New config options 67 else {
68 print "-> Starting shutdown... (signal $sig received), please wait...\n";
69 }
bb56c9de » pab 2007-09-08 added renice option and som... 70 $bitflu_run = 0; # set it to not_running and killed
71 }
72
752a0239 » pab 2007-11-25 Some cosmetic fixes and get... 73
74
3b5c9a66 » pab 2007-08-25 initial import 75 package Bitflu;
76 use strict;
77 use Carp;
37de81bf » pab 2008-08-24 Api-Version bump and versio... 78 use constant V_MAJOR => '0';
06f6784e » pab 2008-10-12 Version bump 79 use constant V_MINOR => '61';
37de81bf » pab 2008-08-24 Api-Version bump and versio... 80 use constant V_STABLE => 0;
81 use constant V_TYPE => ( V_STABLE ? 'stable' : 'devel' );
82 use constant VERSION => V_MAJOR.'.'.V_MINOR.'-'.V_TYPE;
3a9518d5 » pab 2008-10-22 Implemented a sysread() wra... 83 use constant APIVER => 20081022;
37de81bf » pab 2008-08-24 Api-Version bump and versio... 84 use constant LOGBUFF => 0xFF;
3b5c9a66 » pab 2007-08-25 initial import 85
86 ##########################################################################
87 # Create a new Bitflu-'Dispatcher' object
88 sub new {
89 my($class, %args) = @_;
90 my $self = {};
91 bless($self, $class);
b36be24e » pab 2008-03-24 Made config-parser generic 92 $self->{_LogFH} = *STDOUT; # Must be set ASAP
caedb01c » pab 2008-06-29 log command implemented 93 $self->{_LogBuff} = []; # Empty at startup
b36be24e » pab 2008-03-24 Made config-parser generic 94 $self->{Core}->{Tools} = Bitflu::Tools->new(super => $self); # Tools is also loaded ASAP because ::Configuration needs it
3b5c9a66 » pab 2007-08-25 initial import 95 $self->{Core}->{Configuration} = Bitflu::Configuration->new(super=>$self, configuration_file => $args{configuration_file});
96 $self->{Core}->{Network} = Bitflu::Network->new(super => $self);
97 $self->{Core}->{AdminDispatch} = Bitflu::Admin->new(super => $self);
98 $self->{Core}->{QueueMgr} = Bitflu::QueueMgr->new(super => $self);
99 $self->{_Runners} = ();
100 $self->{_BootTime} = time();
1f6a66db » pab 2007-09-09 plugins is no longer a conf... 101 $self->{_Plugins} = ();
3b5c9a66 » pab 2007-08-25 initial import 102 return $self;
103 }
104
105 ##########################################################################
37de81bf » pab 2008-08-24 Api-Version bump and versio... 106 # Return internal version
107 sub GetVersion {
108 my($self) = @_;
109 return(V_MAJOR, V_MINOR, V_STABLE);
110 }
111
112 ##########################################################################
113 # Return internal version as string
114 sub GetVersionString {
115 my($self) = @_;
116 return VERSION;
117 }
118
119 ##########################################################################
3b5c9a66 » pab 2007-08-25 initial import 120 # Call hardcoded configuration plugin
121 sub Configuration {
122 my($self) = @_;
123 return $self->{Core}->{Configuration};
124 }
125
126 ##########################################################################
4697a0af » pab 2007-12-26 Added very unpolished magne... 127 # Call hardcoded tools plugin
128 sub Tools {
33a74a49 » pab 2007-12-22 Implemented Digest-Dispatcher 129 my($self) = @_;
4697a0af » pab 2007-12-26 Added very unpolished magne... 130 return $self->{Core}->{Tools};
33a74a49 » pab 2007-12-22 Implemented Digest-Dispatcher 131 }
132
133 ##########################################################################
3b5c9a66 » pab 2007-08-25 initial import 134 # Call hardcoded Network IO plugin
135 sub Network {
136 my($self) = @_;
137 return $self->{Core}->{Network};
138 }
139
140 ##########################################################################
141 # Call hardcoded Admin plugin
142 sub Admin {
143 my($self) = @_;
144 return $self->{Core}->{AdminDispatch};
145 }
146
147 ##########################################################################
148 # Call hardcoded Queue plugin
149 sub Queue {
150 my($self) = @_;
151 return $self->{Core}->{QueueMgr};
152 }
153
154 ##########################################################################
155 # Call currently loaded storage plugin
156 sub Storage {
157 my($self) = @_;
158 return $self->{Plugin}->{Storage};
159 }
160
161 ##########################################################################
162 # Let bitflu run the given target
163 sub AddRunner {
164 my($self,$target) = @_;
bfb43a2a » pab 2008-09-07 Bump apiversion due to _Run... 165 push(@{$self->{_Runners}}, {target=>$target, runat=>0});
3b5c9a66 » pab 2007-08-25 initial import 166 }
167
168
169 ##########################################################################
170 # Register the exclusive storage plugin
171 sub AddStorage {
172 my($self,$target) = @_;
173 if(defined($self->{Plugin}->{Storage})) { $self->panic("Unable to register additional storage driver '$target' !"); }
174 $self->{Plugin}->{Storage} = $target;
175 $self->debug("AddStorage($target)");
176 return 1;
177 }
178
1f6a66db » pab 2007-09-09 plugins is no longer a conf... 179
180
3b5c9a66 » pab 2007-08-25 initial import 181 ##########################################################################
182 # Loads all plugins from 'plugins' directory but does NOT init them
183 sub LoadPlugins {
1f6a66db » pab 2007-09-09 plugins is no longer a conf... 184 my($self,$xclass) = @_;
3b5c9a66 » pab 2007-08-25 initial import 185 #
186 unshift(@INC, $self->Configuration->GetValue('plugindir'));
d2039c3b » pab 2008-01-02 pluginexclude setting 187
1f6a66db » pab 2007-09-09 plugins is no longer a conf... 188 my $pdirpath = $self->Configuration->GetValue('plugindir')."/$xclass";
189 my @plugins = ();
d2039c3b » pab 2008-01-02 pluginexclude setting 190 my %exclude = (map { $_ => 1} split(/;/,$self->Configuration->GetValue('pluginexclude')));
1f6a66db » pab 2007-09-09 plugins is no longer a conf... 191
59365da4 » pab 2007-12-17 BitTorrent::run rewrite, so... 192 opendir(PLUGINS, $pdirpath) or $self->stop("Unable to read directory '$pdirpath' : $!");
1f6a66db » pab 2007-09-09 plugins is no longer a conf... 193 foreach my $dirent (sort readdir(PLUGINS)) {
d2039c3b » pab 2008-01-02 pluginexclude setting 194 next unless my($pfile, $porder, $pmodname) = $dirent =~ /^((\d\d)_(.+)\.pm)$/i;
326b02a0 » pab 2008-05-31 0.50 stable 195
d2039c3b » pab 2008-01-02 pluginexclude setting 196 if($exclude{$pfile}) {
197 $self->info("Skipping disabled plugin '$pfile -> $pmodname'");
198 }
326b02a0 » pab 2008-05-31 0.50 stable 199 elsif($porder eq '00' && $pmodname ne $self->Configuration->GetValue('storage')) {
200 $self->debug("Skipping unconfigured storage plugin '$dirent'");
201 }
d2039c3b » pab 2008-01-02 pluginexclude setting 202 else {
203 push(@plugins, {file=>$pfile, order=>$porder, class=>$xclass, modname=>$pmodname, package=>$xclass."::".$3});
204 $self->debug("Found plugin $plugins[-1]->{package} in folder $pdirpath");
205 }
1f6a66db » pab 2007-09-09 plugins is no longer a conf... 206 }
207 close(PLUGINS);
208
209 $self->{_Plugins} = \@plugins;
210
211 foreach my $plugin (@{$self->{_Plugins}}) {
fbf219f9 » pab 2007-09-16 Renamed all plugins to supp... 212 my $fname = $plugin->{class}."/".$plugin->{file};
213 $self->debug("Loading $fname");
3b5c9a66 » pab 2007-08-25 initial import 214 eval { require $fname; };
215 if($@) {
1f6a66db » pab 2007-09-09 plugins is no longer a conf... 216 my $perr = $@; chomp($perr);
38c04065 » pab 2008-04-19 Web and telnet patches 217 $self->yell("Unable to load plugin '$fname', error was: '$perr'");
59365da4 » pab 2007-12-17 BitTorrent::run rewrite, so... 218 $self->stop(" -> Please fix or remove this broken plugin file from $pdirpath");
3b5c9a66 » pab 2007-08-25 initial import 219 }
ce8a1baa » pab 2008-02-16 Added APIVERSION 220 my $this_apiversion = $plugin->{package}->_BITFLU_APIVERSION;
221 if($this_apiversion != APIVER) {
222 $self->yell("Plugin '$fname' has an invalid API-Version ( (\$apivers = $this_apiversion) != (\$expected = ".APIVER.") )");
223 $self->yell("HINT: Maybe you forgot to replace the plugins at $pdirpath while upgrading bitflu?!...");
224 $self->stop("-> Exiting due to APIVER mismatch");
225 }
3b5c9a66 » pab 2007-08-25 initial import 226 }
752a0239 » pab 2007-11-25 Some cosmetic fixes and get... 227 return @plugins;
3b5c9a66 » pab 2007-08-25 initial import 228 }
229
230 ##########################################################################
231 # Startup all plugins
232 sub InitPlugins {
233 my($self) = @_;
234
235 my @TO_INIT = ();
1f6a66db » pab 2007-09-09 plugins is no longer a conf... 236 foreach my $plugin (@{$self->{_Plugins}}) {
fbf219f9 » pab 2007-09-16 Renamed all plugins to supp... 237 $self->debug("Registering '$plugin->{package}'");
238 my $this_plugin = $plugin->{package}->register($self) or $self->panic("Regsitering '$plugin' failed, aborting");
239 push(@TO_INIT, {name=>$plugin->{package}, ref=>$this_plugin});
3b5c9a66 » pab 2007-08-25 initial import 240 }
241 foreach my $toinit (@TO_INIT) {
242 $self->debug("Firing up '$toinit->{name}'");
243 $toinit->{ref}->init() or $self->panic("Unable to init plugin : $!");
244 }
245 foreach my $coreplug (sort keys(%{$self->{Core}})) {
246 $self->debug("Starting Core-Plugin '$coreplug'");
247 $self->{Core}->{$coreplug}->init() or $self->panic("Unable to init Core-Plugin : $!");
248 }
249 }
250
bb56c9de » pab 2007-09-08 added renice option and som... 251 ##########################################################################
25c08197 » pab 2008-05-24 The storage-plugin should n... 252 # Build some basic directory structure
253 sub SetupDirectories {
254 my($self) =@_;
255 my $workdir = $self->Configuration->GetValue('workdir') or $self->panic("No workdir configured");
256 my $tmpdir = $self->Configuration->GetValue('tempdir') or $self->panic("No tempdir configured");
257 $tmpdir = $workdir."/".$tmpdir;
258 foreach my $this_dir ($workdir, $tmpdir) {
259 unless(-d $this_dir) {
260 $self->debug("mkdir($this_dir)");
261 mkdir($this_dir) or $self->stop("Unable to create directory '$this_dir' : $!");
262 }
263 }
264 }
265
266 ##########################################################################
bb56c9de » pab 2007-09-08 added renice option and som... 267 # Change nice level, chroot and drop privileges
268 sub SysinitProcess {
3b5c9a66 » pab 2007-08-25 initial import 269 my($self) = @_;
270
271 my $chroot = $self->Configuration->GetValue('chroot');
1b3c39c3 » pab 2007-12-22 Beautify telnet 272 my $uid = int($self->Configuration->GetValue('runas_uid') || 0);
273 my $gid = int($self->Configuration->GetValue('runas_gid') || 0);
274 my $renice = int($self->Configuration->GetValue('renice') || 0);
84c866d7 » pab 2008-02-15 daemon and logfile support 275 my $outlog = ($self->Configuration->GetValue('logfile') || '');
276
277
278 if(length($outlog) > 0) {
279 open(LFH, ">>", $outlog) or $self->stop("Cannot write to logfile '$outlog' : $!");
280 $self->{_LogFH} = *LFH;
281 $self->{_LogFH}->autoflush(1);
282 $self->yell("Logging to '$outlog'");
283 }
284
3b5c9a66 » pab 2007-08-25 initial import 285
bb56c9de » pab 2007-09-08 added renice option and som... 286 # Lock values because we cannot change them after we finished
287 foreach my $lockme qw(runas_uid runas_gid chroot) {
288 $self->Configuration->RuntimeLockValue($lockme);
289 }
290
291
292 # -> Set niceness (This is done before dropping root to get negative values working)
293 if($renice) {
294 $renice = ($renice > 19 ? 19 : ($renice < -20 ? -20 : $renice) ); # Stop funny stuff...
295 $self->info("Setting my own niceness to $renice");
296 POSIX::nice($renice) or $self->warn("nice($renice) failed: $!");
297 }
298
299 # -> Chroot
3b5c9a66 » pab 2007-08-25 initial import 300 if(defined($chroot)) {
301 $self->info("Chrooting into '$chroot'");
302 Carp::longmess("FULLY_LOADING_CARP");
303 chdir($chroot) or $self->panic("Cannot change into directory '$chroot' : $!");
304 chroot($chroot) or $self->panic("Cannot chroot into directory '$chroot' (are you root?) : $!");
305 chdir('/') or $self->panic("Unable to change into new chroot topdir: $!");
306 }
307
bb56c9de » pab 2007-09-08 added renice option and som... 308 # -> Drop group privileges
3b5c9a66 » pab 2007-08-25 initial import 309 if($gid) {
310 $self->info("Changing gid to $gid");
311 $! = undef;
312 $) = "$gid $gid";
313 $self->panic("Unable to set EGID: $!") if $!;
314 $( = "$gid";
315 $self->panic("Unable to set GID: $!") if $!;
316 }
317
bb56c9de » pab 2007-09-08 added renice option and som... 318 # -> Drop user privileges
3b5c9a66 » pab 2007-08-25 initial import 319 if($uid) {
320 $self->info("Changing uid to $uid");
321 POSIX::setuid($uid) or $self->panic("Unable to change UID: $!");
322 }
323
bb56c9de » pab 2007-09-08 added renice option and som... 324 # -> Check if we are still root. We shouldn't.
3b5c9a66 » pab 2007-08-25 initial import 325 if($> == 0 or $) == 0) {
326 $self->warn("Refusing to run with root privileges. Do not start $0 as root unless you are using");
327 $self->warn("the chroot option. In this case you must also specify the options runas_uid & runas_gid");
59365da4 » pab 2007-12-17 BitTorrent::run rewrite, so... 328 $self->stop("Bitflu refuses to run as root");
3b5c9a66 » pab 2007-08-25 initial import 329 }
330
331 $self->info("$0 is running with pid $$ ; uid = ($>|$<) / gid = ($)|$()");
332 }
333
334
e6b5ae79 » pab 2007-09-15 Added command completition 335 ##########################################################################
336 # This should get called after starting the mainloop
337 # The subroutine does the same as a 'init' in a plugin
338 sub PreloopInit {
339 my($self) = @_;
340 $self->Admin->RegisterCommand('die' , $self, '_Command_Shutdown' , 'Terminates bitflu');
341 $self->Admin->RegisterCommand('version' , $self, '_Command_Version' , 'Displays bitflu version string');
342 $self->Admin->RegisterCommand('date' , $self, '_Command_Date' , 'Displays current time and date');
343 }
1f6a66db » pab 2007-09-09 plugins is no longer a conf... 344
84c866d7 » pab 2008-02-15 daemon and logfile support 345 sub Daemonize {
346 my($self) = @_;
347 $self->info("Backgrounding");
348 my $child = fork();
349
350 if(!defined($child)) {
351 die "Unable to fork: $!\n";
352 }
353 elsif($child != 0) {
354 $self->yell("Bitflu is running with pid $child");
355 exit(0);
356 }
357 }
1f6a66db » pab 2007-09-09 plugins is no longer a conf... 358
e6b5ae79 » pab 2007-09-15 Added command completition 359 ##########################################################################
360 # bye!
361 sub _Command_Shutdown {
362 my($self) = @_;
363 kill(2,$$);
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 364 return {MSG=>[ [1, "Shutting down $0 (with pid $$)"] ], SCRAP=>[]};
e6b5ae79 » pab 2007-09-15 Added command completition 365 }
366
367 ##########################################################################
368 # Return version string
369 sub _Command_Version {
370 my($self) = @_;
9cf2543f » pab 2008-02-24 remove sysinfo command 371 my $uptime = ( ($self->Network->GetTime - $self->{_BootTime}) / 60);
0e1c6b12 » pab 2008-08-30 beautify 372 return {MSG=>[ [1, sprintf("This is Bitflu %s (API:%s) running on Perl %vd. Uptime: %.3f minutes (%s)",$self->GetVersionString,
373 APIVER, $^V, $uptime, "".localtime($self->{_BootTime}) )] ], SCRAP=>[]};
e6b5ae79 » pab 2007-09-15 Added command completition 374 }
375
376 ##########################################################################
377 # Return version string
378 sub _Command_Date {
379 my($self) = @_;
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 380 return {MSG=>[ [1, "".localtime()] ], SCRAP=>[]};
e6b5ae79 » pab 2007-09-15 Added command completition 381 }
382
84c866d7 » pab 2008-02-15 daemon and logfile support 383 ##########################################################################
384 # Printout logmessage
385 sub _xlog {
386 my($self, $msg, $force_stdout) = @_;
caedb01c » pab 2008-06-29 log command implemented 387 my $rmsg = localtime()." # $msg\n";
388 my $xfh = $self->{_LogFH};
389 my $lbuff = $self->{_LogBuff};
390
84c866d7 » pab 2008-02-15 daemon and logfile support 391 print $xfh $rmsg;
392
393 if($force_stdout && $xfh ne *STDOUT) {
394 print STDOUT $rmsg;
395 }
caedb01c » pab 2008-06-29 log command implemented 396
397 push(@$lbuff, $rmsg);
398 shift(@$lbuff) if int(@$lbuff) >= LOGBUFF;
84c866d7 » pab 2008-02-15 daemon and logfile support 399 }
400
401 sub info { my($self,$msg) = @_; return if $self->Configuration->GetValue('loglevel') < 4; $self->_xlog($msg); }
402 sub debug { my($self,$msg) = @_; return if $self->Configuration->GetValue('loglevel') < 10; $self->_xlog(" ** DEBUG ** $msg"); }
403 sub warn { my($self,$msg) = @_; return if $self->Configuration->GetValue('loglevel') < 2; $self->_xlog("** WARNING ** $msg"); }
404 sub yell { my($self,$msg) = @_; $self->_xlog($msg,1); }
405 sub stop { my($self,$msg) = @_; $self->yell("EXITING # $msg"); exit(1); }
3b5c9a66 » pab 2007-08-25 initial import 406 sub panic {
407 my($self,$msg) = @_;
84c866d7 » pab 2008-02-15 daemon and logfile support 408 $self->yell("--------- BITFLU SOMEHOW MANAGED TO CRASH ITSELF; PANIC MESSAGE: ---------");
409 $self->yell($msg);
410 $self->yell("--------- BACKTRACE START ---------");
411 $self->yell(Carp::longmess());
412 $self->yell("---------- BACKTRACE END ----------");
413
414 $self->yell("SHA1-Module used : ".$self->Tools->{mname});
415 $self->yell("Perl Version : ".sprintf("%vd", $^V));
416 $self->yell("Perl Execname : ".$^X);
417 $self->yell("OS-Name : ".$^O);
418 $self->yell("Running since : ".gmtime($self->{_BootTime}));
419 $self->yell("---------- LOADED PLUGINS ---------");
d2039c3b » pab 2008-01-02 pluginexclude setting 420 foreach my $plug (@{$self->{_Plugins}}) {
84c866d7 » pab 2008-02-15 daemon and logfile support 421 $self->yell(sprintf("%-32s -> %s",$plug->{file}, $plug->{package}));
d2039c3b » pab 2008-01-02 pluginexclude setting 422 }
84c866d7 » pab 2008-02-15 daemon and logfile support 423 $self->yell("##################################");
3b5c9a66 » pab 2007-08-25 initial import 424 exit(1);
425 }
426
427
428 1;
429
430
431 ####################################################################################################################################################
432 ####################################################################################################################################################
433 # Bitflu Queue manager
434 #
435 package Bitflu::QueueMgr;
a6c39744 » pab 2008-03-21 added history support 436
3b5c9a66 » pab 2007-08-25 initial import 437 use constant SHALEN => 40;
a6c39744 » pab 2008-03-21 added history support 438 use constant HPFX => 'history_';
439
3b5c9a66 » pab 2007-08-25 initial import 440 sub new {
441 my($class, %args) = @_;
442 my $self = {super=> $args{super}};
443 bless($self,$class);
444 return $self;
445 }
446
447 ##########################################################################
448 # Inits plugin: This resumes all found storage items
449 sub init {
450 my($self) = @_;
451 my $queueIds = $self->{super}->Storage->GetStorageItems();
452 my $runners = $self->GetRunnersRef();
453
454 foreach my $sid (@$queueIds) {
9c5f3648 » pab 2007-12-23 Storage Checking 455 $self->info("Resuming download $sid, this may take a few seconds...");
3b5c9a66 » pab 2007-08-25 initial import 456 my $this_storage = $self->{super}->Storage->OpenStorage($sid) or $self->panic("Unable to open storage for sid $sid");
457 my $owner = $this_storage->GetSetting('owner');
458 if(defined($owner) && defined($runners->{$owner})) {
459 $runners->{$owner}->resume_this($sid);
460 }
461 else {
462 $self->panic("StorageObject $sid is owned by '$owner', but plugin is not loaded/registered correctly");
463 }
464 }
bbbbb5fc » pab 2007-09-01 Added autocommit/autocancel... 465 $self->{super}->Admin->RegisterCommand('rename' , $self, 'admincmd_rename', 'Renames a download',
466 [ [undef, "Renames a download"], [undef, "Usage: rename queue_id \"New Name\""] ]);
467 $self->{super}->Admin->RegisterCommand('cancel' , $self, 'admincmd_cancel', 'Removes a file from the download queue',
468 [ [undef, "Removes a file from the download queue"], [undef, "Usage: cancel queue_id [queue_id2 ...]"] ]);
a6c39744 » pab 2008-03-21 added history support 469
470 $self->{super}->Admin->RegisterCommand('history' , $self, 'admincmd_history', 'Manages download history',
471 [ [undef, "Manages internal download history"], [undef, ''],
472 [undef, "Usage: history [ queue_id [show forget] ] [list]"], [undef, ''],
473 [undef, "history list : List all remembered downloads"],
474 [undef, "history queue_id show : Shows details about queue_id"],
475 [undef, "history queue_id forget : Removes history of queue_id"],
476 ]);
477
7dfb0491 » pab 2008-07-17 Moved pause feature to Queu... 478 $self->{super}->Admin->RegisterCommand('pause' , $self, 'admincmd_pause', 'Stops a download',
479 [ [undef, "Stop given download"], [undef, ''],
480 [undef, "Usage: pause queue_id [queue_id2 ...]"], [undef, ''],
481 ]);
482
483 $self->{super}->Admin->RegisterCommand('resume' , $self, 'admincmd_resume', 'Resumes a paused download',
484 [ [undef, "Resumes a paused download"], [undef, ''],
485 [undef, "Usage: resume queue_id [queue_id2 ...]"], [undef, ''],
486 ]);
487
37de81bf » pab 2008-08-24 Api-Version bump and versio... 488 $self->info("--- startup completed: bitflu ".$self->{super}->GetVersionString." is ready ---");
3b5c9a66 » pab 2007-08-25 initial import 489 return 1;
490 }
491
7dfb0491 » pab 2008-07-17 Moved pause feature to Queu... 492
493 ##########################################################################
494 # Pauses a download
495 sub admincmd_pause {
496 my($self, @args) = @_;
497
498 my @MSG = ();
499 my $NOEXEC = '';
500
501 if(int(@args)) {
502 foreach my $cid (@args) {
503 my $so = $self->{super}->Storage->OpenStorage($cid);
504 if($so) {
505 $so->SetSetting('_paused', 1);
506 push(@MSG, [1, "$cid: download paused"]);
507 }
508 else {
509 push(@MSG, [2, "$cid: does not exist in queue, cannot pause"]);
510 }
511 }
512 }
513 else {
514 $NOEXEC .= 'Usage: pause queue_id';
515 }
516 return({MSG=>\@MSG, SCRAP=>[], NOEXEC=>$NOEXEC});
517 }
518
519 ##########################################################################
520 # Resumes a download
521 sub admincmd_resume {
522 my($self, @args) = @_;
523
524 my @MSG = ();
525 my $NOEXEC = '';
526
527 if(int(@args)) {
528 foreach my $cid (@args) {
529 my $so = $self->{super}->Storage->OpenStorage($cid);
530 if($so) {
531 $so->SetSetting('_paused', 0);
532 push(@MSG, [1, "$cid: download resumed"]);
533 }
534 else {
535 push(@MSG, [2, "$cid: does not exist in queue, cannot resume"]);
536 }
537 }
538 }
539 else {
540 $NOEXEC .= 'Usage: resume queue_id';
541 }
542 return({MSG=>\@MSG, SCRAP=>[], NOEXEC=>$NOEXEC});
543 }
544
545
3b5c9a66 » pab 2007-08-25 initial import 546 ##########################################################################
547 # Cancel a queue item
548 sub admincmd_cancel {
549 my($self, @args) = @_;
550
551 my $runners = $self->GetRunnersRef();
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 552 my @MSG = ();
553 my $NOEXEC = '';
752a0239 » pab 2007-11-25 Some cosmetic fixes and get... 554
555 if(int(@args)) {
556 foreach my $cid (@args) {
557 my $storage = $self->{super}->Storage->OpenStorage($cid);
558 if($storage) {
559 my $owner = $storage->GetSetting('owner');
560 if(defined($owner) && defined($runners->{$owner})) {
a6c39744 » pab 2008-03-21 added history support 561 $self->ModifyHistory($cid, Canceled=>'');
752a0239 » pab 2007-11-25 Some cosmetic fixes and get... 562 $runners->{$owner}->cancel_this($cid);
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 563 push(@MSG, [1, "'$cid' canceled"]);
752a0239 » pab 2007-11-25 Some cosmetic fixes and get... 564 }
565 else {
566 $self->panic("'$cid' has no owner, cannot cancel!");
567 }
3b5c9a66 » pab 2007-08-25 initial import 568 }
569 else {
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 570 push(@MSG, [2, "'$cid' not removed from queue: No such item"]);
3b5c9a66 » pab 2007-08-25 initial import 571 }
572 }
573 }
752a0239 » pab 2007-11-25 Some cosmetic fixes and get... 574 else {
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 575 $NOEXEC .= 'Usage: cancel queue_id [queue_id2 ...]';
752a0239 » pab 2007-11-25 Some cosmetic fixes and get... 576 }
577
578
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 579 return({MSG=>\@MSG, SCRAP=>[], NOEXEC=>$NOEXEC});
3b5c9a66 » pab 2007-08-25 initial import 580 }
581
582 ##########################################################################
583 # Rename a queue item
584 sub admincmd_rename {
585 my($self, @args) = @_;
586
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 587 my $sha = $args[0];
588 my $name = $args[1];
589 my @MSG = ();
590 my $NOEXEC = '';
3b5c9a66 » pab 2007-08-25 initial import 591
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 592 if(!defined($name)) {
593 $NOEXEC .= "Usage: rename queue_id \"New Name\"";
3b5c9a66 » pab 2007-08-25 initial import 594 }
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 595 elsif(my $storage = $self->{super}->Storage->OpenStorage($sha)) {
596 $storage->SetSetting('name', $name);
597 push(@MSG, [1, "Renamed $sha into '$name'"]);
3b5c9a66 » pab 2007-08-25 initial import 598 }
599 else {
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 600 push(@MSG, [2, "Unable to rename $sha: queue_id does not exist"]);
3b5c9a66 » pab 2007-08-25 initial import 601 }
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 602 return({MSG=>\@MSG, SCRAP=>[], NOEXEC=>$NOEXEC});
3b5c9a66 » pab 2007-08-25 initial import 603 }
604
605 ##########################################################################
a6c39744 » pab 2008-03-21 added history support 606 # Manages download history
607 sub admincmd_history {
608 my($self,@args) = @_;
609
610 my $sha = ($args[0] || '');
611 my $cmd = ($args[1] || '');
612 my @MSG = ();
613 my $NOEXEC = '';
614 my $hpfx = HPFX;
615 my $hkey = $hpfx.$sha;
616 my $strg = $self->{super}->Storage;
617
618 if($sha eq 'list') {
619 my @cbl = $strg->ClipboardList;
620 my $cbi = 0;
621 foreach my $item (@cbl) {
622 if(my($this_sid) = $item =~ /^$hpfx(.+)$/) {
623 my $ll = "$1 : ".substr($self->GetHistory($this_sid)->{Name},0,64);
624 push(@MSG, [ ($strg->OpenStorage($this_sid) ? 1 : 5 ), $ll]);
625 $cbi++;
626 }
627 }
628 push(@MSG, [1, "$cbi item".($cbi == 1 ? '' : 's')." stored in history"]);
629 }
630 elsif(length($sha)) {
631 if(my $ref = $self->GetHistory($sha)) {
632 if($cmd eq 'show') {
c9743480 » pab 2008-08-17 HTTP-UI fixes 633 foreach my $k (sort keys(%$ref)) {
a6c39744 » pab 2008-03-21 added history support 634 push(@MSG,[1, sprintf("%20s -> %s",$k,$ref->{$k})]);
635 }
636 }
637 elsif($cmd eq 'forget') {
638 $strg->ClipboardRemove($hkey);
639 push(@MSG, [1, "history for $sha has been removed"]);
640 }
641 else {
642 push(@MSG, [2, "unknown subcommand, see 'help history'"]);
643 }
644 }
645 else {
646 push(@MSG, [2,"queue item $sha has no history"]);
647 }
648 }
649 else {
650 push(@MSG, [2,"See 'help history'"]);
651 }
652
653 return({MSG=>\@MSG, SCRAP=>[], NOEXEC=>$NOEXEC});
654 }
655
656 ##########################################################################
3b5c9a66 » pab 2007-08-25 initial import 657 # Add a new item to queue (Also creates a new storage)
658 sub AddItem {
659 my($self, %args) = @_;
660
661 my $name = $args{Name};
662 my $chunks = $args{Chunks} or $self->panic("No chunks?!");
663 my $size = $args{Size};
664 my $overst = $args{Overshoot};
665 my $flayout = $args{FileLayout} or $self->panic("FileLayout missing");
4697a0af » pab 2007-12-26 Added very unpolished magne... 666 my $shaname = ($args{ShaName} || unpack("H*", $self->{super}->Tools->sha1($name)));
3b5c9a66 » pab 2007-08-25 initial import 667 my $owner = ref($args{Owner}) or $self->panic("No owner?");
a6c39744 » pab 2008-03-21 added history support 668 my $sobj = 0;
73a3d7ec » pab 2008-05-12 Added option to disable the... 669 my $history = $self->{super}->Configuration->GetValue('history');
3b5c9a66 » pab 2007-08-25 initial import 670
671 if($size == 0 && $chunks != 1) {
672 $self->panic("Sorry: You can not create a dynamic storage with multiple chunks ($chunks != 1)");
673 }
674 if(!defined($name)) {
675 $self->panic("AddItem needs a name!");
676 }
677 if(length($shaname) != SHALEN) {
678 $self->panic("Invalid shaname: $shaname");
679 }
680
681
a6c39744 » pab 2008-03-21 added history support 682 if($self->{super}->Storage->OpenStorage($shaname)) {
683 $@ = "$shaname: item exists in queue";
684 }
73a3d7ec » pab 2008-05-12 Added option to disable the... 685 elsif($history && $self->GetHistory($shaname)) {
a6c39744 » pab 2008-03-21 added history support 686 $@ = "$shaname: has already been downloaded. Use 'history $shaname forget' if you want do re-download it";
73a3d7ec » pab 2008-05-12 Added option to disable the... 687 $self->warn($@);
a6c39744 » pab 2008-03-21 added history support 688 }
689 elsif($sobj = $self->{super}->Storage->CreateStorage(StorageId => $shaname, Size=>$size, Chunks=>$chunks, Overshoot=>$overst, FileLayout=>$flayout)) {
3b5c9a66 » pab 2007-08-25 initial import 690 $sobj->SetSetting('owner', $owner);
691 $sobj->SetSetting('name' , $name);
33a74a49 » pab 2007-12-22 Implemented Digest-Dispatcher 692 $sobj->SetSetting('createdat', $self->{super}->Network->GetTime);
73a3d7ec » pab 2008-05-12 Added option to disable the... 693 if($history) {
694 $self->ModifyHistory($shaname, Name=>$name, Canceled=>'never', Started=>'',
695 Ended=>'never', Committed=>'never');
696 }
3b5c9a66 » pab 2007-08-25 initial import 697 }
698 else {
a6c39744 » pab 2008-03-21 added history support 699 $self->panic("CreateStorage for $shaname failed");
3b5c9a66 » pab 2007-08-25 initial import 700 }
a6c39744 » pab 2008-03-21 added history support 701
3b5c9a66 » pab 2007-08-25 initial import 702 return $sobj;
703 }
704
705 ##########################################################################
706 # Removes an item from the queue + storage
707 sub RemoveItem {
708 my($self,$sid) = @_;
709 my $ret = $self->{super}->Storage->RemoveStorage($sid);
710 if(!$ret) {
711 $self->panic("Unable to remove storage-object $sid : $!");
712 }
713
714 delete($self->{statistics}->{$sid}) or $self->panic("Cannot remove non-existing statistics for $sid");
715 return 1;
716 }
717
718 ##########################################################################
a6c39744 » pab 2008-03-21 added history support 719 # Updates/creates on-disk history of given sid
720 # Note: Strings with length == 0 are replaced with the current time. Awkward.
721 sub ModifyHistory {
722 my($self,$sid, %args) = @_;
723 if($self->{super}->Storage->OpenStorage($sid)) {
724 my $old_ref = $self->GetHistory($sid);
725 foreach my $k (keys(%args)) {
726 my $v = $args{$k};
727 $v = "".localtime($self->{super}->Network->GetTime) if length($v) == 0;
728 $old_ref->{$k} = $v;
729 }
b36be24e » pab 2008-03-24 Made config-parser generic 730 return $self->{super}->Storage->ClipboardSet(HPFX.$sid, $self->{super}->Tools->RefToCBx($old_ref));
a6c39744 » pab 2008-03-21 added history support 731 }
732 else {
733 return 0;
734 }
735 }
736
737 ##########################################################################
738 # Returns history of given sid
739 sub GetHistory {
740 my($self,$sid) = @_;
b36be24e » pab 2008-03-24 Made config-parser generic 741 my $r = $self->{super}->Tools->CBxToRef($self->{super}->Storage->ClipboardGet(HPFX.$sid));
a6c39744 » pab 2008-03-21 added history support 742 return $r;
743 }
744
745 ##########################################################################
3b5c9a66 » pab 2007-08-25 initial import 746 # Set private statistics
8ca1bb06 » pab 2007-12-24 Removed a few warnings and ... 747 # You are supposed to set total_bytes, total_chunks, done_bytes, done_chunks,
748 # uploaded_bytes, clients, active_clients, last_recv
749 # ..and we do not save anything.. you'll need to do this on your own :-)
3b5c9a66 » pab 2007-08-25 initial import 750 sub SetStats {
751 my($self, $id, $ref) = @_;
752 foreach my $xk (keys(%$ref)) {
753 $self->{statistics}->{$id}->{$xk} = $ref->{$xk};
754 }
755 }
756
757 sub IncrementStats {
758 my($self, $id, $ref) = @_;
759 foreach my $xk (keys(%$ref)) {
760 $self->SetStats($id,{$xk => $self->GetStat($id,$xk)+$ref->{$xk}});
761 }
762 }
763 sub DecrementStats {
764 my($self, $id, $ref) = @_;
765 foreach my $xk (keys(%$ref)) {
766 $self->SetStats($id,{$xk => $self->GetStat($id,$xk)-$ref->{$xk}});
767 }
768 }
769
770 ##########################################################################
771 # Get private statistics
772 sub GetStats {
773 my($self,$id) = @_;
774 return $self->{statistics}->{$id};
775 }
776
777 ##########################################################################
778 # Get single statistics key
779 sub GetStat {
780 my($self,$id,$key) = @_;
781 return $self->GetStats($id)->{$key};
782 }
783
784 ##########################################################################
785 # Returns a list with all queue objects
786 sub GetQueueList {
787 my($self) = @_;
788 my $xh = ();
789 my $all_ids = $self->{super}->Storage->GetStorageItems();
790 foreach my $id (@$all_ids) {
791 my $so = $self->{super}->Storage->OpenStorage($id) or $self->panic("Unable to open $id");
792 my $name = $so->GetSetting('name');
793 my $type = ($so->GetSetting('type') or "????");
794 $xh->{$type}->{$id} = { name=>$name };
795 }
796 return $xh;
797 }
798
7dfb0491 » pab 2008-07-17 Moved pause feature to Queu... 799 ##########################################################################
800 # Returns true if download is marked as paused
801 sub IsPaused {
802 my($self,$sid) = @_;
803 my $so = $self->{super}->Storage->OpenStorage($sid) or $self->panic("$sid does not exist");
804 return ( $so->GetSetting('_paused') ? 1 : 0 );
805 }
3b5c9a66 » pab 2007-08-25 initial import 806
807 ##########################################################################
808 # Returns a list of bitflus _Runner array as reference hash
809 sub GetRunnersRef {
810 my($self) = @_;
811 my $runners = ();
bfb43a2a » pab 2008-09-07 Bump apiversion due to _Run... 812 foreach my $rx (@{$self->{super}->{_Runners}}) {
813 my $t = $rx->{target};
814 $runners->{ref($t)} = $t;
3b5c9a66 » pab 2007-08-25 initial import 815 }
816 return $runners;
817 }
818
819
820
d2039c3b » pab 2008-01-02 pluginexclude setting 821 sub debug { my($self, $msg) = @_; $self->{super}->debug("QueueMGR: ".$msg); }
822 sub info { my($self, $msg) = @_; $self->{super}->info("QueueMGR: ".$msg); }
823 sub warn { my($self, $msg) = @_; $self->{super}->warn("QueueMGR: ".$msg); }
824 sub panic { my($self, $msg) = @_; $self->{super}->panic("QueueMGR: ".$msg); }
3b5c9a66 » pab 2007-08-25 initial import 825
826 1;
827
828 ###############################################################################################################
4697a0af » pab 2007-12-26 Added very unpolished magne... 829 # Bitflu Sammelsurium
830 package Bitflu::Tools;
9ab51800 » pab 2007-12-31 More webui fixes.. 831
832 use MIME::Base64 ();
8343f78d » pab 2008-01-06 Some tracker fixes and a re... 833 use IO::Socket;
33a74a49 » pab 2007-12-22 Implemented Digest-Dispatcher 834
835 ##########################################################################
836 # Create new object and try to load a module
b36be24e » pab 2008-03-24 Made config-parser generic 837 # Note: new() this gets called before ::Configuration is ready!
838 # You can't use fancy stuff such as ->debug. ->stop should work
33a74a49 » pab 2007-12-22 Implemented Digest-Dispatcher 839 sub new {
840 my($class, %args) = @_;
841 my $self = { super => $args{super}, ns => '', mname => '' };
842 bless($self,$class);
843
844 foreach my $mname (qw(Digest::SHA Digest::SHA1)) {
845 my $code = "use $mname; \$self->{ns} = $mname->new; \$self->{mname} = \$mname";
846 eval $code;
847 }
848
b36be24e » pab 2008-03-24 Made config-parser generic 849 unless($self->{mname}) {
33a74a49 » pab 2007-12-22 Implemented Digest-Dispatcher 850 $self->stop("No SHA1-Module found. Bitflu requires 'Digest::SHA' (http://search.cpan.org)");
851 }
852
853 return $self;
854 }
855
856 sub init { return 1 }
857
4697a0af » pab 2007-12-26 Added very unpolished magne... 858 ##########################################################################
1e342af6 » pab 2008-05-04 Added first version of crea... 859 # Return hexed sha1 of $buff
33a74a49 » pab 2007-12-22 Implemented Digest-Dispatcher 860 sub sha1_hex {
861 my($self, $buff) = @_;
862 $self->{ns}->add($buff);
863 return $self->{ns}->hexdigest;
864 }
865
4697a0af » pab 2007-12-26 Added very unpolished magne... 866 ##########################################################################
1e342af6 » pab 2008-05-04 Added first version of crea... 867 # Return sha1 of $buff
33a74a49 » pab 2007-12-22 Implemented Digest-Dispatcher 868 sub sha1 {
869 my($self,$buff) = @_;
870 $self->{ns}->add($buff);
871 return $self->{ns}->digest;
872 }
873
4697a0af » pab 2007-12-26 Added very unpolished magne... 874 ##########################################################################
875 # Encode string into base32
876 sub encode_b32 {
877 my($self,$val) = @_;
878 my $s = unpack("B*",$val);
879 $s =~ s/(.{5})/000$1/g; # Convert 5-byte-chunks to 8-byte-chunks
880 my $len = length($s);
881 my $olen = $len % 8;
882
883 if($olen) {
884 $s = substr($s,0,$len-$olen)."000".substr($s,-1*$olen).("0" x (5 - $olen));
885 }
886
887 $s = pack("B*",$s);
888 $s =~ tr/\0-\37/A-Z2-7/; # Octal!
889 return $s;
890 }
891
892 ##########################################################################
893 # Decode base32 into string
894 sub decode_b32 {
895 my($self,$val) = @_;
896 my $s = uc($val);
897 $s =~ tr/A-Z2-7/\0-\37/;
898 $s = unpack("B*", $s);
899 $s =~ s/000(.{5})/$1/g;
900 if( my $olen = -1*(length($s)%8) ) {
901 $s = substr($s,0,$olen);
902 }
903 return pack("B*",$s);
904 }
905
9ab51800 » pab 2007-12-31 More webui fixes.. 906 ##########################################################################
907 # Decode base64 into string
908 sub decode_b64 {
909 my($self,$val) = @_;
910 return MIME::Base64::decode($val);
911 }
912
4697a0af » pab 2007-12-26 Added very unpolished magne... 913
914 ##########################################################################
915 # Parse a magnet link
916 sub decode_magnet {
917 my($self,$uri) = @_;
918 my $xt = {};
919 if($uri =~ /^magnet:\?(.+)$/) {
920 foreach my $item (split(/&/,$1)) {
921 if($item =~ /^(([^=\.]+)(\.\d+)?)=(.+)$/) {
922 my $mk = $2;
923 my @it = split(/:/,$4);
924 my $mv = pop(@it);
925 my $sk = join(':',@it) || ":";
926 push(@{$xt->{$mk}}, {$sk => $mv});
927 }
928 }
929 }
930 return $xt;
931 }
ae176dce » pab 2008-01-04 Exclude support! 932
933 sub ExpandRange {
934 my($self,@a) = @_;
935 my %dedupe = ();
936 foreach my $chunk (@a) {
937 if($chunk =~ /^(\d+)-(\d+)$/) { if($2 <= 0xFFFF) { for($1..$2) { $dedupe{$_} = 1; } } }
938 elsif($chunk =~ /^(\d+)$/) { $dedupe{abs($1)} = 1; }
939 }
940 return \%dedupe;
941 }
942
8343f78d » pab 2008-01-06 Some tracker fixes and a re... 943 ##########################################################################
944 # Resolve hostnames
945 sub Resolve {
946 my($self,$name) = @_;
947 my @iplist = ();
948 my @result = gethostbyname($name);
949 @iplist = map{ inet_ntoa($_) } @result[4..$#result];
950 return List::Util::shuffle(@iplist);
951 }
97dfa070 » pab 2008-01-12 Some http-gui addons and fi... 952
953 ##########################################################################
954 # Escape a HTTP-URI-Escaped string
955 sub UriUnescape {
956 my($self,$string) = @_;
957 $string =~ s/%([0-9A-Fa-f]{2})/chr(hex($1))/eg;
958 return $string;
959 }
960
961 ##########################################################################
962 # Escape string
963 sub UriEscape {
964 my($self,$string) = @_;
965 $string =~ s/([^A-Za-z0-9\-_.!~*'()\/])/sprintf("%%%02X",ord($1))/eg;
966 return $string;
967 }
b36be24e » pab 2008-03-24 Made config-parser generic 968
969 ##########################################################################
970 # Converts a CBX into a hashref
971 sub CBxToRef {
972 my($self,$buff) = @_;
973 my $r = undef;
974 $buff ||= '';
975 foreach my $line (split(/\n/,$buff)) {
976 chomp($line);
977 if($line =~ /^#/ or $line =~ /^\s*$/) {
978 next; # Comment or empty line
979 }
980 elsif($line =~ /^([a-zA-Z0-9_\.]+)\s*=\s*(.*)$/) {
981 $r->{$1} = $2;
982 }
983 else {
984 # Ignore. Can't use panic anyway
985 }
986 }
987 return $r;
988 }
989
990 ##########################################################################
991 # Convert hashref into CBX
992 sub RefToCBx {
993 my($self,$ref) = @_;
994 my @caller = caller;
995 my $buff = "# Written by $caller[0]\@$caller[2] on ".gmtime()."\n";
996 foreach my $key (sort(keys(%$ref))) {
997 my $val = $ref->{$key};
998 $key =~ tr/a-zA-Z0-9_\.//cd;
999 $val =~ tr/\r\n//d;
1000 $buff .= sprintf("%-25s = %s\n",$key, $val);
1001 }
1002 return $buff."# EOF #\n";
1003 }
ae176dce » pab 2008-01-04 Exclude support! 1004
1e342af6 » pab 2008-05-04 Added first version of crea... 1005 ##########################################################################
1006 # Generates a 'find' like dirlist
1007 sub GenDirList {
1008 my($self,$dstruct, $dir) = @_;
1009 push(@{$dstruct->{_}},$dir);
1010 my $pfx = join('/',@{$dstruct->{_}});
1011 opendir(DIR, $pfx);
1012 foreach my $dirent (readdir(DIR)) {
1013 my $fp = "$pfx/".$dirent;
1014 next if $dirent eq '.'; # No thanks
1015 next if $dirent eq '..'; # Ditto
1016 next if (-l $fp); # Won't look at symlinks
1017 push(@{$dstruct->{list}},$fp);
1018 $self->GenDirList($dstruct,$dirent) if -d $fp;
1019 }
1020 closedir(DIR);
1021 pop(@{$dstruct->{_}});
1022 }
6933c336 » pab 2008-05-04 some more create_torrent love 1023
1024 ##########################################################################
1025 # Getopts like support
1026 sub GetOpts {
1027 my($self,$args) = @_;
1028 my @leftovers = ();
1029 my $ctx = undef;
1030 my $argref = {};
1031 foreach my $this_arg (@$args) {
caedb01c » pab 2008-06-29 log command implemented 1032 if($this_arg =~ /^--?(.+)/) {
6933c336 » pab 2008-05-04 some more create_torrent love 1033 $ctx = $1;
1034 $argref->{$ctx} = defined if !exists $argref->{$ctx};
1035 }
1036 elsif(defined($ctx)) {
1037 $argref->{$ctx} = $this_arg;
1038 $ctx = undef;
1039 }
1040 else {
1041 push(@leftovers, $this_arg);
1042 }
1043 }
1044 @$args = @leftovers;
1045 return $argref;
1046 }
1e342af6 » pab 2008-05-04 Added first version of crea... 1047
eeafdc86 » pab 2008-05-28 even more VFS updates 1048 ##########################################################################
1049 # Return exclusive name
1050 sub GetExclusiveDirectory {
1051 my($self,$base,$id) = @_;
1052 my $xname = undef;
1053 foreach my $sfx (0..0xFFFF) {
1054 $xname = $base."/".$id;
1055 $xname .= ".$sfx" if $sfx != 0;
1056 unless(-e $xname) {
1057 return $xname;
1058 }
1059 }
1060 return undef;
1061 }
3a9518d5 » pab 2008-10-22 Implemented a sysread() wra... 1062
1063 ##########################################################################
1064 # looping sysread implementation
1065 # *BSD doesn't like big LENGTH values on sysread
1066 # This provides a crappy warper to 'fix' this problem
1067 # syswrite() doesn't seem to suffer the same problem ...
1068 sub Sysread {
1069 my($self, $fh, $ref, $bytes_needed) = @_;
1070
1071 my $bytes_left = $bytes_needed;
1072 my $buff = '';
1073
1074 $self->panic("Cannot read $bytes_needed bytes") if $bytes_needed < 0;
1075
1076 while($bytes_left > 0) {
1077 my $br = sysread($fh, $buff, $bytes_left);
1078 if($br) { ${$ref} .= $buff; $bytes_left -= $br; } # Data
1079 elsif(defined($br)) { last; } # EOF
1080 else { return undef; } # Error
1081 }
1082
1083 return ($bytes_needed-$bytes_left);
1084 }
eeafdc86 » pab 2008-05-28 even more VFS updates 1085
1086
33a74a49 » pab 2007-12-22 Implemented Digest-Dispatcher 1087 sub debug { my($self, $msg) = @_; $self->{super}->debug(ref($self).": ".$msg); }
1088 sub stop { my($self, $msg) = @_; $self->{super}->stop(ref($self).": ".$msg); }
1089
1090 1;
1091
1092
1093 ###############################################################################################################
3b5c9a66 » pab 2007-08-25 initial import 1094 # Bitflu Admin-Dispatcher : Release 20070319_1
1095 package Bitflu::Admin;
1096
1097 ##########################################################################
1098 # Guess what?
1099 sub new {
1100 my($class, %args) = @_;
1101 my $self = {super=> $args{super}, cmdlist => {}, notifylist => {}};
1102 bless($self,$class);
1103 return $self;
1104 }
1105
1106 ##########################################################################
1107 # Init plugin
1108 sub init {
1109 my($self) = @_;
bbbbb5fc » pab 2007-09-01 Added autocommit/autocancel... 1110 $self->RegisterCommand("help", $self, 'admincmd_help' , 'Displays what you are reading now',
1111 [ [undef, "Use 'help' to get a list of all commands"], [undef, "Type 'help command' to get help about 'command'"] ]);
b6c764b5 » pab 2007-12-01 Added useradmin support 1112 $self->RegisterCommand("plugins", $self, 'admincmd_plugins', 'Displays all loaded plugins');
1113 $self->RegisterCommand("useradmin",$self, 'admincmd_useradm', 'Create and modify accounts',
1114 [ [undef, "Usage: useradmin [set username password] [delete username] [list]"] ]);
3b5c9a66 » pab 2007-08-25 initial import 1115 $self->RegisterNotify($self, 'receive_notify');
caedb01c » pab 2008-06-29 log command implemented 1116 $self->RegisterCommand("log", $self, 'admincmd_log', 'Display last log output',
1117 [ [undef, "Usage: log [-limit]"], [undef, 'Example: log -10 # <-- displays the last 10 log entries'] ] );
3b5c9a66 » pab 2007-08-25 initial import 1118 return 1;
1119 }
1120
1121 ##########################################################################
caedb01c » pab 2008-06-29 log command implemented 1122 # Return logbuffer
1123 sub admincmd_log {
1124 my($self, @args) = @_;
1125 my @A = ();
1126 my @log = @{$self->{super}->{_LogBuff}};
1127 my $opts = $self->{super}->Tools->GetOpts(\@args);
1128 my $limit = int(((keys(%$opts))[0]) || 0);
1129 my $logsize = int(@log);
1130 my $logat = ( $limit ? ( $logsize - $limit ) : 0 );
1131 my $i = 0;
1132
1133 foreach my $ll (@log) {
1134 next if $i++ < $logat;
1135 chomp($ll);
1136 push(@A, [undef, $ll]);
1137 }
1138 return({MSG=>\@A, SCRAP=>[]});
1139 }
1140
1141 ##########################################################################
3b5c9a66 » pab 2007-08-25 initial import 1142 # Display registered plugins
1143 sub admincmd_plugins {
1144 my($self) = @_;
1145
1146 my @A = ([1, "Hooks registered at bitflus NSFS (NotSoFairScheduler)"]);
bfb43a2a » pab 2008-09-07 Bump apiversion due to _Run... 1147 foreach my $rx (@{$self->{super}->{_Runners}}) {
1148 push(@A,[undef,$rx->{target}]);
3b5c9a66 » pab 2007-08-25 initial import 1149 }
1150
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 1151 return({MSG=>\@A, SCRAP=>[]});
3b5c9a66 » pab 2007-08-25 initial import 1152 }
1153
1154 ##########################################################################
1155 # Notification handler, we are just going to print them out using the logging
1156 sub receive_notify {
1157 my($self,$msg) = @_;
1158 $self->info("#NOTIFICATION#: $msg");
1159 }
1160
1161 ##########################################################################
1162 # BareBones help
1163 sub admincmd_help {
bbbbb5fc » pab 2007-09-01 Added autocommit/autocancel... 1164 my($self,$topic) = @_;
3b5c9a66 » pab 2007-08-25 initial import 1165 my @A = ();
1166
bbbbb5fc » pab 2007-09-01 Added autocommit/autocancel... 1167 if($topic) {
e6b5ae79 » pab 2007-09-15 Added command completition 1168 if(defined($self->GetCommands->{$topic})) {
1169 my @instances = @{$self->GetCommands->{$topic}};
bbbbb5fc » pab 2007-09-01 Added autocommit/autocancel... 1170
1171 foreach my $ci (@instances) {
1172 push(@A, [3, "Command '$topic' (Provided by plugin $ci->{class})"]);
1173 if($ci->{longhelp}) {
1174 push(@A, @{$ci->{longhelp}});
1175 }
1176 else {
1177 push(@A, [undef, $ci->{help}]);
1178 }
1179 push(@A, [undef, '']);
1180 }
1181 }
1182 else {
1183 push(@A, [2, "No help for '$topic', command does not exist"]);
3b5c9a66 » pab 2007-08-25 initial import 1184 }
1185 }
bbbbb5fc » pab 2007-09-01 Added autocommit/autocancel... 1186 else {
e6b5ae79 » pab 2007-09-15 Added command completition 1187 foreach my $xcmd (sort (keys %{$self->GetCommands})) {
bbbbb5fc » pab 2007-09-01 Added autocommit/autocancel... 1188 my $lb = sprintf("%-20s", $xcmd);
1189 my @hlps = ();
e6b5ae79 » pab 2007-09-15 Added command completition 1190 foreach my $instance (@{$self->GetCommands->{$xcmd}}) {
bbbbb5fc » pab 2007-09-01 Added autocommit/autocancel... 1191 push(@hlps, "$instance->{help}");;
1192 }
1193
1194 $lb .= join(' / ',@hlps);
1195
1196 push(@A, [undef, $lb]);
1197 }
1198 }
1199
3b5c9a66 » pab 2007-08-25 initial import 1200
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 1201 return({MSG=>\@A, SCRAP=>[]});
3b5c9a66 » pab 2007-08-25 initial import 1202 }
1203
1204 ##########################################################################
b6c764b5 » pab 2007-12-01 Added useradmin support 1205 # Handles useradm commands
1206 sub admincmd_useradm {
1207 my($self, @args) = @_;
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 1208
1209 my @A = ();
1210 my $ERR = '';
b6c764b5 » pab 2007-12-01 Added useradmin support 1211
1212 my($cmd,$usr,$pass) = @args;
1213
1214 if($cmd eq 'set' && $pass) {
1215 $self->__useradm_modify(Inject => {User=>$usr, Pass=>$pass});
1216 push(@A, [1, "Useraccount updated"]);
1217 }
1218 elsif($cmd eq 'delete' && $usr) {
1219 if(defined $self->__useradm_modify->{$usr}) {
1220 # -> Account exists
1221 $self->__useradm_modify(Drop => {User=>$usr});
1222 push(@A, [1, "Account '$usr' removed"]);
1223 $self->panic("BUG") if (defined $self->__useradm_modify->{$usr}); # Paranoia check
1224 }
1225 else {
1226 push(@A, [2, "Account '$usr' does not exist"]);
1227 }
1228 }
1229 elsif($cmd eq 'list') {
1230 push(@A, [3, "Configured accounts:"]);
1231 foreach my $k (keys(%{$self->__useradm_modify})) {
1232 push(@A, [undef,$k]);
1233 }
1234 }
1235 else {
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 1236 $ERR .= "Usage error, type 'help useradmin' for more information";
b6c764b5 » pab 2007-12-01 Added useradmin support 1237 }
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 1238 return({MSG=>\@A, SCRAP=>[], NOEXEC=>$ERR});
b6c764b5 » pab 2007-12-01 Added useradmin support 1239 }
1240
1241 ##########################################################################
1242 # Create password entry
1243 sub __useradm_mkentry {
1244 my($self,$usr,$pass) = @_;
1245 $usr =~ tr/: ;=//d;
1246 return undef if length($usr) == 0;
4697a0af » pab 2007-12-26 Added very unpolished magne... 1247 return $usr.":".$self->{super}->Tools->sha1_hex("$usr;$pass");
b6c764b5 » pab 2007-12-01 Added useradmin support 1248 }
1249
1250 ##########################################################################
1251 # Modify current setting
1252 sub __useradm_modify {
1253 my($self,%args) = @_;
1254 my @result = ();
1255 my $allusr = {};
1256 my $to_inject = '';
1257 my $delta = 0;
9ab51800 » pab 2007-12-31 More webui fixes.. 1258 foreach my $entry (split(/;/,($self->{super}->Configuration->GetValue('useradm') || ''))) {
b6c764b5 » pab 2007-12-01 Added useradmin support 1259 if(my($user,$hash) = $entry =~ /^([^:]*):(.+)$/) {
9ab51800 » pab 2007-12-31 More webui fixes.. 1260 if ($user ne ($args{Inject}->{User} || '') && $user ne ($args{Drop}->{User} || '')) {
b6c764b5 » pab 2007-12-01 Added useradmin support 1261 push(@result,$entry);
1262 }
1263 else {
1264 $delta++;
1265 }
1266 $allusr->{$user} = $entry;
1267 }
1268 else {
1269 $self->warn("Useradmin: Wiping garbage entry: '$entry'");
1270 }
1271 }
1272
1273 if(exists($args{Inject}->{User})) {
1274 $to_inject = $args{Inject}->{User};
1275 $to_inject =~ tr/:; //d;
1276 $delta++;
1277 }
1278
1279 if(length($to_inject) > 0) {
1280 push(@result,$self->__useradm_mkentry($to_inject,$args{Inject}->{Pass}));
1281 }
1282
1283 $self->{super}->Configuration->SetValue('useradm', join(';', @result)) if $delta;
1284 return $allusr;
1285 }
1286
1287
1288 ##########################################################################
3b5c9a66 » pab 2007-08-25 initial import 1289 # Register Notify handler
1290 sub RegisterNotify {
1291 my($self, $xref, $xcmd) = @_;
1292 $self->debug("RegisterNotify: Will notify $xref via $xref->$xcmd");
1293 $self->{notifylist}->{$xref} = { class => $xref, cmd => $xcmd };
1294 }
1295
1296 ##########################################################################
1297 # Send out notifications
1298 sub SendNotify {
1299 my($self,$msg) = @_;
1300 foreach my $kx (keys(%{$self->{notifylist}})) {
1301 my $nc = $self->{notifylist}->{$kx};
1302 my $class = $nc->{class}; my $cmd = $nc->{cmd};
1303 $class->$cmd($msg);
1304 }
1305 }
1306
1307 ##########################################################################
1308 # Registers a new command to be used with ExecuteCommand
1309 sub RegisterCommand {
bbbbb5fc » pab 2007-09-01 Added autocommit/autocancel... 1310 my($self,$name,$xref,$xcmd,$helptext,$longhelp) = @_;
3b5c9a66 » pab 2007-08-25 initial import 1311 $self->debug("RegisterCommand: Hooking $name to $xref->$xcmd");
bbbbb5fc » pab 2007-09-01 Added autocommit/autocancel... 1312 push(@{$self->{cmdlist}->{$name}}, {class=>$xref, cmd=>$xcmd, help=>$helptext, longhelp=>$longhelp});
3b5c9a66 » pab 2007-08-25 initial import 1313 $helptext or $self->panic("=> $xcmd ; $xref");
1314 }
1315
1316 ##########################################################################
e6b5ae79 » pab 2007-09-15 Added command completition 1317 # Returns the full cmdlist
1318 sub GetCommands {
1319 my($self) = @_;
1320 return $self->{cmdlist};
1321 }
1322
1323 ##########################################################################
3b5c9a66 » pab 2007-08-25 initial import 1324 # Execute a command!
1325 sub ExecuteCommand {
1326 my($self,$command,@args) = @_;
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 1327
1328
1329 my $plugin_hits = 0;
1330 my $plugin_fails = 0;
1331 my $plugin_ok = 0;
1332 my @plugin_msg = ();
1333 my @plugin_nex = ();
3b5c9a66 » pab 2007-08-25 initial import 1334
e6b5ae79 » pab 2007-09-15 Added command completition 1335 if(ref($self->GetCommands->{$command}) eq "ARRAY") {
1336 foreach my $ref (@{$self->GetCommands->{$command}}) {
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 1337 $plugin_hits++;
3b5c9a66 » pab 2007-08-25 initial import 1338 my $class = $ref->{class};
1339 my $cmd = $ref->{cmd};
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 1340 my $bref = $class->$cmd(@args);
1341 my $SCRAP = $bref->{SCRAP} or $self->panic("$class -> $cmd returned no SCRAP");
1342 my $MSG = $bref->{MSG} or $self->panic("$class -> $cmd returned no MSG");
1343 my $ERR = $bref->{NOEXEC};
1344 @args = @$SCRAP;
1345
1346 push(@plugin_msg, @$MSG);
1347
1348 if($ERR) {
1349 push(@plugin_nex, $ERR); # Plugin usage error
3b5c9a66 » pab 2007-08-25 initial import 1350 }
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 1351 else {
1352 $plugin_ok++; # Plugin could do something
3b5c9a66 » pab 2007-08-25 initial import 1353 }
1354 }
1355 }
1356
1357 if($plugin_hits == 0) {
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 1358 push(@plugin_msg, [2, "Unknown command '$command'"]);
1359 $plugin_fails++;
3b5c9a66 » pab 2007-08-25 initial import 1360 }
02ad0fd9 » pab 2007-12-30 A broken http plugin 1361 else {
1362 foreach my $leftover (@args) {
c9743480 » pab 2008-08-17 HTTP-UI fixes 1363 push(@plugin_msg, [2, "Failed to execute '$command $leftover'"]);
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 1364 $plugin_fails++;
1365 }
02ad0fd9 » pab 2007-12-30 A broken http plugin 1366
1367 if($plugin_ok == 0) {
1368 # Nothing executed, display all usage 'hints'
1369 foreach my $xerr (@plugin_nex) {
1370 push(@plugin_msg, [2, $xerr]);
1371 $plugin_fails++;
1372 }
1373 }
3b5c9a66 » pab 2007-08-25 initial import 1374 }
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 1375 return({MSG=>\@plugin_msg, FAILS=>$plugin_fails});
3b5c9a66 » pab 2007-08-25 initial import 1376 }
1377
b6c764b5 » pab 2007-12-01 Added useradmin support 1378 ##########################################################################
1379 # Returns TRUE if Authentication was successful (or disabled (= no accounts))
1380 sub AuthenticateUser {
1381 my($self,%args) = @_;
1382 my $numentry = int(keys(%{$self->__useradm_modify}));
1383 return 1 if $numentry == 0; # No users, no security
1384
1385 my $expect = $self->__useradm_mkentry($args{User}, $args{Pass});
1386 if(defined($expect) && $self->__useradm_modify->{$args{User}} eq $expect ) {
1387 return 1;
1388 }
1389 else {
1390 return 0;
1391 }
1392 }
1393
d2039c3b » pab 2008-01-02 pluginexclude setting 1394 sub warn { my($self, $msg) = @_; $self->{super}->warn("Admin : ".$msg); }
1395 sub debug { my($self, $msg) = @_; $self->{super}->debug("Admin : ".$msg); }
1396 sub info { my($self, $msg) = @_; $self->{super}->info("Admin : ".$msg); }
1397 sub panic { my($self, $msg) = @_; $self->{super}->panic("Admin : ".$msg); }
3b5c9a66 » pab 2007-08-25 initial import 1398
1399 1;
1400
1401
1402 ###############################################################################################################
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1403 # Bitflu Network-IO Lib : Release 20071220_1
3b5c9a66 » pab 2007-08-25 initial import 1404 package Bitflu::Network;
1405
1406 use strict;
1407 use IO::Socket;
1408 use IO::Select;
1409 use POSIX;
1410
839ea0fd » pab 2007-12-29 new bencoding decoder 1411 use constant NETSTATS => 2; # ReGen netstats each 2 seconds
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1412 use constant MAXONWIRE => 1024*1024; # Do not buffer more than 1mb per client connection
1413 use constant BPS_MIN => 8; # Minimal upload speed per socket
1414 use constant DEVNULL => '/dev/null'; # Path to /dev/null
1415 use constant LT_UDP => 1; # Internal ID for UDP sockets
1416 use constant LT_TCP => 2; # Internal ID for TCP sockets
8630fab0 » pab 2008-08-31 Added TTL support 1417 use constant BLIST_LIMIT => 1024; # NeverEver blacklist more than 1024 IPs per instance
1418 use constant BLIST_TTL => 60*60; # BL entries are valid for 1 hour
3b5c9a66 » pab 2007-08-25 initial import 1419
1420 ##########################################################################
1421 # Creates a new Networking Object
1422 sub new {
1423 my($class, %args) = @_;
233883e5 » pab 2008-08-23 This clockskew patch is better 1424 my $self = {super=> $args{super}, bpc=>BPS_MIN, NOWTIME => 0, timeflux=>0 , _bitflu_network => {}, avfds => 0,
3b5c9a66 » pab 2007-08-25 initial import 1425 stats => {nextrun=>0, sent=>0, recv=>0, raw_recv=>0, raw_sent=>0} };
1426 bless($self,$class);
1427 $self->SetTime;
1428 $self->{avfds} = $self->TestFileDescriptors;
47dc3e98 » pab 2007-12-01 Track announce_peer and fix... 1429 $self->debug("Reserved $self->{avfds} file descriptors for networking");
3b5c9a66 » pab 2007-08-25 initial import 1430 return $self;
1431 }
1432
1433 ##########################################################################
1434 # Register Admin commands
1435 sub init {
1436 my($self) = @_;
d0b61b4e » pab 2008-06-23 Renamed blinfo into blacklist 1437 $self->{super}->Admin->RegisterCommand('netstat' , $self, '_Command_Netstat', 'Displays networking information');
1438 $self->{super}->Admin->RegisterCommand('blacklist' , $self, '_Command_Blacklist', 'Show current in-memory IP-Blacklist');
3b5c9a66 » pab 2007-08-25 initial import 1439 $self->SetTime;
1440 return 1;
1441 }
1442
59365da4 » pab 2007-12-17 BitTorrent::run rewrite, so... 1443 ##########################################################################
1444 # Display netstat command
3b5c9a66 » pab 2007-08-25 initial import 1445 sub _Command_Netstat {
1446 my($self) = @_;
1447 my @A = ();
1448 my $bfn = $self->{_bitflu_network};
1449
c664d5a6 » pab 2007-12-19 More cleanups 1450 push(@A, [3, "Total file descriptors left : $self->{avfds}"]);
3b5c9a66 » pab 2007-08-25 initial import 1451
1452 foreach my $item (keys(%$bfn)) {
c3035eb6 » pab 2008-06-08 First batch of the new RANK... 1453 if(exists($bfn->{$item}->{config})) {
98644351 » pab 2007-12-02 Kademlia should work now ;-) 1454 push(@A, [4, '-------------------------------------------------------------------------']);
3b5c9a66 » pab 2007-08-25 initial import 1455 push(@A, [1, "Handle: $item"]);
98644351 » pab 2007-12-02 Kademlia should work now ;-) 1456 push(@A, [undef,"Active connections : $bfn->{$item}->{config}->{cntMaxPeers}"]);
1457 push(@A, [undef,"Connection hardlimit : $bfn->{$item}->{config}->{MaxPeers}"]);
1458 push(@A, [undef,"Connections not yet established : ".int(keys(%{$bfn->{$item}->{establishing}}))]);
3b5c9a66 » pab 2007-08-25 initial import 1459 }
1460 }
1461
98cc2b50 » pab 2007-12-28 Reworked ->ExecuteCommand a... 1462 return({MSG=>\@A, SCRAP=>[]});
3b5c9a66 » pab 2007-08-25 initial import 1463 }
1464
d0b61b4e » pab 2008-06-23 Renamed blinfo into blacklist 1465 sub _Command_Blacklist {
c3035eb6 » pab 2008-06-08 First batch of the new RANK... 1466 my($self) = @_;
1467 my @A = ();
1468 my $bfn = $self->{_bitflu_network};
1469
1470 foreach my $item (sort keys(%$bfn)) {
1471 if(exists($bfn->{$item}->{config})) {
1472 push(@A, [4, "Blacklist for ID $item"]);
1473 my $blc = 0;
8630fab0 » pab 2008-08-31 Added TTL support 1474 while( my($k,$v) = each(%{$bfn->{$item}->{blacklist}->{bldb}}) ) {
7d437f18 » pab 2008-08-31 Beautify blacklist output 1475 my $this_ttl = $v - $self->GetTime;
1476 next if $this_ttl < 0;
1477 push(@A, [2, sprintf(" %-24s (expires in %d seconds)",$k,$this_ttl)]);
c3035eb6 » pab 2008-06-08 First batch of the new RANK... 1478 $blc++;
1479 }
1480 push(@A, [3, "$blc ip(s) are blacklisted"], [undef, '']);
1481 }
1482 }
1483
1484 return({MSG=>\@A, SCRAP=>[]});
1485 }
1486
3b5c9a66 » pab 2007-08-25 initial import 1487 ##########################################################################
1488 # Test how many filedescriptors this OS / env can handle
1489 sub TestFileDescriptors {
1490 my($self) = @_;
1491 my $i = 0;
1492 my @fdx = ();
1493 my $sysr = 0xF;
1494 my $canhave = 0;
59365da4 » pab 2007-12-17 BitTorrent::run rewrite, so... 1495
1496 open(FAKE, DEVNULL) or $self->stop("Unable to open ".DEVNULL.": $!");
1497 close(FAKE);
1498
3b5c9a66 » pab 2007-08-25 initial import 1499 while($i++ < 2048) {
59365da4 » pab 2007-12-17 BitTorrent::run rewrite, so... 1500 unless( open($fdx[$i], DEVNULL) ) {
3b5c9a66 » pab 2007-08-25 initial import 1501 last;
1502 }
1503 }
1504 if($i > $sysr) {
1505 $canhave = $i - $sysr;
1506 }
1507 else {
1508 $self->panic("Sorry, bitfu can not run with only $i filedescriptors left");
1509 }
1510 while(--$i > 0) {
1511 close($fdx[$i]) or $self->panic("Unable to close TestFD # $i : $!");
1512 }
1513 return $canhave;
1514 }
1515
1516 ##########################################################################
1517 # Refresh buffered time
1518 sub SetTime {
1519 my($self) = @_;
233883e5 » pab 2008-08-23 This clockskew patch is better 1520
1521 my $NOW = time();
1522
1523 if($NOW > $self->{NOWTIME}) {
1524 $self->{NOWTIME} = $NOW;
1525 }
1526 elsif($NOW < $self->{NOWTIME}) {
1527 $self->warn("Clock jumped backwards! Returning last known good time...");
1528 }
3b5c9a66 » pab 2007-08-25 initial import 1529 }
1530
1531 ##########################################################################
1532 # Returns buffered time
1533 sub GetTime {
1534 my($self) = @_;
1535 return $self->{NOWTIME};
1536 }
1537
1538 ##########################################################################
1539 # Returns bandwidth statistics
1540 sub GetStats {
1541 my($self) = @_;
1542 return $self->{stats};
1543 }
1544
1545 ##########################################################################
1546 # Returns last IO for given socket
1547 sub GetLastIO {
1548 my($self,$socket) = @_;
c664d5a6 » pab 2007-12-19 More cleanups 1549 $self->panic("Cannot return lastio of vanished socket <$socket>") unless exists($self->{_bitflu_network}->{$socket});
3b5c9a66 » pab 2007-08-25 initial import 1550 return $self->{_bitflu_network}->{$socket}->{lastio};
1551 }
1552
59365da4 » pab 2007-12-17 BitTorrent::run rewrite, so... 1553 ##########################################################################
02ad0fd9 » pab 2007-12-30 A broken http plugin 1554 # Returns QueueLength of given socket
1555 sub GetQueueLen {
1556 my($self, $socket) = @_;
61deb2b5 » pab 2008-01-01 A new monster commit :-) 1557 $self->panic("Cannot return qlen of vanished socket <$socket>") unless exists($self->{_bitflu_network}->{$socket});
1558 return ($self->{_bitflu_network}->{$socket}->{qlen} || 0);
1559 }
1560
1561 ##########################################################################
1562 # Returns how many bytes we can write to the queue
1563 sub GetQueueFree {
1564 my($self,$socket) = @_;
1565 $self->panic("Cannot return qfree of vanished socket <$socket>") unless exists($self->{_bitflu_network}->{$socket});
1566 return(MAXONWIRE - $self->GetQueueLen($socket));
02ad0fd9 » pab 2007-12-30 A broken http plugin 1567 }
1568
1569 ##########################################################################
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1570 # Returns TRUE if socket is an INCOMING connection
1571 sub IsIncoming {
1572 my($self,$socket) = @_;
1573 my $val = $self->{_bitflu_network}->{$socket}->{incoming};
1574 $self->panic("$socket has an undef value for 'incoming'") unless defined($val);
1575 return $val;
1576 }
1577
1578 ##########################################################################
59365da4 » pab 2007-12-17 BitTorrent::run rewrite, so... 1579 # Create an UDP-Listen socket
46202084 » pab 2007-11-10 First UDP-Socket support 1580 sub NewUdpListen {
1581 my($self,%args) = @_;
1582 return undef if(!defined($args{ID}));
1583 return undef if(!defined($args{Port}));
1584
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1585 if(exists($self->{_bitflu_network}->{$args{ID}})) {
46202084 » pab 2007-11-10 First UDP-Socket support 1586 $self->panic("FATAL: $args{ID} has a listening socket, unable to create a second instance with the same ID");
1587 }
1588
1589 my $new_socket = IO::Socket::INET->new(LocalPort=>$args{Port}, LocalAddr=>$args{Bind}, Proto=>'udp') or return undef;
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1590
156d901b » pab 2008-06-08 More blacklisting-love 1591 $self->{_bitflu_network}->{$args{ID}} = { select => undef, socket => $new_socket, rqi => 0, wqi => 0, config => { MaxPeers=>1, cntMaxPeers=>0, },
1592 blacklist => { pointer => 0, array => [], bldb => {}} };
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1593 $self->{_bitflu_network}->{$args{ID}}->{listentype} = LT_UDP;
1594 $self->{_bitflu_network}->{$args{ID}}->{select} = new IO::Select or $self->panic("Unable to create new IO::Select object: $!");
c664d5a6 » pab 2007-12-19 More cleanups 1595 $self->{_bitflu_network}->{$args{ID}}->{select}->add($new_socket) or $self->panic("Unable to glue <$new_socket> to select object of $args{ID}: $!");
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1596 $self->{_bitflu_network}->{$args{ID}}->{callbacks} = $args{Callbacks} or $self->panic("Unable to register UDP-Socket without any callbacks");
46202084 » pab 2007-11-10 First UDP-Socket support 1597 $self->Unblock($new_socket) or $self->panic("Unable to unblock $new_socket");
1598 return $new_socket;
1599 }
1600
3b5c9a66 » pab 2007-08-25 initial import 1601 ##########################################################################
1602 # Try to create a new listening socket
c664d5a6 » pab 2007-12-19 More cleanups 1603 # NewTcpListen(ID=>UniqueueRunnerId, Port=>PortToListen, Bind=>IPv4ToBind, Callbacks => {})
3b5c9a66 » pab 2007-08-25 initial import 1604 sub NewTcpListen {
1605 my($self,%args) = @_;
1606 return undef if(!defined($args{ID}));
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1607 my $socket = 0;
3b5c9a66 » pab 2007-08-25 initial import 1608
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1609 if(exists($self->{_bitflu_network}->{$args{ID}})) {
3b5c9a66 » pab 2007-08-25 initial import 1610 $self->panic("FATAL: $args{ID} has a listening socket, unable to create a second instance with the same ID");
1611 }
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1612 elsif($args{MaxPeers} < 1) {
1613 $self->panic("$args{ID}: cannot reserve '$args{MaxPeers}' file descriptors");
3b5c9a66 » pab 2007-08-25 initial import 1614 }
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1615 elsif($args{Port}) {
1616 $socket = IO::Socket::INET->new(LocalPort=>$args{Port}, LocalAddr=>$args{Bind}, Proto=>'tcp', ReuseAddr=>1, Listen=>1) or return undef;
3b5c9a66 » pab 2007-08-25 initial import 1617 }
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1618
156d901b » pab 2008-06-08 More blacklisting-love 1619 $self->{_bitflu_network}->{$args{ID}} = { select => undef, socket => $socket, rqi => 0, wqi => 0, config => { MaxPeers=>($args{MaxPeers}), cntMaxPeers=>0 },
1620 blacklist => { pointer => 0, array => [], bldb => {}} };
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1621 $self->{_bitflu_network}->{$args{ID}}->{select} = new IO::Select or $self->panic("Unable to create new IO::Select object: $!");
1622 $self->{_bitflu_network}->{$args{ID}}->{listentype} = LT_TCP;
c664d5a6 » pab 2007-12-19 More cleanups 1623 $self->{_bitflu_network}->{$args{ID}}->{callbacks} = $args{Callbacks} or $self->panic("Unable to register TCP-Socket without any callbacks");
bfaf9db4 » pab 2008-05-09 multihomed hosts support go... 1624 $self->{_bitflu_network}->{$args{ID}}->{laddr_in} = sockaddr_in(0, ($args{Bind} ? inet_aton($args{Bind}) : INADDR_ANY)) or $self->panic("sockaddr failed");
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1625
1626 if($socket) {
1627 $self->{_bitflu_network}->{$args{ID}}->{select}->add($socket) or $self->panic("Unable to glue <$socket> to select object of $args{ID}: $!");
3b5c9a66 » pab 2007-08-25 initial import 1628 }
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1629
1630 return $socket;
3b5c9a66 » pab 2007-08-25 initial import 1631 }
1632
1633
1634 ##########################################################################
1635 # Creates a new (outgoing) connection
1636 # NewTcpConnection(ID=>UniqueRunnerId, Ipv4=>Ipv4, Port=>PortToConnect);
1637 sub NewTcpConnection {
1638 my($self, %args) = @_;
1639 return undef if(!defined($args{ID}));
1640
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1641 my $bfn_strct = $self->{_bitflu_network}->{$args{ID}};
1642
156d901b » pab 2008-06-08 More blacklisting-love 1643 if($self->{avfds} < 1) {
1644 return undef; # No Filedescriptors left
3b5c9a66 » pab 2007-08-25 initial import 1645 }
156d901b » pab 2008-06-08 More blacklisting-love 1646 elsif($bfn_strct->{config}->{cntMaxPeers} >= $bfn_strct->{config}->{MaxPeers}) {
1647 return undef; # Maxpeers reached
3b5c9a66 » pab 2007-08-25 initial import 1648 }
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1649 elsif($bfn_strct->{listentype} != LT_TCP) {
1650 $self->panic("Cannot create TCP connection for socket of type ".$bfn_strct->{listentype}." using $args{ID}");
1651 }
3b5c9a66 » pab 2007-08-25 initial import 1652
8343f78d » pab 2008-01-06 Some tracker fixes and a re... 1653 if(exists($args{Hostname})) {
156d901b » pab 2008-06-08 More blacklisting-love 1654 # -> Resolve
8343f78d » pab 2008-01-06 Some tracker fixes and a re... 1655 my @xresolved = $self->{super}->Tools->Resolve($args{Hostname});
1656 unless( ($args{Ipv4} = $xresolved[0] ) ) {
1657 $self->warn("Cannot resolve $args{Hostname}");
1658 return undef;
1659 }
1660 }
1661
1662 if($args{Ipv4} !~ /^\d{1,3}\.\d{1,3}\.\d{1,3}\.\d{1,3}$/) {
1663 $self->panic("Invalid IP: $args{Ipv4}");
1664 }
1665
156d901b » pab 2008-06-08 More blacklisting-love 1666 if($self->IpIsBlacklisted($args{ID}, $args{Ipv4})) {
caedb01c » pab 2008-06-29 log command implemented 1667 $self->debug("Won't connect to blacklisted IP $args{Ipv4}");
156d901b » pab 2008-06-08 More blacklisting-love 1668 return undef;
1669 }
3b5c9a66 » pab 2007-08-25 initial import 1670
1671 my $proto = getprotobyname('tcp');
1672 my $sock = undef;
8343f78d » pab 2008-01-06 Some tracker fixes and a re... 1673 my $sin = undef;
1674
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1675 socket($sock, AF_INET,SOCK_STREAM,$proto) or $self->panic("Failed to create a new socket : $!");
bfaf9db4 » pab 2008-05-09 multihomed hosts support go... 1676 bind($sock, $bfn_strct->{laddr_in}) or $self->panic("Failed to bind socket <$sock> to interface : $!");
3b5c9a66 » pab 2007-08-25 initial import 1677 eval { $sin = sockaddr_in($args{Port}, inet_aton($args{Ipv4})); };
1678
1679 if(!defined($sin)) {
1680 $self->warn("Unable to create socket for $args{Ipv4}:$args{Port}");
1681 return undef;
1682 }
1683
1684 $self->Unblock($sock) or $self->panic("Failed to unblock new socket <$sock> : $!");
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1685 if(exists($self->{_bitflu_network}->{$sock})) {
1686 $self->panic("FATAL: DUPLICATE SOCKET-ID <$sock> ?!");
3b5c9a66 » pab 2007-08-25 initial import 1687 }
1688
1689 # Write PerSocket information: establishing | outbuff | config
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1690 $bfn_strct->{establishing}->{$sock} = { socket => $sock, till => $self->GetTime+$args{Timeout}, sin => $sin };
1691 $self->{_bitflu_network}->{$sock} = { sockmap => $sock, handlemap => $args{ID}, fastwrite => 0, lastio => $self->GetTime, incoming => 0 };
156d901b » pab 2008-06-08 More blacklisting-love 1692 $self->{avfds}--;
1693 $bfn_strct->{config}->{cntMaxPeers}++;
3b5c9a66 » pab 2007-08-25 initial import 1694 return $sock;
1695 }
1696
1697
1698 ##########################################################################
1699 # Run Network IO
1700 # Run(UniqueIdToRun,{callbacks});
1701 sub Run {
c664d5a6 » pab 2007-12-19 More cleanups 1702 my($self, $handle_id) = @_;
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1703 my $select_handle = $self->{_bitflu_network}->{$handle_id}->{select} or $self->panic("$handle_id has no select handle");
c664d5a6 » pab 2007-12-19 More cleanups 1704 my $callbacks = $self->{_bitflu_network}->{$handle_id}->{callbacks};
3b5c9a66 » pab 2007-08-25 initial import 1705 $self->SetTime;
1706 $self->_Throttle;
1707 $self->_Establish($handle_id, $callbacks, $select_handle);
1708 $self->_IOread($handle_id, $callbacks, $select_handle);
1709 $self->_IOwrite($handle_id,$callbacks, $select_handle);
1710 }
1711
59365da4 » pab 2007-12-17 BitTorrent::run rewrite, so... 1712 ##########################################################################
1713 # Check establishing-queue
3b5c9a66 » pab 2007-08-25 initial import 1714 sub _Establish {
1715 my($self, $handle_id, $callbacks, $select_handle) = @_;
1716 foreach my $ref (values(%{$self->{_bitflu_network}->{$handle_id}->{establishing}})) {
1717 connect($ref->{socket},$ref->{sin});
1718 if($!{'EISCONN'}) {
1719 delete($self->{_bitflu_network}->{$handle_id}->{establishing}->{$ref->{socket}});
1720 $select_handle->add($ref->{socket});
1721 }
1722 elsif($ref->{till} < $self->GetTime) {
1723 if(my $cbn = $callbacks->{Close}) { $handle_id->$cbn($ref->{socket}); }
1724 $self->{_bitflu_network}->{$handle_id}->{config}->{cntMaxPeers}--;
1725 $self->{avfds}++;
59365da4 » pab 2007-12-17 BitTorrent::run rewrite, so... 1726 delete($self->{_bitflu_network}->{$handle_id}->{establishing}->{$ref->{socket}}) or $self->panic("Cannot remove ".$ref->{socket}." from $handle_id");
1727 delete($self->{_bitflu_network}->{$ref->{socket}}) or $self->panic("Cannot remove ".$ref->{socket});
3b5c9a66 » pab 2007-08-25 initial import 1728 delete($self->{_bitflu_network}->{$handle_id}->{writeq}->{$ref->{socket}});
1729 close($ref->{socket});
1730 }
1731 }
1732 }
1733
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1734 ##########################################################################
1735 # Read from a bunch of sockets
3b5c9a66 » pab 2007-08-25 initial import 1736 sub _IOread {
1737 my($self, $handle_id, $callbacks, $select_handle) = @_;
1738
1739
1740 if($self->{_bitflu_network}->{$handle_id}->{rqi} == 0) {
1741 # Refill cache
1742 my @sq = $select_handle->can_read(0);
1743 $self->{_bitflu_network}->{$handle_id}->{rq} = \@sq;
1744 $self->{_bitflu_network}->{$handle_id}->{rqi} = int(@sq);
1745 }
1746
71598963 » pab 2007-08-26 added support for per-clien... 1747 my $rpr = $self->{super}->Configuration->GetValue('readpriority');
3b5c9a66 » pab 2007-08-25 initial import 1748
1749 while($self->{_bitflu_network}->{$handle_id}->{rqi} > 0) {
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1750 my $handle_ref = $self->{_bitflu_network}->{$handle_id}; # Get HandleID structure
1751 my $tor = --$handle_ref->{rqi}; # Current Index to Read
1752 my $socket = ${$handle_ref->{rq}}[$tor] or $self->panic(); # Current Socket
1753 if($socket eq $handle_ref->{socket} && $handle_ref->{listentype} == LT_TCP) {
3b5c9a66 » pab 2007-08-25 initial import 1754 my $new_sock = $socket->accept();
7eb8f783 » pab 2007-12-22 More debug infos and drop c... 1755 my $new_ip = '';
3b5c9a66 » pab 2007-08-25 initial import 1756 if(!defined($new_sock)) {
1757 $self->info("Unable to accept new socket <$new_sock> : $!");
1758 }
156d901b » pab 2008-06-08 More blacklisting-love 1759 elsif($self->{avfds} < 1) {
3b5c9a66 » pab 2007-08-25 initial import 1760 $self->warn("System has no file-descriptors left, dropping new incoming connection");
1761 $new_sock->close() or $self->panic("Unable to close <$new_sock> : $!");
1762 }
1763 elsif(!$self->Unblock($new_sock)) {
1764 $self->info("Unable to unblock $new_sock : $!");
1765 $new_sock->close() or $self->panic("Unable to close <$new_sock> : $!");
1766 }
7eb8f783 » pab 2007-12-22 More debug infos and drop c... 1767 elsif(!($new_ip = $new_sock->peerhost)) {
9c5f3648 » pab 2007-12-23 Storage Checking 1768 $self->debug("Unable to obtain peerhost from $new_sock : $!");
7eb8f783 » pab 2007-12-22 More debug infos and drop c... 1769 $new_sock->close() or $self->panic("Unable to close <$new_sock> : $!");
1770 }
156d901b » pab 2008-06-08 More blacklisting-love 1771 elsif($handle_ref->{config}->{cntMaxPeers} >= $handle_ref->{config}->{MaxPeers}) {
3b5c9a66 » pab 2007-08-25 initial import 1772 $self->warn("Handle <$handle_id> is full: Dropping new socket");
1773 $new_sock->close() or $self->panic("Unable to close <$new_sock> : $!");
1774 }
156d901b » pab 2008-06-08 More blacklisting-love 1775 elsif($self->IpIsBlacklisted($handle_id, $new_ip)) {
1776 $self->warn("Refusing incoming connection from blacklisted IP $new_ip");
1777 }
3b5c9a66 » pab 2007-08-25 initial import 1778 else {
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1779 $self->{_bitflu_network}->{$new_sock} = { sockmap => $new_sock, handlemap => $handle_id, fastwrite => 0, lastio => $self->GetTime, incoming => 1 };
3b5c9a66 » pab 2007-08-25 initial import 1780 $select_handle->add($new_sock);
156d901b » pab 2008-06-08 More blacklisting-love 1781 $self->{avfds}--;
1782 $handle_ref->{config}->{cntMaxPeers}++;
7eb8f783 » pab 2007-12-22 More debug infos and drop c... 1783 if(my $cbn = $callbacks->{Accept}) { $handle_id->$cbn($new_sock,$new_ip); }
3b5c9a66 » pab 2007-08-25 initial import 1784 }
1785 }
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1786 elsif(exists($self->{_bitflu_network}->{$socket})) {
30afc404 » pab 2007-12-18 Added read-loop 1787 my $full_buffer = '';
1788 my $full_bufflen = 0;
1789 my $last_bufflen = 0;
1790
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1791 for(0..8) {
30afc404 » pab 2007-12-18 Added read-loop 1792 my $pb = '';
ca8e7c3f » pab 2007-12-18 Fixed unchoking 1793 $last_bufflen = ( read($socket,$pb,POSIX::BUFSIZ) || 0 ); # Removes warnings ;-)
30afc404 » pab 2007-12-18 Added read-loop 1794 $full_buffer .= $pb;
1795 $full_bufflen += $last_bufflen;
c664d5a6 » pab 2007-12-19 More cleanups 1796 last if $last_bufflen != POSIX::BUFSIZ;
30afc404 » pab 2007-12-18 Added read-loop 1797 }
1798
1799 if($full_bufflen != 0) {
1800 # We read 'something'. If there was an error, we'll pick it up next time
1801 $self->{stats}->{raw_recv} += $full_bufflen;
3b5c9a66 » pab 2007-08-25 initial import 1802 $self->{_bitflu_network}->{$socket}->{lastio} = $self->GetTime;
30afc404 » pab 2007-12-18 Added read-loop 1803 if(my $cbn = $callbacks->{Data}) { $handle_id->$cbn($socket, \$full_buffer, $full_bufflen); }
3b5c9a66 » pab 2007-08-25 initial import 1804 }
1805 else {
1806 if(my $cbn = $callbacks->{Close}) { $handle_id->$cbn($socket); }
1807 $self->RemoveSocket($handle_id,$socket);
1808 }
1809 }
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1810 elsif($handle_ref->{listentype} == LT_UDP) {
156d901b » pab 2008-06-08 More blacklisting-love 1811 my $new_ip = '';
46202084 » pab 2007-11-10 First UDP-Socket support 1812 my $buffer = undef;
156d901b » pab 2008-06-08 More blacklisting-love 1813
1814 $socket->recv($buffer,POSIX::BUFSIZ); # Read data from socket
1815
1816 if(!($new_ip = $socket->peerhost)) {
1817 # Weirdo..
1818 $self->warn("<$socket> had no peerhost, data dropped");
1819 }
1820 elsif($self->IpIsBlacklisted($handle_id, $new_ip)) {
1821 $self->warn("Dropping UDP-Data from blacklisted IP $new_ip");
1822 }
1823 elsif(my $cbn = $callbacks->{Data}) {
1824 $handle_id->$cbn($socket, \$buffer);
1825 }
46202084 » pab 2007-11-10 First UDP-Socket support 1826 }
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1827 else {
1828 $self->warn("Skipping read from <$socket> / Not active?");
1829 }
3b5c9a66 » pab 2007-08-25 initial import 1830 last if --$rpr < 0;
1831 }
1832 }
1833
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1834 ##########################################################################
1835 # Write to some sockets
3b5c9a66 » pab 2007-08-25 initial import 1836 sub _IOwrite {
1837 my($self, $handle_id, $callbacks, $select_handle) = @_;
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1838
1839 my $handle_ref = $self->{_bitflu_network}->{$handle_id};
3b5c9a66 » pab 2007-08-25 initial import 1840
59365da4 » pab 2007-12-17 BitTorrent::run rewrite, so... 1841 if($handle_ref->{wqi} == 0) {
3b5c9a66 » pab 2007-08-25 initial import 1842 # Refill cache
59365da4 » pab 2007-12-17 BitTorrent::run rewrite, so... 1843 my @sq = (values(%{$handle_ref->{writeq}}));
1844 $handle_ref->{wq} = \@sq;
1845 $handle_ref->{wqi} = int(@sq);
3b5c9a66 » pab 2007-08-25 initial import 1846 }
1847
1848 my $wpr = $self->{super}->Configuration->GetValue('writepriority');
59365da4 » pab 2007-12-17 BitTorrent::run rewrite, so... 1849 while($handle_ref->{wqi} > 0) {
1850 my $tow = --$handle_ref->{wqi};
1851 my $socket = ${$handle_ref->{wq}}[$tow];
1852 $self->panic("No socket!") unless $socket;
c664d5a6 » pab 2007-12-19 More cleanups 1853 next unless exists($self->{_bitflu_network}->{$handle_id}->{writeq}->{$socket}); # Socket vanished or no writequeue
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1854 $self->_TryWrite(Socket=>$socket, Handle=>$handle_id, CanKill=>1);
3b5c9a66 » pab 2007-08-25 initial import 1855 last if --$wpr < 0;
1856 }
1857 }
1858
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1859
1860 ##########################################################################
1861 # Try to write data to a socket
c664d5a6 » pab 2007-12-19 More cleanups 1862 sub _TryWrite {
1863 my($self, %args) = @_;
1864
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1865 my $socket = $args{Socket} or $self->panic;
1866 my $handle_id = $args{Handle} or $self->panic;
1867 my $socket_strct = $self->{_bitflu_network}->{$socket} or $self->panic;
1868 my $handle_strct = $self->{_bitflu_network}->{$args{Handle}} or $self->panic;
1869 my $select_handle = $handle_strct->{select} or $self->panic;
1870 my $bufsize = ($self->{bpc} + $socket_strct->{fastwrite}) or $self->panic;
1871 my $cankill = $args{CanKill};
c664d5a6 » pab 2007-12-19 More cleanups 1872
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1873 if(!$select_handle->exists($socket)) { return; } # not yet connected
c664d5a6 » pab 2007-12-19 More cleanups 1874
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1875 my $bytes_sent = syswrite($socket, $socket_strct->{outbuff}, ($bufsize > (POSIX::BUFSIZ) ? (POSIX::BUFSIZ) : $bufsize) );
c664d5a6 » pab 2007-12-19 More cleanups 1876
1877 if($!{'EISCONN'}) {
1878 #$self->debug("EISCONN returned.");
1879 }
1880 elsif(!defined($bytes_sent)) {
1881 if($!{'EAGAIN'} or $!{'EWOULDBLOCK'}) {
1882 #$self->warn("$wsocket returned EAGAIN");
1883 }
1884 elsif($cankill) {
1885 if(my $cbn = $handle_strct->{callbacks}->{Close}) { $handle_id->$cbn($socket); }
1886 $self->RemoveSocket($handle_id,$socket);
1887 }
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1888 else {
97dfa070 » pab 2008-01-12 Some http-gui addons and fi... 1889 $self->debug("Delaying kill of $handle_id -> $socket [Write failed with: $!]");
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1890 }
c664d5a6 » pab 2007-12-19 More cleanups 1891 }
1892 else {
1893 $self->{stats}->{raw_sent} += $bytes_sent;
1894 $socket_strct->{qlen} -= $bytes_sent;
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1895 $socket_strct->{outbuff} = substr($socket_strct->{outbuff},$bytes_sent);
1896 $socket_strct->{fastwrite} = 0 if( ($socket_strct->{fastwrite} -= $bytes_sent) < 0);
c664d5a6 » pab 2007-12-19 More cleanups 1897 if($socket_strct->{qlen} == 0) {
1898 delete($handle_strct->{writeq}->{$socket}) or $self->panic("Deleting non-existing socket: Handle: $handle_id ; Sock: $socket");
1899 }
1900 }
1901 }
3b5c9a66 » pab 2007-08-25 initial import 1902
1903
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1904 ##########################################################################
1905 # Calculate new value for bcp
3b5c9a66 » pab 2007-08-25 initial import 1906 sub _Throttle {
1907 my($self) = @_;
1908 return if $self->GetTime <= $self->{stats}->{nextrun};
1909 my $UPSPEED = $self->{super}->Configuration->GetValue('upspeed') * 1024;
1910
1911 if($self->{stats}->{nextrun} != 0) {
1912 my $resolution = $self->GetTime - $self->{stats}->{nextrun} + NETSTATS;
1913 $self->{stats}->{sent} = $self->{stats}->{raw_sent} / $resolution;
1914 $self->{stats}->{recv} = $self->{stats}->{raw_recv} / $resolution;
1915 $self->{stats}->{raw_sent} = 0;
1916 $self->{stats}->{raw_recv} = 0;
1917 # Throttle upspeed
1918 my $current_upspeed = $self->{stats}->{sent};
1919 my $wanted_upspeed = $UPSPEED;
1920 my $upspeed_drift = $UPSPEED-$current_upspeed;
1921 my $upspeed_adjust = 1; # = Nothing
1922
1923 if($upspeed_drift < -500) {
1924 $upspeed_adjust = ($wanted_upspeed/($current_upspeed+1));
1925 }
1926 elsif($upspeed_drift > 500) {
1927 $upspeed_adjust = ($wanted_upspeed/($current_upspeed+1));
1928 }
1929
1930 $upspeed_adjust = 1.3 if $upspeed_adjust > 1.3; # Do not bump up too fast..
1931 $self->{bpc} = int($self->{bpc} * $upspeed_adjust);
1932 if($self->{bpc} < BPS_MIN) { $self->{bpc} = BPS_MIN }
1933 elsif($self->{bpc} > POSIX::BUFSIZ) { $self->{bpc} = POSIX::BUFSIZ }
1934 }
1935
1936 $self->{stats}->{nextrun} = NETSTATS + $self->GetTime;
1937 }
1938
1939
1940
1941 ##########################################################################
1942 # Remove socket
1943 # RemoveSocket(UniqueRunId, Socket)
1944 sub RemoveSocket {
1945 my($self,$handle_id, $socket) = @_;
1946
1947 if($self->{_bitflu_network}->{$handle_id}->{select}->exists($socket)) {
1948 $self->{_bitflu_network}->{$handle_id}->{select}->remove($socket) or $self->panic("Unable to remove <$socket>");
1949 }
1950 elsif(delete($self->{_bitflu_network}->{$handle_id}->{establishing}->{$socket})) {
1951 # Kill unestablished sock
1952 }
1953 else {
1954 $self->panic("FATAL: <$socket> was not attached to IO::Select and not establishing!");
1955 }
1956
1957 # Correct statistics
1958 $self->{_bitflu_network}->{$handle_id}->{config}->{cntMaxPeers}--;
1959 $self->{avfds}++;
1960
1961 # Wipe socket itself + writeq
1962 delete($self->{_bitflu_network}->{$socket}) or $self->panic("Unable to remove non-existent socketmap for <$socket>");
1963 delete($self->{_bitflu_network}->{$handle_id}->{writeq}->{$socket});
1964 close($socket) or $self->panic("Unable to close socket $socket : $!");
1965 }
1966
46202084 » pab 2007-11-10 First UDP-Socket support 1967
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1968 ##########################################################################
1969 # Send UPD datagram
46202084 » pab 2007-11-10 First UDP-Socket support 1970 sub SendUdp {
1971 my($self, $socket, %args) = @_;
1972 my $ip = $args{Ip} or $self->panic("No IP given");
1973 my $port = $args{Port} or $self->panic("No Port given");
156d901b » pab 2008-06-08 More blacklisting-love 1974 my $id = $args{ID} or $self->panic("No ID given");
46202084 » pab 2007-11-10 First UDP-Socket support 1975 my $data = $args{Data};
156d901b » pab 2008-06-08 More blacklisting-love 1976 if($self->IpIsBlacklisted($id, $ip)) {
1977 $self->warn("Won't send UDP-Data to blacklisted IP $ip");
1978 return undef;
1979 }
1980 else {
1981 my $hisip = IO::Socket::inet_aton($ip);
1982 my $hispn = IO::Socket::sockaddr_in($port, $hisip);
1983 my $bs = send($socket,$data,0,$hispn);
1984 return $bs;
1985 }
46202084 » pab 2007-11-10 First UDP-Socket support 1986 }
1987
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1988 ##########################################################################
1989 # FastWrite data
c664d5a6 » pab 2007-12-19 More cleanups 1990 sub WriteDataNow {
1991 my($self,$socket,$buffer) = @_;
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 1992 $self->{_bitflu_network}->{$socket}->{fastwrite} += length($buffer);
c664d5a6 » pab 2007-12-19 More cleanups 1993 $self->WriteData($socket,$buffer);
1994 }
1995
3b5c9a66 » pab 2007-08-25 initial import 1996 ##########################################################################
1997 # Write Data to socket
1998 # WriteData(UniqueRunId, Socket, DataToWRite)
1999 sub WriteData {
2000 my($self, $socket, $buffer) = @_;
2001
2002 my $gotspace = 1;
61deb2b5 » pab 2008-01-01 A new monster commit :-) 2003 my $queued_bytes = $self->GetQueueLen($socket);
3b5c9a66 » pab 2007-08-25 initial import 2004 my $this_bytes = length($buffer);
2005 my $total_bytes = $queued_bytes + $this_bytes;
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 2006 my $handle_id = $self->{_bitflu_network}->{$socket}->{handlemap} or $self->panic("No handleid for $socket ?");
3b5c9a66 » pab 2007-08-25 initial import 2007
2008 if($total_bytes > MAXONWIRE) {
61deb2b5 » pab 2008-01-01 A new monster commit :-) 2009 $self->warn("<$socket> Buffer overrun! Too much unsent data: $total_bytes bytes");
3b5c9a66 » pab 2007-08-25 initial import 2010 $gotspace = 0;
2011 }
a90f2309 » pab 2007-12-20 New netiolob release + bugf... 2012 elsif($self->{_bitflu_network}->{$handle_id}->{listentype} != LT_TCP) {
2013 $self->panic("Cannot write tcp data to non-tcp socket $socket ($self->{_bitflu_network}->{$handle_id}->{listentype})");
2014 }
3b5c9a66 » pab 2007-08-25 initial import 2015 else {
2016 $self->{_bitflu_network}->{$socket}->{outbuff} .= $buffer;
2017 $self->{_bitflu_network}->{$socket}->{lastio} = $self->GetTime;
2018 $self->{_bitflu_network}->{$socket}->{qlen}