#!/usr/bin/perl
use strict;
use warnings;
use IO::Socket::INET;
use POSIX qw( CLOCKS_PER_SEC );
use Time::HiRes qw( gettimeofday CLOCK_REALTIME );

use constant TRUE      => scalar 1;
use constant ARGUMENTS => scalar 1;
use constant MAXBYTES  => scalar 256;
use constant MAX_PORT  => scalar 65536;
use constant MIN_PORT  => scalar 1;

my $dot = ".";
my ( $rcv_sntp_packet , $li_d , $send_sntp_packet , $precision_server );

if ( @ARGV > ARGUMENTS ) {
    print "\nPlease no more than ".ARGUMENTS." argument input!\n";
    print "\nCorrect Syntax: perl $0 PORT (e.g. 5000)\n";
    exit();
}
elsif ( @ARGV < ARGUMENTS ) {
    print "\nPlease no less than ".ARGUMENTS." argument input!\n";
    print "\nCorrect Syntax: perl $0 PORT (e.g. 5000)\n";
    exit();
}
else {

    my $port = $ARGV[0]; # User input PORT;

    die "\nPlease provide only numeric characters for PORT number!\n\n"
	if ( $port =~ /\D/ );

    die "\nPlease use PORT number between ".MIN_PORT." - ".MAX_PORT."\n\n" 
	if ( ( $port > MAX_PORT ) || ( $port < MIN_PORT ) );

    my $server_socket = IO::Socket::INET->new(
	LocalPort  => $port, # Default NTP port 123
	Proto      => 'udp',
	Type       => SOCK_DGRAM,
	LocalAddr  => 'localhost',
	Broadcast  => 1 ) or die "Can't bind: $@\n";

    printf("\nServer is up, listens on PORT: ".$port." waiting for client...\n");

    while ( TRUE ) {

	my $peer_address = $server_socket->peerhost();
	my $peer_port = $server_socket->peerport();
	
	if ( defined $peer_address ) { print "Peer address: ".$peer_address."\n" };
	if ( defined $peer_port ) { print "Peer port: ".$peer_port."\n" };
	
	# read operation on the socket
	$server_socket->recv( $rcv_sntp_packet , MAXBYTES ) 
	    or die "Server error received: $!\n";
	my ( $server_rcv_epoc_sec , $server_rcv_epoc_microsec ) = gettimeofday(); # Server epoc time in sec and microsec

	# Convert to binary epoc rcv seconds
	my $server_sec_rcv_b = dec2bin( $server_rcv_epoc_sec , 32 , "N" );
	#print "Epoc rcv sec ".$server_sec_rcv_b."\n";

	# Convert to binary epoc rcv micro seconds
	my $server_microsec_rcv_b = dec2bin( $server_rcv_epoc_microsec , 32 , "N" );
	#print "Epoc rcv microsec ".$server_microsec_rcv_b."\n";

	# Concatenate the rcv sec and rcv microsec 64 in total
	my $server_epoc_rcv_b = $server_sec_rcv_b . $server_microsec_rcv_b;
	#print "Length of rcv time server: ".length( $server_epoc_rcv_b )."\n";

	my $server_rcv_epoc_d = $server_rcv_epoc_sec . $dot . $server_rcv_epoc_microsec;

	#print "\n\n" . "Server received: ".$rcv_sntp_packet."\n\n";

	if ( !defined $rcv_sntp_packet ) {
	    $send_sntp_packet = "Invalid Request";

	    $server_socket->send( $send_sntp_packet )
		or die "Server error send:  $!\n";
	}
	else {

	    my $client_li_binary = substr( $rcv_sntp_packet , 0 , 2 );
	    my $client_li = bin2dec( $client_li_binary , 8 , "c" );

	    my $client_vn_binary = substr( $rcv_sntp_packet , 2 , 3 );
	    my $client_vn = bin2dec( $client_vn_binary , 8 , "c" );

	    my $client_mode_binary = substr( $rcv_sntp_packet , 5 , 3 );
	    my $client_mode = bin2dec( $client_mode_binary , 8 , "c" );

	    my $client_stratum_binary = substr( $rcv_sntp_packet , 8 , 8 );
	    my $client_stratum = bin2dec( $client_stratum_binary , 8 , "C" );

	    my $client_poll_interval_binary = substr( $rcv_sntp_packet , 16 , 8 );
	    my $client_poll_interval = bin2dec( $client_poll_interval_binary , 8 , "c" );

	    my $client_precision_binary = substr( $rcv_sntp_packet , 24 , 8 );
	    my $client_precision = bin2dec( $client_precision_binary , 8 , "c" );

	    my $client_root_delay_binary = substr( $rcv_sntp_packet , 32 , 32 );
	    my $client_root_delay = bin2dec( $client_root_delay_binary , 32 , "f" );

	    my $client_root_dispersion_binary = substr( $rcv_sntp_packet , 64 , 32 );
	    my $client_root_dispersion = bin2dec( $client_root_dispersion_binary , 32 , "N" );

	    my $client_ref_identifier_binary = substr( $rcv_sntp_packet , 96 , 32 );
	    my $client_ref_identifier = bin2dec( $client_ref_identifier_binary , 32 , "N" );

	    my $client_ref_sec_epoc_b = substr( $rcv_sntp_packet , 128 , 32 );
	    my $client_ref_sec_epoc = bin2dec( $client_ref_sec_epoc_b , 32 , "N" );

	    my $client_ref_microsec_epoc_b = substr( $rcv_sntp_packet , 160 , 32 );
	    my $client_ref_microsec_epoc = bin2dec( $client_ref_microsec_epoc_b , 32 , "N" );

	    my $client_ref_epoc_d = $client_ref_sec_epoc . $dot . $client_ref_microsec_epoc;

	    # Concatenate client ref sec and ref microsec for server message transmission
	    my $client_epoc_ref_b = $client_ref_sec_epoc_b . $client_ref_microsec_epoc_b;

	    my $client_send_sec_epoc_b = substr( $rcv_sntp_packet , 192 , 32 );
	    my $client_send_sec_epoc = bin2dec( $client_send_sec_epoc_b , 32 , "N" );

	    my $client_send_microsec_epoc_b = substr( $rcv_sntp_packet , 224 , 32 );
	    my $client_send_microsec_epoc = bin2dec( $client_send_microsec_epoc_b , 32 , "N" );

	    my $client_send_epoc_d = $client_send_sec_epoc . $dot . $client_send_microsec_epoc;
	    
	    # Concatenate client ref sec and ref microsec for server message transmission
	    my $client_epoc_send_b = $client_send_sec_epoc_b . $client_send_microsec_epoc_b;

	    # Server data preparing message

	    # Root Delay, total roundtrip delay to the primary reference source
	    $server_rcv_epoc_microsec = $dot . $server_rcv_epoc_microsec;
	    my $root_delay_server = $server_rcv_epoc_microsec - $client_root_delay;

	    if ($root_delay_server < 59) {
		$li_d = 0;
	    } elsif ($root_delay_server == 61 ) {		
		$li_d = 1;		
	    } elsif ($root_delay_server == 59) {		
		$li_d = 2;
	    } else {
		$li_d = 3;
	    }

	    # $li = 0; is the server we have no warning for asynchronization
	    my $li_b = dec2bin( $li_d , 8 , "c" );
	    $li_b = substr $li_b, -2;

	    # $vn = 3; is the version 3 only IPV4
	    my $vn_b = dec2bin( 3 , 8 , "c" );
	    $vn_b = substr $vn_b, -3;

	    # $mode = 4; is the server (mode 4)
	    my $mode_b = dec2bin( 4 , 8 , "c" );
	    $mode_b = substr $mode_b, -3;

	    # $stratum = 1; is the server clock which is primary reference
	    my $stratum_b = dec2bin( 1 , 8 , "c" );

	    # $poll = 6; # is the poll interval between messages 2**6 (2 to the power of 6) = 64 sec
	    my $poll_b = dec2bin( 2 , 8 , "c" );

	    # The precission size on the RFC is 8 bits, anything lower than 1e-03 (0.001) it can not fit on 8 bits. In such cases we round to clossest digit. Never the less the value is so small not even worth mentioning it.
	    #my ($realtime, $user, $system, $cuser, $csystem) = POSIX::times() ;
	    
	    ( undef , undef , $precision_server , undef , undef ) = POSIX::times();
	
	    my $precision_b = dec2bin( $precision_server , 8 , "c" );

	    #my $root_delay_server = $server_rcv_epoc_d - $client_root_delay;
	    my $root_delay_server_b = dec2bin( $root_delay_server , 32 , "f" );

	    my $root_dispersion = 0; # is the nominal error relative to the primary reference since the server is the reference we can not have relative error. We assume the source is accurate 100%.
	    my $root_dispersion_b = dec2bin( $root_dispersion , 32 , "N" );

	    # $reference_identifier = 0; if this is the primary server then there is not of offset LOCL or PPS if GPS
	    my $reference_identifier_str = "LOCL";
	    my $reference_identifier_b .= unpack( "B32" , $reference_identifier_str );

	    # NTP uses 64-bit Time Stamps to exchange information. Two parts are used, 32-bits for seconds and 32-bits for portions of a second. The 64-bit Time Stamp can manage 136 years of time based from January 1, 1970. Ref. http://www.linux.org/threads/tcp-ip-protocol-network-time-protocol-ntp.4912/
	    # Server epoc receive packet from client in binary $server_epoc_rcv_b in decimal $server_rcv_epoc_d

	    # Server epoc send in sec and microsec
	    my ( $server_sec_send_d , $server_microsec_send_d ) = gettimeofday();

	    # Convert to binary epoc send seconds
	    my $server_sec_send_b = dec2bin( $server_sec_send_d , 32 , "N" );

	    # Convert to binary epoc send micro seconds
	    my $server_microsec_send_b = dec2bin( $server_microsec_send_d , 32 , "N" );

	    # Concatenate the epoc send sec and micro sec to a string 64 bits long to send
	    my $server_epoc_send_b = $server_sec_send_b . $server_microsec_send_b;

	    # Print decimal epoc send message
	    my $server_epoc_send_d = $server_sec_send_d . $dot . $server_microsec_send_d;

	    $send_sntp_packet = $li_b . $vn_b . $mode_b . $stratum_b . $poll_b . $precision_b . $root_delay_server_b . $root_dispersion_b . $reference_identifier_b . $client_epoc_ref_b . $client_epoc_send_b . $server_epoc_rcv_b . $server_epoc_send_b;

	    $server_socket->send( $send_sntp_packet )
		or die "Server error send:  $!\n";
	    
	} # End of else not Invalid Message

	#print "Send packet: ".$send_sntp_packet."\n";

    } # End of while(TRUE) loop

    $server_socket->close(); # Close socket

} # End of else arguments

sub dec2bin {
    my $bits      = shift;
    my $size      = shift;
    my $template  = shift;
    return unpack("B$size", pack($template, $bits));
}

sub bin2dec {
    my $bits     = shift;
    my $size     = shift;
    my $template = shift;
    return unpack($template, pack("B$size", substr("0" x $size . $bits , -$size)));
}