source: trunk/Demo/Packages/synapse/sntpsend.pas

Last change on this file was 60, checked in by chronos, 13 years ago
File size: 12.7 KB
Line 
1{==============================================================================|
2| Project : Ararat Synapse | 003.000.002 |
3|==============================================================================|
4| Content: SNTP client |
5|==============================================================================|
6| Copyright (c)1999-2007, Lukas Gebauer |
7| All rights reserved. |
8| |
9| Redistribution and use in source and binary forms, with or without |
10| modification, are permitted provided that the following conditions are met: |
11| |
12| Redistributions of source code must retain the above copyright notice, this |
13| list of conditions and the following disclaimer. |
14| |
15| Redistributions in binary form must reproduce the above copyright notice, |
16| this list of conditions and the following disclaimer in the documentation |
17| and/or other materials provided with the distribution. |
18| |
19| Neither the name of Lukas Gebauer nor the names of its contributors may |
20| be used to endorse or promote products derived from this software without |
21| specific prior written permission. |
22| |
23| THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" |
24| AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE |
25| IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE |
26| ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR |
27| ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL |
28| DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR |
29| SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER |
30| CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT |
31| LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY |
32| OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH |
33| DAMAGE. |
34|==============================================================================|
35| The Initial Developer of the Original Code is Lukas Gebauer (Czech Republic).|
36| Portions created by Lukas Gebauer are Copyright (c)2000-2007. |
37| All Rights Reserved. |
38|==============================================================================|
39| Contributor(s): |
40| Patrick Chevalley |
41|==============================================================================|
42| History: see HISTORY.HTM from distribution package |
43| (Found at URL: http://www.ararat.cz/synapse/) |
44|==============================================================================}
45
46{:@abstract( NTP and SNTP client)
47
48Used RFC: RFC-1305, RFC-2030
49}
50
51{$IFDEF FPC}
52 {$MODE DELPHI}
53{$ENDIF}
54{$Q-}
55{$H+}
56
57unit sntpsend;
58
59interface
60
61uses
62 SysUtils,
63 synsock, blcksock, synautil;
64
65const
66 cNtpProtocol = '123';
67
68type
69
70 {:@abstract(Record containing the NTP packet.)}
71 TNtp = packed record
72 mode: Byte;
73 stratum: Byte;
74 poll: Byte;
75 Precision: Byte;
76 RootDelay: Longint;
77 RootDisperson: Longint;
78 RefID: Longint;
79 Ref1: Longint;
80 Ref2: Longint;
81 Org1: Longint;
82 Org2: Longint;
83 Rcv1: Longint;
84 Rcv2: Longint;
85 Xmit1: Longint;
86 Xmit2: Longint;
87 end;
88
89 {:@abstract(Implementation of NTP and SNTP client protocol),
90 include time synchronisation. It can send NTP or SNTP time queries, or it
91 can receive NTP broadcasts too.
92
93 Note: Are you missing properties for specify server address and port? Look to
94 parent @link(TSynaClient) too!}
95 TSNTPSend = class(TSynaClient)
96 private
97 FNTPReply: TNtp;
98 FNTPTime: TDateTime;
99 FNTPOffset: double;
100 FNTPDelay: double;
101 FMaxSyncDiff: double;
102 FSyncTime: Boolean;
103 FSock: TUDPBlockSocket;
104 FBuffer: string;
105 FLi, FVn, Fmode : byte;
106 function StrToNTP(const Value: AnsiString): TNtp;
107 function NTPtoStr(const Value: Tntp): AnsiString;
108 procedure ClearNTP(var Value: Tntp);
109 public
110 constructor Create;
111 destructor Destroy; override;
112
113 {:Decode 128 bit timestamp used in NTP packet to TDateTime type.}
114 function DecodeTs(Nsec, Nfrac: Longint): TDateTime;
115
116 {:Decode TDateTime type to 128 bit timestamp used in NTP packet.}
117 procedure EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
118
119 {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
120 is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
121 valid.}
122 function GetSNTP: Boolean;
123
124 {:Send request to @link(TSynaClient.TargetHost) and wait for reply. If all
125 is OK, then result is @true and @link(NTPReply) and @link(NTPTime) are
126 valid. Result time is after all needed corrections.}
127 function GetNTP: Boolean;
128
129 {:Wait for broadcast NTP packet. If all OK, result is @true and
130 @link(NTPReply) and @link(NTPTime) are valid.}
131 function GetBroadcastNTP: Boolean;
132
133 {:Holds last received NTP packet.}
134 property NTPReply: TNtp read FNTPReply;
135 published
136 {:Date and time of remote NTP or SNTP server. (UTC time!!!)}
137 property NTPTime: TDateTime read FNTPTime;
138
139 {:Offset between your computer and remote NTP or SNTP server.}
140 property NTPOffset: Double read FNTPOffset;
141
142 {:Delay between your computer and remote NTP or SNTP server.}
143 property NTPDelay: Double read FNTPDelay;
144
145 {:Define allowed maximum difference between your time and remote time for
146 synchronising time. If difference is bigger, your system time is not
147 changed!}
148 property MaxSyncDiff: double read FMaxSyncDiff write FMaxSyncDiff;
149
150 {:If @true, after successfull getting time is local computer clock
151 synchronised to given time.
152 For synchronising time you must have proper rights! (Usually Administrator)}
153 property SyncTime: Boolean read FSyncTime write FSyncTime;
154
155 {:Socket object used for TCP/IP operation. Good for seting OnStatus hook, etc.}
156 property Sock: TUDPBlockSocket read FSock;
157 end;
158
159implementation
160
161constructor TSNTPSend.Create;
162begin
163 inherited Create;
164 FSock := TUDPBlockSocket.Create;
165 FTimeout := 5000;
166 FTargetPort := cNtpProtocol;
167 FMaxSyncDiff := 3600;
168 FSyncTime := False;
169end;
170
171destructor TSNTPSend.Destroy;
172begin
173 FSock.Free;
174 inherited Destroy;
175end;
176
177function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp;
178begin
179 if length(FBuffer) >= SizeOf(Result) then
180 begin
181 Result.mode := ord(Value[1]);
182 Result.stratum := ord(Value[2]);
183 Result.poll := ord(Value[3]);
184 Result.Precision := ord(Value[4]);
185 Result.RootDelay := DecodeLongInt(value, 5);
186 Result.RootDisperson := DecodeLongInt(value, 9);
187 Result.RefID := DecodeLongInt(value, 13);
188 Result.Ref1 := DecodeLongInt(value, 17);
189 Result.Ref2 := DecodeLongInt(value, 21);
190 Result.Org1 := DecodeLongInt(value, 25);
191 Result.Org2 := DecodeLongInt(value, 29);
192 Result.Rcv1 := DecodeLongInt(value, 33);
193 Result.Rcv2 := DecodeLongInt(value, 37);
194 Result.Xmit1 := DecodeLongInt(value, 41);
195 Result.Xmit2 := DecodeLongInt(value, 45);
196 end;
197
198end;
199
200function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString;
201begin
202 SetLength(Result, 4);
203 Result[1] := AnsiChar(Value.mode);
204 Result[2] := AnsiChar(Value.stratum);
205 Result[3] := AnsiChar(Value.poll);
206 Result[4] := AnsiChar(Value.precision);
207 Result := Result + CodeLongInt(Value.RootDelay);
208 Result := Result + CodeLongInt(Value.RootDisperson);
209 Result := Result + CodeLongInt(Value.RefID);
210 Result := Result + CodeLongInt(Value.Ref1);
211 Result := Result + CodeLongInt(Value.Ref2);
212 Result := Result + CodeLongInt(Value.Org1);
213 Result := Result + CodeLongInt(Value.Org2);
214 Result := Result + CodeLongInt(Value.Rcv1);
215 Result := Result + CodeLongInt(Value.Rcv2);
216 Result := Result + CodeLongInt(Value.Xmit1);
217 Result := Result + CodeLongInt(Value.Xmit2);
218end;
219
220procedure TSNTPSend.ClearNTP(var Value: Tntp);
221begin
222 Value.mode := 0;
223 Value.stratum := 0;
224 Value.poll := 0;
225 Value.Precision := 0;
226 Value.RootDelay := 0;
227 Value.RootDisperson := 0;
228 Value.RefID := 0;
229 Value.Ref1 := 0;
230 Value.Ref2 := 0;
231 Value.Org1 := 0;
232 Value.Org2 := 0;
233 Value.Rcv1 := 0;
234 Value.Rcv2 := 0;
235 Value.Xmit1 := 0;
236 Value.Xmit2 := 0;
237end;
238
239function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime;
240const
241 maxi = 4294967295.0;
242var
243 d, d1: Double;
244begin
245 d := Nsec;
246 if d < 0 then
247 d := maxi + d + 1;
248 d1 := Nfrac;
249 if d1 < 0 then
250 d1 := maxi + d1 + 1;
251 d1 := d1 / maxi;
252 d1 := Trunc(d1 * 10000) / 10000;
253 Result := (d + d1) / 86400;
254 Result := Result + 2;
255end;
256
257procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
258const
259 maxi = 4294967295.0;
260 maxilongint = 2147483647;
261var
262 d, d1: Double;
263begin
264 d := (dt - 2) * 86400;
265 d1 := frac(d);
266 if d > maxilongint then
267 d := d - maxi - 1;
268 d := trunc(d);
269 d1 := Trunc(d1 * 10000) / 10000;
270 d1 := d1 * maxi;
271 if d1 > maxilongint then
272 d1 := d1 - maxi - 1;
273 Nsec:=trunc(d);
274 Nfrac:=trunc(d1);
275end;
276
277function TSNTPSend.GetBroadcastNTP: Boolean;
278var
279 x: Integer;
280begin
281 Result := False;
282 FSock.Bind(FIPInterface, FTargetPort);
283 FBuffer := FSock.RecvPacket(FTimeout);
284 if FSock.LastError = 0 then
285 begin
286 x := Length(FBuffer);
287 if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then
288 if x >= SizeOf(NTPReply) then
289 begin
290 FNTPReply := StrToNTP(FBuffer);
291 FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
292 if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
293 SetUTTime(FNTPTime);
294 Result := True;
295 end;
296 end;
297end;
298
299function TSNTPSend.GetSNTP: Boolean;
300var
301 q: TNtp;
302 x: Integer;
303begin
304 Result := False;
305 FSock.CloseSocket;
306 FSock.Bind(FIPInterface, cAnyPort);
307 FSock.Connect(FTargetHost, FTargetPort);
308 ClearNtp(q);
309 q.mode := $1B;
310 FBuffer := NTPtoStr(q);
311 FSock.SendString(FBuffer);
312 FBuffer := FSock.RecvPacket(FTimeout);
313 if FSock.LastError = 0 then
314 begin
315 x := Length(FBuffer);
316 if x >= SizeOf(NTPReply) then
317 begin
318 FNTPReply := StrToNTP(FBuffer);
319 FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
320 if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
321 SetUTTime(FNTPTime);
322 Result := True;
323 end;
324 end;
325end;
326
327function TSNTPSend.GetNTP: Boolean;
328var
329 q: TNtp;
330 x: Integer;
331 t1, t2, t3, t4 : TDateTime;
332begin
333 Result := False;
334 FSock.CloseSocket;
335 FSock.Bind(FIPInterface, cAnyPort);
336 FSock.Connect(FTargetHost, FTargetPort);
337 ClearNtp(q);
338 q.mode := $1B;
339 t1 := GetUTTime;
340 EncodeTs(t1, q.org1, q.org2);
341 FBuffer := NTPtoStr(q);
342 FSock.SendString(FBuffer);
343 FBuffer := FSock.RecvPacket(FTimeout);
344 if FSock.LastError = 0 then
345 begin
346 x := Length(FBuffer);
347 t4 := GetUTTime;
348 if x >= SizeOf(NTPReply) then
349 begin
350 FNTPReply := StrToNTP(FBuffer);
351 FLi := (NTPReply.mode and $C0) shr 6;
352 FVn := (NTPReply.mode and $38) shr 3;
353 Fmode := NTPReply.mode and $07;
354 if (Fli < 3) and (Fmode = 4) and
355 (NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and
356 (NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0)
357 then begin
358 t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2);
359 t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
360 FNTPDelay := (T4 - T1) - (T2 - T3);
361 FNTPTime := t3 + FNTPDelay / 2;
362 FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400;
363 FNTPDelay := FNTPDelay * 86400;
364 if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then
365 SetUTTime(FNTPTime);
366 Result := True;
367 end
368 else result:=false;
369 end;
370 end;
371end;
372
373end.
Note: See TracBrowser for help on using the repository browser.