Helper classes

One thing we want to do is output a log. When i wrote the original code some years ago, i didn't remember that there are quite good logging modules, so i rolled my own. It's simple enough, so for the purpose of this tutorial we use it. Just save the following to the file "TextLogger.pm":

package TextLogger;
use strict;
use warnings;

use Helpers;

sub new {
    my ($class, %config) = @_;
    my $self = bless \%config, $class;

    
    $self->log("Logfile for " . $self->{appname} . " (re)started");
    return $self;
}

sub log {
    my ($self, $logline) = @_;
    
    my $fullline = Helpers::getISODate() . "  $logline\n";
    
    open($self->{fh}, ">>", $self->{logfile});
    print {$self->{fh}} $fullline;
    close($self->{fh});
    print $fullline . "\n";
}

sub alive {
    my ($self) = @_;
    
    $self->log("-- " . $self->{appname} . " is alive --");
}

sub DESTROY {
    my ($self) = @_;
    
    $self->log("Stopping logfile");
    
}

1;
[download]

What the logging module does for us is simply opening the configured logfile whenever we want to output a logline, prepend the current ISO timestamp and reclose the file. It also automatically logs when the service is started or stopped, or rather, whenever the object is created and destroyed. But the way we are going to use it, the two are synonymous. There's also the alive() function which just outputs an "i'm alive" message when there is nothing else to log and we just want to know that the service hasn't crashed and/or burned yet.

Writing the server

Now that we got all the (one) helper module(s) sorted out, let's get right down to writing the server. Our ENNTP - which stands for "extremly naive network time protocol" works this way: The client connects to the server at port 64100. The server sends an ISO date string, a carriage return and line feed (windows newline) and closes the connection. Sounds easy enough.

Here's the full server code, save it to TimeServer.pl:

package PerlSvc;
use strict;
use warnings;

use Time::HiRes qw( sleep );
use IO::Socket;
use TextLogger;

# the short name by which your service will be known (cannot be 'my')
our $Name = "pmtimesrv";
# the display name. This is the name that the Windows Control Panel
# will display (cannot be 'my')
our $DisplayName = "PerlMonks Time Server";

# the startup routine is called when the service starts
sub Startup {
    # Start listening to our server socket
    my $server = IO::Socket::INET->new(LocalPort => 64100,
                                Type      => SOCK_STREAM,
                                Reuse     => 1,
                                Listen    => 10 )   # or SOMAXCONN
    or die "Couldn't be a Time server on port 64100 : $@\n";

    my $oldfh = select($server);
    $| = 0;
    select($oldfh);
    my $temp = 1;
    ioctl ($server, 0x8004667E, \$temp); # set non-blockin

    # Make a new logger
    my $logfilename = 'C:\Programme\PerlMonks\TimeServer.log';
    my $logger = new TextLogger(logfile        => $logfilename,
                appname        => 'TimeServer');

    $logger->log("Starting to serve timestamps");

    my $alivecount = 36000;

    while (ContinueRun()) {
    $alivecount--;
    if(!$alivecount) {
        $alivecount = 36000;
        $logger->alive();
    }
    
        my $client = $server->accept();

        # see if there are new clients waiting
        if(!defined($client)) {
            # ok, no client waiting, sleep a short time and retry
            sleep(0.1);
            next;
        }
    $logger->log("Connection from: " . $client->peerhost);
    print $client getDateTime();
    close $client;
    }
    
    $logger->log("Someone has set up us the bomb!"); # mandatory AYBAB
+TU quote
}

sub Install {
    # add your additional install messages or functions here
    print "The $Name Service has been installed.\n";
    print "Start the service with the command: net start $Name\n";
}

sub Remove {
    # add your additional remove messages or functions here
    print "The $Name Service has been removed.\n";
}

sub Help {
    # add your additional help messages or functions here
    print "$Name Service -- use '--install' to install, '--remove' to 
+uninstall. Or run interactive.\n";
}

sub Interactive {
    Startup();
}

# ---- HELPERS ----

sub doPad {
    my ($val, $len) = @_;
    while(length($val) < $len) {
    $val = "0$val";
    }
    return $val;
}

sub getDateTime {
    my ($sec,$min,$hour,$mday,$mon,$year,$wday,$yday,$isdst) = localti
+me(time());

    return    doPad($mday,2) . "-" .
        doPad($mon+1,2). "-" .
        ($year + 1900) . " " .
        doPad($hour,2) . ":" .
        doPad($min, 2) . ":" .
        doPad($sec, 2) . "\n";

}
[download]

The basic framework of functions were provided by ActiveState in one of its examples. Since we don't have any special requirements, we just fill in the functions Install(), Remove() and Help() with some custom messages. Startup() is the function called when the service starts, Interactive() when starting from the command line. For us, it makes no difference, so Interactive() just calls Startup().

The Startup() function is where all the magic happens. First thing we do is binding to port 64100. If that fails, there's no point in continuing and we just die(). If opening the socket works, we set it to non-blocking. This way, we can react to events and run our main loop even without having clients connecting to the server.

Next thing we do is, we create a new logger and enter the main loop.

The main loop is terminated if ContinueRun() returns false, e.g. when Windows notifies the service (through a PerlSVC provided function) that it wants the service to terminate. Windows is generally a bit too polite about this: If we just ignore ContinueRun() and keep on going anyway, the windows service manager has no way of stopping the service - only using the taskmanager or shutting down windows can knock out the service in this way.

The first thing we do in main loop is to check if we want to send out one of the regular "i am still alive and running" messages to the log file.

Then we try to handle the next client connection. Remember, we unblocked the socket, so we get undef if there is no client waiting. If we hadn't unblocked, the accept() would wait - if no client connects - until the end of the universe (or next system crash) for an incoming client connection, effectively disabling the Windows service managers ability to stop the service. If there's no client connection, we just sleep a short time (no use in wasting CPU power in full-thrust busy looping).

If there is a client waiting for us, we log its IP, send the current ISO date string to the socket, close the connection and immediately loop again.

So, in effect, when no clients are around, the service spends most of its time just sleeping, only log log about once an hour an alive() message. Under DDOS conditions, we just serve as many connections as possible, most likely encountering a network bottleneck long before we run out of CPU power. The intended usage scenario for this service is somewhere inbetween (depending on if your 50.000 computers domain administrator discovers your services and decides to use it).

Writing the client

The client is quite similar in nature, since it uses the same PerlSVC layout. So, put the following code into TimeClient.pl:

package PerlSvc;
use strict;
use warnings;

use IO::Socket;
use Time::HiRes qw( sleep );
use Data::Dumper;
use TextLogger;
use Helpers;

# the short name by which your service will be known (cannot be 'my')
our $Name = "pmtimeclnt";
# the display name. This is the name that the Windows Control Panel
# will display (cannot be 'my')
our $DisplayName = "PerlMonks Time Client";

# the startup routine is called when the service starts
sub Startup {
    my $waitcount = 300; # <- Wait 30 seconds at startup for things to
+ settle down...
    my $logfilename = 'C:\Programme\PerlMonks\TimeClient.log';
    my $logger = new TextLogger(logfile        => $logfilename,
                appname        => 'TimeClient');
    my $alivecount = 36000;

    while (ContinueRun()) {
    $alivecount--;
    if(!$alivecount) {
        $alivecount = 36000;
        $logger->alive();
    }
    
    $waitcount--;

    if(!$waitcount) {
        $logger->log("Start of syncronize cycle");
        my $socket = IO::Socket::INET->new(PeerAddr => "127.0.0.1",
                    PeerPort => 64100,
                    Proto    => "tcp",
                    Type     => SOCK_STREAM);

        if(!$socket) {
        #print "Socket error...\n";
        $waitcount = 600; #try again in a minute
        $logger->log("Socket error");
        } else {
        foreach my $line (<$socket>) {
            $logger->log("Parsing reply...");
            if($line =~ /(\d\d-\d\d-\d\d\d\d)\ (\d\d\:\d\d\:\d\d)/) {
            my ($dstamp, $tstamp) = ($1, $2);

            system("cmd.exe /c date $dstamp");
            system("cmd.exe /c time $tstamp");
            $logger->log("SET: Date = $dstamp / Time = $tstamp");
            }
        }
        close $socket;
        $waitcount=36000; # wait an hour
        }
    }
    sleep(0.1);
    
    }
    $logger->log("For great justice!"); #AYBABTU!!1!
}

sub Install {
    # add your additional install messages or functions here
    print "The $Name Service has been installed.\n";
    print "Start the service with the command: net start $Name\n";
}

sub Remove {
    # add your additional remove messages or functions here
    print "The $Name Service has been removed.\n";
}

sub Help {
    # add your additional help messages or functions here
    print "$Name Service -- add custom help message here.\n";
}

sub Interactive {
    Startup();
}
[download]

Ok, let's take a look at Startup(). We can ignore all the looping and alive()-handling, this is the same as in the server.

The first 30 seconds or so we do... nothing. This has no immediate effect on interactive startup (except keeping the user waiting a bit longer). On system boot, this helps a bit, though. Since we don't really bother to handle the correct sequence of service startups (by registering dependencies), but we still want network connectivity to syncronise, we just wait and hope that windows has configured the network interface when we finally do some work. It's not ideal, but at least in my network it gets the job done.

Next, we try to connect to the server. If that fails, we reschedule the next connection in about 60 seconds plus a few fractions. The timing system is not very precise, since we are just counting how many times we sleep() at least a certain interval. But it don't really matter, it get's the job done.

If we get a connection, we read in all lines we recieve and try to find a datestring (be strict in what you send and liberal what you recieve). If we find something that looks like a datestring, we twice call cmd.exe, once with the date, once with the time. A very crude and simple method, but again, as long as all the windows clients use the same date and time formats (mine do), it gets the job done.

When we parsed all the lines - which there should be only one of anyway - we close the socket and reschedule the next sync run in 36000 tenths of seconds, which is 3600 seconds or 60 minutes which is an hour.

On-demand splash

First of all, we'll need a very simple splash screen. For size/posting reasons, it's a base64 encoded gzip of a bmp file. Save it to "clock.bmp.gz.base64":

H4sICEUa804CA2Nsb2NrLmJtcADNWndYlEcT/ykoiAUVgyXG3rDH2MWOiN2onyUqGBv2Gi
+vWxJqo
GDU2sFcsWFEUe0ExohSxIaAoRQEr7KTn23J3HAd3nMgf2eeB2zK7szszO23fdt2q1YIs9p
+ZADf47
XPOXB9ayv2h1wK6g+vsN6k+UPHnyIG/evLCwsIClpSXy5cuH/Pnzw8rKCtbW1ihQoABsbG
+xQsGBB
FCpUCIULF0aRIkVga2uLokWLolixYrCzs0OJEiXw2Wefwd7eHiVLlkSpUqVQunRplClTBp
+9//jnK
li2LL774AuXKlUP58uVRoUIFVKxYEZUqVULlypVRpUoVVK1aFdWqVUP16tVRo0YNODg4oG
+bNmqhV
qxZq166NOnXqoG7duqhXrx7q16+PL7/8El999RUaNmyIRo0aoXHjxmjSpAmaNm2KZs2aoX
+nz5mjR
ogUcHR3RqlUrtG7dGm3atEHbtm3Rrl07tG/fHk5OTujQoQOcnZ3RsWNHuLi4oFOnTujcuT
+O6dOmC
rl27olu3bujevTt69OiBnj174uuvv0avXr3Qu3dv9OnTB3379kX//v0xYMAAfPPNNxg4cC
+AGDRqE
wYMHw9XVFW5ubhgyZAi+/fZbDB06FMOGDcPw4cMxYsQIuLu7Y9SoURg9ejTGjBmDsWPHYt
+y4cRg/
fjwmTpyISZMmYfLkyZgyZQqmTp2KadOmYfr06ZgxYwZmzpyJWbNmYfbs2fDw8MCcOXMwd+
+5czJs3
D/Pnz8eCBQuwcOFCfP/99/jhhx+waNEiLF68GEuWLMHSpUuxbNkyLF++HD/++CN++uknrF
+ixAitX
rsSqVavg6emJ1atX4+eff8aaNWuwdu1arFu3Dr/88gvWr1+PDRs2YOPGjdi0aRM2b94MLy
+8veHt7
Y8uWLdi6dSu2bduG7du3Y8eOHdi5cyd27dqF3bt3Y8+ePdi7dy/27duH/fv3w8fHBwcOHM
+DBgwdx
6NAhHD58GL6+vjhy5AiOHj2KY8eO4fjx4zhx4gROnjwJPz8/nDp1CqdPn4a/vz/OnDmDs2
+fPIiAg
AOfOncP58+dx4cIFXLx4EZcuXcLly5dx5coVXL16FdeuXcP169cRGBiIGzdu4ObNmwgKCs
+KtW7fw
66+/4vbt2wgODsadO3dw9+5dhISEIDQ0FGFhYQgPD8e9e/cQERGB+/fv48GDB3j48CEePX
+qEx48f
IzIyEk+ePEFUVBSio6MRExODp0+f4tmzZ4iNjcXz58/x4sULxMXFIT4+HgkJCUhMTMTLly
+/x6tUr
JCUlITk5GSkpKXj9+jXevHmDt2/f4t27d3j//j0+fPiA1NRUpKWlgTEGIsJvv/2G33//HX
+/88Qf+
/PNP/PXXX/j777/xzz//4N9//xUw/63yKuLSob17D12MeClaLDeX5ovFbh/frBj0StHGY7
+dE5R6e
N15dCyHLYt1xw6vcOIFnc5gsDVd+0mkYPexrsGJhu1Kl7QobdPYKySkWRpebpK9ToMfcg8
+Gp2rHU
275zehTQO8zlnGDhZ2ikW6L71kTSkySmqSTu6JlXC9Ig9KOxsHdu2tltfNTijNIWB5O3s7
+MnXV2m
Y9fRjlq4/6V85CF886iJRWaniJUYXbN/w2/0zzQDcKfZVkSPy4aqkffzS2iw7PiIo7BUFw
+2H18j2
wdZET3CcqPB0hcPNgZgXPhA1OiUBvOwUvOM7s5Hc1XBzkdhmGLFdeMDPMJuotqvC0aYDkW
+sZYgEI
kABEKxVj8l81E8UahaH1W9HwkFpvLlGTxkTzNiscS/n57PsQDc9L9Bqekldd1KwfzKAXo/
+ES1uIw
r/qMpLdYTuRYluh2vJwtcQiw6HuMMIBoAt9E/5O8w1+d3i1bJIy6ScgmnLKpdYFg6l+MKC
+hON0+D
Q5XHERzPZDoDNOVT09rLqa2yQcJIaY5JEq4V4EDhDRP0ITLg4CWi1msqxa+6nPy9nFyPMZ
+MoWkoo
b15v7EFPeXWngTYyxMEHl3OwFBrZkbcOKSQmT9JdwtwQ1Wm4Q6MAGwMIQxz8tvIZ8+k0Vo
+hWmGV2
5JokAPKFcgbzhkNxIgtgWjY4aDBQjF5atCExjUUWUow3VjbIU4QwCuQkYi+qPaW1vP2SGW
+xjSIZj
3OMgR1ho5Q+MfuL3iEVaKhHOmhmhEsU1UXfFVSY1XzmuEDNApaWmpmXoqA80VmryIKaLZc
+LkMldZ
lvy2FWNeXCIl71XnJd510xQH93GASAkQj//x/w81jM+fpVrpIYYmEJf2VRyJn6bXCahqSt
+q5vRqm
qR7g06aBs1KKsGMWx/CTtkZUv8NUnVywOH6/koyjeFwdeXTXgVFfJV3tlRbORCkLEUilSH
+BP3Eof
WXDUlLQz2rgpvcVdYNmZJtVKiuG8kaJ3N1HzXXxegsEtM7skcOjVzsT8pdEy2E6M6GzGxa
+Yf+nyS
m8HayfsjtXBoxoWcRF8yk4LS8VO8pcqWZyW1hD1pkAF7uEDhwe1a33cU+fRTzhGSRG/7NO
+JGS6x4
WX8lZ+H0ETvKfxZ/mn/JaCFf5CgjO62YavqFghW2aKCM6v1zjoXRCWnaB3Ibr9FL2jJUOG
+li5YDS
0tuJzSmGKGl+ylwQdeGt9EofFHdjPNE6UsZAXvecFHkBwB1gWks0X9R16LeJVhydRQGuLt
+9Jglnv
/3gMXlLjuqWx99Pz4ld6r8UnSwfeaCR8y9Fw4YcMFemWfR+PY50QV67dqUqeKcKn6ajHdS
+YQbuXa
mft8z6Trt8OmQU5IVcn2gHQdHymfWEgpVHzCfBThfIP09EZUTtzwx+lON13hilvcww2qq5
++0wFQR
tqNiKVfKPVdrQaWefGGN0ijDq56cUOfchAubGyXcctQVTvod8maLIvwKRKgT5l6oKlZKFC
+tHidYR
xY7w3IyGxUJ828KMbBH1ObzSkvvNqDHEHHZEB8VkDxQ2qBKKK/M9VqsPeeXJFld7c7Y4Ef
+myB3r0
xdCdMWr7jUW7onA+mdnsGIzaZpPLVyQLRENogADzzWprOJuHQPiNWpUlfmNpavEGPX3M2Z
++DdDSz
282a7vVtF7NUsfZLbuYVrvMLvm2/05xzFMZM/n9PjUkmoZZ0GrHwmto/l68QiYOZLbfAL7
+TINpPX
kTXFREbiItEF/sPDus0zdGWiqXkpQFs+Y1R81ptKG+KuKzxOFEbxEJG/uvDOevkPUzsTyr
+ToUqMM
SdVbhsuGMKt7FQ4rc3HsqZmVk2kcRymFQ0Mr73RaTTAmjoINlWEyPZg2KX0dbx2twrQ7Z6
+a8T0Zx
7pINi7hzYfYdlDy/pJPdm+vnDTnJjMIHdlZsoBGoYA4G7xHzNwXrZFdzB8egdIP1pthQe7
+8mKm1h
Do659UphrrqDwtrmN6lLNGzoEqQZ/JL73GbrkmAtHyrx300saxyM4kdlvA1lhCNmbjkIEf
+PywimN
ccQ+nJrVJBOGIO7j2y7SRw4sM0MjPGu14Ay33nNVwKH8OWmjCrY1sD77awM19xiqkt1mHC
+DIMR8K
Kxslj31cEe3qSwOCLi0KdA40oN8TKYvmlOc3la3drrua9yljUlKywT0uE4eu8EjZbHYkKp
+EVhcf5
PBxlFOFR3igbdFIMc14BYqosiuK+z1a+cCHVM0hF03U4aZ4YY4O2/GgWjiCumtuoDE9Xte
+3DiiE7
j6Wz4a4xvToBJY1fiiQ9X/TAAXW7vZhWVoCN0qdWbHh9saSxi9YX9Yxv/yuH29LzeKV8au
+lHv9GM
dZF5LZW+4myIbc3b17M+iCO6GT2GoMfXybxW116GHW14u7l2UPiliGbnFRvGSOW/2oj7j6
+FGj7FQ
TpxF9HAwcFtYTIicqaaIp+LRHCiVaH0+aLeTVbHBPOPXPL6zTDxzo/RhAdHsjOZOmAYLQc
+pAobxQ
PcioB8EDClOa8FoFMb9uiKgX4bW+6WPShiwQHBWZJ2/jPspLwM+0vlV0cNdkoh/qreQiD0
+Ibswtp
bwF3s7scY/kie5QJbJIplzGZqJrTC0pOMk7xE0CyacPxjCjWqSY3OplyGTIGRTzjTL9o3c
+lk6JrN
KaqW4MxIZW+hiZX10Mer3C+xCWjx1vg5PLT6x+g54mqKBwBqbcgNFVbwspm7zMsMOa7fHI
+Lq2eWv
aEYjjXrKnOSV6blEueBhhKT3e+oLsosIgDNu4KCezfLDdZW6lonDTJlRmWWFg3wR1HMLGJ
+fWfq91
zToio5MhcmuqF1aJlK3U1/I9zjcLkg/QnO+sTItqT9IN+Ez/mht6DFbAGK1g82muCNak1F
+2yvD7F
NVkskdLvrckhB/Iuv/QNBZ++bzBtCweIkQAJcm+B3H+T74mpWSaqI6VOOy3qU+GrQhKuW1
+qYTpI6
SAgBvEold2/IZe4aEc7dcpSzLVDY3jedkmWWPzoDtBuQIT5hdzjISRbrzJF8h0farP2abL
+QzRyJy
m02tkogrn5EZQbj6nGFotmBHD9CbV8/wsEzqK1N+nms6uZbgglA9FgbkyYRDvrEspF3YIl
+rX5ALd
TKrNTlCMZ1RrrHwrWmvAA0McfHAxB3tN/QTfZKKSGz9mBhI3yURuLMtTTP9XpnBE90gle3
+BKpfEJ
E+Tkltk+rClyOSRyzcZF5goNtSIWlT5LHwej51z5zRfhntDiKQ3VI7UZD4SK8Vx3Mdrah5
+hQcU6f
c41N8g1Cg0P4MIyEcR/Gg8l+4g1ydx69Z7/sihJh1ItXmpbre3xH1LwBD7CPKRy7fIiKfs
+NVg43Q
2KvFzpKbqVkbzPRTI4sr+Mli8hViB3CHh0K8VXugwtGCm5j+FYidEs9O8hMADzXDNtT8DN
+cANcVi
gRScnXV4RMFvPhWbonAMqkNsndA2lX3lhOXqGzj0+JgHdLqked62GB2tkk4X8yVxmq1WOG
+baED2w
uaNG4sZrYf0+LpHHlNGSfNmo7WJTbpCns7M3nZuuuxxbdV89jMxBqjBe96UCHFfcJ+1HDf
+oZQ89W
OhCnmJx9mRHuopeZaDluU4Au3xgb4D22pX7aIjznX5gkuFsbfK+S18o6r0GXxdCnn/alDO
+3oYvpb
nA7bPj1ny+cfHlQu6/XL9PNhuZQU5qukHp/fuVL+9NUtKzrPOfIul7/BUiUh7IK//4WQBP
+rPlf8D
MsEJPyYrAAA=
[download]

Ok, we need to extract that (i only know how to do that from the command line on linux, for windows PerlMonks it's probably a matter of 4 minutes to either provide a fitting 100x100 pixel BMP or write a Perl oneliner to do the job for you):

base64 -d clock.bmp.gz.base64 | zcat > clock.bmp
[download]

Now, write that huge graphical application to do the job:

#!/usr/bin/perl -w
use strict;
use warnings;

use IO::Socket;
use Tk;

my $splash;
my $picfile = "clock.bmp";
if(defined($PerlApp::VERSION)) {
    $picfile = PerlApp::extract_bound_file($picfile);
}

require Tk::Splash;
$splash = Tk::Splash->Show($picfile, 100, 100, "PerlMonks Time Sync",
                           undef);
for(1..5) {
    DoOneEvent();
}


my $socket = IO::Socket::INET->new(PeerAddr => "127.0.0.1",
            PeerPort => 64100,
            Proto    => "tcp",
            Type     => SOCK_STREAM);

die("Can't open connection to time server!") if(!$socket);

foreach my $line (<$socket>) {
    if($line =~ /(\d\d-\d\d-\d\d\d\d)\ (\d\d\:\d\d\:\d\d)/) {
    my ($dstamp, $tstamp) = ($1, $2);
        sleep(1);
        system("cmd.exe /c date $dstamp");
        system("cmd.exe /c time $tstamp");
        last;
    }
}
$splash->Destroy;
[download]

On startup, we just take a look if we are running as "compiled" PerlApp. If so, we extract the bounded file for the splash screen, else we just assume it is in our current working directory.

Next, we create a Tk::Splash with the clock picture and run our own mini event loop (just enough events to get the splash displayed).

Then we connect to the server once, get our time string, call cmd.exe twice and close the splash screen.

And thats it. PTS has landed, TimeSync is complete!

BREW /very/strong/coffee HTTP/1.1
Host: goodmorning.example.com

418 I'm a teapot