pascal/lazarus-ccr
1
0
Fork 0
Code Issues Releases Activity

First Commit. Tested Laz1.7 fpc 3.1.1

Browse Source 
git-svn-id: https://svn.code.sf.net/p/lazarus-ccr/svn@5304 8e941d3f-bd1b-0410-a28a-d453659cc2b4
This commit is contained in:
gbamber
2016-11-03 14:15:54 +00:00
parent 188e680f94
commit 07d34de44c
63 changed files with 55451 additions and 0 deletions
Download Patch File Download Diff File Expand all files Collapse all files

374
components/lazautoupdate/synapse/source/lib/sntpsend.pas Normal file
View File

@ -0,0 +1,374 @@
{==============================================================================|
| Project : Ararat Synapse | 003.000.003 |
|==============================================================================|
| Content: SNTP client |
|==============================================================================|
| Copyright (c)1999-2010, Lukas Gebauer |
| All rights reserved. |
| |
| Redistribution and use in source and binary forms, with or without |
| modification, are permitted provided that the following conditions are met: |
| |
| Redistributions of source code must retain the above copyright notice, this |
| list of conditions and the following disclaimer. |
| |
| Redistributions in binary form must reproduce the above copyright notice, |
| this list of conditions and the following disclaimer in the documentation |
| and/or other materials provided with the distribution. |
| |
| Neither the name of Lukas Gebauer nor the names of its contributors may |
| be used to endorse or promote products derived from this software without |
| specific prior written permission. |
| |
| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
| DAMAGE. |
|==============================================================================|
| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
| Portions created by Lukas Gebauer are Copyright (c)2000-2010. |
| All Rights Reserved. |
|==============================================================================|
| Contributor(s): |
| Patrick Chevalley |
|==============================================================================|
| History: see HISTORY.HTM from distribution package |
| (Found at URL: http://www.ararat.cz/synapse/) |
|==============================================================================}
{:@abstract( NTP and SNTP client)
Used RFC: RFC-1305, RFC-2030
}
{$IFDEF FPC}
{$MODE DELPHI}
{$ENDIF}
{$Q-}
{$H+}
unit sntpsend;
interface
uses
SysUtils,
synsock, blcksock, synautil;
const
cNtpProtocol = '123';
type
{:@abstract(Record containing the NTP packet.)}
TNtp = packed record
mode: Byte;
stratum: Byte;
poll: Byte;
Precision: Byte;
RootDelay: Longint;
RootDisperson: Longint;
RefID: Longint;
Ref1: Longint;
Ref2: Longint;
Org1: Longint;
Org2: Longint;
Rcv1: Longint;
Rcv2: Longint;
Xmit1: Longint;
Xmit2: Longint;
end;
{:@abstract(Implementation of NTP and SNTP client protocol),
include time synchronisation. It can send NTP or SNTP time queries, or it
can receive NTP broadcasts too.
Note: Are you missing properties for specify server address and port? Look to
parent @link(TSynaClient) too!}
TSNTPSend = class(TSynaClient)
private
FNTPReply: TNtp;
FNTPTime: TDateTime;
FNTPOffset: double;
FNTPDelay: double;
FMaxSyncDiff: double;
FSyncTime: Boolean;
FSock: TUDPBlockSocket;
FBuffer: AnsiString;
FLi, FVn, Fmode : byte;
function StrToNTP(const Value: AnsiString): TNtp;
function NTPtoStr(const Value: Tntp): AnsiString;
procedure ClearNTP(var Value: Tntp);
public
constructor Create;
destructor Destroy; override;
{:Decode 128 bit timestamp used in NTP packet to TDateTime type.}
function DecodeTs(Nsec, Nfrac: Longint): TDateTime;
{:Decode TDateTime type to 128 bit timestamp used in NTP packet.}
procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
{:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
valid.}
function GetSNTP: Boolean;
{:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
valid. Result time is after all needed corrections.}
function GetNTP: Boolean;
{:Wait for broadcast NTP packet. If all OK, result is @true and
@link(NTPReply) and @link(NTPTime) are valid.}
function GetBroadcastNTP: Boolean;
{:Holds last received NTP packet.}
property NTPReply: TNtp read FNTPReply;
published
{:Date and time of remote NTP or SNTP server. (UTC time!!!)}
property NTPTime: TDateTime read FNTPTime;
{:Offset between your computer and remote NTP or SNTP server.}
property NTPOffset: Double read FNTPOffset;
{:Delay between your computer and remote NTP or SNTP server.}
property NTPDelay: Double read FNTPDelay;
{:Define allowed maximum difference between your time and remote time for
synchronising time. If difference is bigger, your system time is not
changed!}
property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff;
{:If @true, after successfull getting time is local computer clock
synchronised to given time.
For synchronising time you must have proper rights! (Usually Administrator)}
property SyncTime: Boolean read FSyncTime write FSyncTime;
{:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
property Sock: TUDPBlockSocket read FSock;
end;
implementation
constructor TSNTPSend.Create;
begin
inherited Create;
FSock := TUDPBlockSocket.Create;
FSock.Owner := self;
FTimeout := 5000;
FTargetPort := cNtpProtocol;
FMaxSyncDiff := 3600;
FSyncTime := False;
end;
destructor TSNTPSend.Destroy;
begin
FSock.Free;
inherited Destroy;
end;
function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp;
begin
if length(FBuffer) >= SizeOf(Result) then
begin
Result.mode := ord(Value[1]);
Result.stratum := ord(Value[2]);
Result.poll := ord(Value[3]);
Result.Precision := ord(Value[4]);
Result.RootDelay := DecodeLongInt(value, 5);
Result.RootDisperson := DecodeLongInt(value, 9);
Result.RefID := DecodeLongInt(value, 13);
Result.Ref1 := DecodeLongInt(value, 17);
Result.Ref2 := DecodeLongInt(value, 21);
Result.Org1 := DecodeLongInt(value, 25);
Result.Org2 := DecodeLongInt(value, 29);
Result.Rcv1 := DecodeLongInt(value, 33);
Result.Rcv2 := DecodeLongInt(value, 37);
Result.Xmit1 := DecodeLongInt(value, 41);
Result.Xmit2 := DecodeLongInt(value, 45);
end;
end;
function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString;
begin
SetLength(Result, 4);
Result[1] := AnsiChar(Value.mode);
Result[2] := AnsiChar(Value.stratum);
Result[3] := AnsiChar(Value.poll);
Result[4] := AnsiChar(Value.precision);
Result := Result + CodeLongInt(Value.RootDelay);
Result := Result + CodeLongInt(Value.RootDisperson);
Result := Result + CodeLongInt(Value.RefID);
Result := Result + CodeLongInt(Value.Ref1);
Result := Result + CodeLongInt(Value.Ref2);
Result := Result + CodeLongInt(Value.Org1);
Result := Result + CodeLongInt(Value.Org2);
Result := Result + CodeLongInt(Value.Rcv1);
Result := Result + CodeLongInt(Value.Rcv2);
Result := Result + CodeLongInt(Value.Xmit1);
Result := Result + CodeLongInt(Value.Xmit2);
end;
procedure TSNTPSend.ClearNTP(var Value: Tntp);
begin
Value.mode := 0;
Value.stratum := 0;
Value.poll := 0;
Value.Precision := 0;
Value.RootDelay := 0;
Value.RootDisperson := 0;
Value.RefID := 0;
Value.Ref1 := 0;
Value.Ref2 := 0;
Value.Org1 := 0;
Value.Org2 := 0;
Value.Rcv1 := 0;
Value.Rcv2 := 0;
Value.Xmit1 := 0;
Value.Xmit2 := 0;
end;
function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime;
const
maxi = 4294967295.0;
var
d, d1: Double;
begin
d := Nsec;
if d < 0 then
d := maxi + d + 1;
d1 := Nfrac;
if d1 < 0 then
d1 := maxi + d1 + 1;
d1 := d1 / maxi;
d1 := Trunc(d1 * 10000) / 10000;
Result := (d + d1) / 86400;
Result := Result + 2;
end;
procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
const
maxi = 4294967295.0;
maxilongint = 2147483647;
var
d, d1: Double;
begin
d := (dt - 2) * 86400;
d1 := frac(d);
if d > maxilongint then
d := d - maxi - 1;
d := trunc(d);
d1 := Trunc(d1 * 10000) / 10000;
d1 := d1 * maxi;
if d1 > maxilongint then
d1 := d1 - maxi - 1;
Nsec:=trunc(d);
Nfrac:=trunc(d1);
end;
function TSNTPSend.GetBroadcastNTP: Boolean;
var
x: Integer;
begin
Result := False;
FSock.Bind(FIPInterface, FTargetPort);
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
begin
x := Length(FBuffer);
if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then
if x >= SizeOf(NTPReply) then
begin
FNTPReply := StrToNTP(FBuffer);
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
SetUTTime(FNTPTime);
Result := True;
end;
end;
end;
function TSNTPSend.GetSNTP: Boolean;
var
q: TNtp;
x: Integer;
begin
Result := False;
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
ClearNtp(q);
q.mode := $1B;
FBuffer := NTPtoStr(q);
FSock.SendString(FBuffer);
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
begin
x := Length(FBuffer);
if x >= SizeOf(NTPReply) then
begin
FNTPReply := StrToNTP(FBuffer);
FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
SetUTTime(FNTPTime);
Result := True;
end;
end;
end;
function TSNTPSend.GetNTP: Boolean;
var
q: TNtp;
x: Integer;
t1, t2, t3, t4 : TDateTime;
begin
Result := False;
FSock.CloseSocket;
FSock.Bind(FIPInterface, cAnyPort);
FSock.Connect(FTargetHost, FTargetPort);
ClearNtp(q);
q.mode := $1B;
t1 := GetUTTime;
EncodeTs(t1, q.org1, q.org2);
FBuffer := NTPtoStr(q);
FSock.SendString(FBuffer);
FBuffer := FSock.RecvPacket(FTimeout);
if FSock.LastError = 0 then
begin
x := Length(FBuffer);
t4 := GetUTTime;
if x >= SizeOf(NTPReply) then
begin
FNTPReply := StrToNTP(FBuffer);
FLi := (NTPReply.mode and $C0) shr 6;
FVn := (NTPReply.mode and $38) shr 3;
Fmode := NTPReply.mode and $07;
if (Fli < 3) and (Fmode = 4) and
(NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and
(NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0)
then begin
t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2);
t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
FNTPDelay := (T4 - T1) - (T2 - T3);
FNTPTime := t3 + FNTPDelay / 2;
FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400;
FNTPDelay := FNTPDelay * 86400;
if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then
SetUTTime(FNTPTime);
Result := True;
end
else result:=false;
end;
end;
end;
end.