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

Last change on this file was 2, checked in by chronos, 13 years ago
  • Přidáno: Základní kostra projektu.
  • Přidáno: Knihovna synapse.
File size: 12.7 KB
Line 
1{==============================================================================|
2| Project : Ararat Synapse | 003.000.003 |
3|==============================================================================|
4| Content: SNTP client |
5|==============================================================================|
6| Copyright (c)1999-2010, 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-2010. |
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: AnsiString;
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 FSock.Owner := self;
166 FTimeout := 5000;
167 FTargetPort := cNtpProtocol;
168 FMaxSyncDiff := 3600;
169 FSyncTime := False;
170end;
171
172destructor TSNTPSend.Destroy;
173begin
174 FSock.Free;
175 inherited Destroy;
176end;
177
178function TSNTPSend.StrToNTP(const Value: AnsiString): TNtp;
179begin
180 if length(FBuffer) >= SizeOf(Result) then
181 begin
182 Result.mode := ord(Value[1]);
183 Result.stratum := ord(Value[2]);
184 Result.poll := ord(Value[3]);
185 Result.Precision := ord(Value[4]);
186 Result.RootDelay := DecodeLongInt(value, 5);
187 Result.RootDisperson := DecodeLongInt(value, 9);
188 Result.RefID := DecodeLongInt(value, 13);
189 Result.Ref1 := DecodeLongInt(value, 17);
190 Result.Ref2 := DecodeLongInt(value, 21);
191 Result.Org1 := DecodeLongInt(value, 25);
192 Result.Org2 := DecodeLongInt(value, 29);
193 Result.Rcv1 := DecodeLongInt(value, 33);
194 Result.Rcv2 := DecodeLongInt(value, 37);
195 Result.Xmit1 := DecodeLongInt(value, 41);
196 Result.Xmit2 := DecodeLongInt(value, 45);
197 end;
198
199end;
200
201function TSNTPSend.NTPtoStr(const Value: Tntp): AnsiString;
202begin
203 SetLength(Result, 4);
204 Result[1] := AnsiChar(Value.mode);
205 Result[2] := AnsiChar(Value.stratum);
206 Result[3] := AnsiChar(Value.poll);
207 Result[4] := AnsiChar(Value.precision);
208 Result := Result + CodeLongInt(Value.RootDelay);
209 Result := Result + CodeLongInt(Value.RootDisperson);
210 Result := Result + CodeLongInt(Value.RefID);
211 Result := Result + CodeLongInt(Value.Ref1);
212 Result := Result + CodeLongInt(Value.Ref2);
213 Result := Result + CodeLongInt(Value.Org1);
214 Result := Result + CodeLongInt(Value.Org2);
215 Result := Result + CodeLongInt(Value.Rcv1);
216 Result := Result + CodeLongInt(Value.Rcv2);
217 Result := Result + CodeLongInt(Value.Xmit1);
218 Result := Result + CodeLongInt(Value.Xmit2);
219end;
220
221procedure TSNTPSend.ClearNTP(var Value: Tntp);
222begin
223 Value.mode := 0;
224 Value.stratum := 0;
225 Value.poll := 0;
226 Value.Precision := 0;
227 Value.RootDelay := 0;
228 Value.RootDisperson := 0;
229 Value.RefID := 0;
230 Value.Ref1 := 0;
231 Value.Ref2 := 0;
232 Value.Org1 := 0;
233 Value.Org2 := 0;
234 Value.Rcv1 := 0;
235 Value.Rcv2 := 0;
236 Value.Xmit1 := 0;
237 Value.Xmit2 := 0;
238end;
239
240function TSNTPSend.DecodeTs(Nsec, Nfrac: Longint): TDateTime;
241const
242 maxi = 4294967295.0;
243var
244 d, d1: Double;
245begin
246 d := Nsec;
247 if d < 0 then
248 d := maxi + d + 1;
249 d1 := Nfrac;
250 if d1 < 0 then
251 d1 := maxi + d1 + 1;
252 d1 := d1 / maxi;
253 d1 := Trunc(d1 * 10000) / 10000;
254 Result := (d + d1) / 86400;
255 Result := Result + 2;
256end;
257
258procedure TSNTPSend.EncodeTs(dt: TDateTime; var Nsec, Nfrac: Longint);
259const
260 maxi = 4294967295.0;
261 maxilongint = 2147483647;
262var
263 d, d1: Double;
264begin
265 d := (dt - 2) * 86400;
266 d1 := frac(d);
267 if d > maxilongint then
268 d := d - maxi - 1;
269 d := trunc(d);
270 d1 := Trunc(d1 * 10000) / 10000;
271 d1 := d1 * maxi;
272 if d1 > maxilongint then
273 d1 := d1 - maxi - 1;
274 Nsec:=trunc(d);
275 Nfrac:=trunc(d1);
276end;
277
278function TSNTPSend.GetBroadcastNTP: Boolean;
279var
280 x: Integer;
281begin
282 Result := False;
283 FSock.Bind(FIPInterface, FTargetPort);
284 FBuffer := FSock.RecvPacket(FTimeout);
285 if FSock.LastError = 0 then
286 begin
287 x := Length(FBuffer);
288 if (FTargetHost = '0.0.0.0') or (FSock.GetRemoteSinIP = FSock.ResolveName(FTargetHost)) then
289 if x >= SizeOf(NTPReply) then
290 begin
291 FNTPReply := StrToNTP(FBuffer);
292 FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
293 if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
294 SetUTTime(FNTPTime);
295 Result := True;
296 end;
297 end;
298end;
299
300function TSNTPSend.GetSNTP: Boolean;
301var
302 q: TNtp;
303 x: Integer;
304begin
305 Result := False;
306 FSock.CloseSocket;
307 FSock.Bind(FIPInterface, cAnyPort);
308 FSock.Connect(FTargetHost, FTargetPort);
309 ClearNtp(q);
310 q.mode := $1B;
311 FBuffer := NTPtoStr(q);
312 FSock.SendString(FBuffer);
313 FBuffer := FSock.RecvPacket(FTimeout);
314 if FSock.LastError = 0 then
315 begin
316 x := Length(FBuffer);
317 if x >= SizeOf(NTPReply) then
318 begin
319 FNTPReply := StrToNTP(FBuffer);
320 FNTPTime := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
321 if FSyncTime and ((abs(FNTPTime - GetUTTime) * 86400) <= FMaxSyncDiff) then
322 SetUTTime(FNTPTime);
323 Result := True;
324 end;
325 end;
326end;
327
328function TSNTPSend.GetNTP: Boolean;
329var
330 q: TNtp;
331 x: Integer;
332 t1, t2, t3, t4 : TDateTime;
333begin
334 Result := False;
335 FSock.CloseSocket;
336 FSock.Bind(FIPInterface, cAnyPort);
337 FSock.Connect(FTargetHost, FTargetPort);
338 ClearNtp(q);
339 q.mode := $1B;
340 t1 := GetUTTime;
341 EncodeTs(t1, q.org1, q.org2);
342 FBuffer := NTPtoStr(q);
343 FSock.SendString(FBuffer);
344 FBuffer := FSock.RecvPacket(FTimeout);
345 if FSock.LastError = 0 then
346 begin
347 x := Length(FBuffer);
348 t4 := GetUTTime;
349 if x >= SizeOf(NTPReply) then
350 begin
351 FNTPReply := StrToNTP(FBuffer);
352 FLi := (NTPReply.mode and $C0) shr 6;
353 FVn := (NTPReply.mode and $38) shr 3;
354 Fmode := NTPReply.mode and $07;
355 if (Fli < 3) and (Fmode = 4) and
356 (NTPReply.stratum >= 1) and (NTPReply.stratum <= 15) and
357 (NTPReply.Rcv1 <> 0) and (NTPReply.Xmit1 <> 0)
358 then begin
359 t2 := DecodeTs(NTPReply.Rcv1, NTPReply.Rcv2);
360 t3 := DecodeTs(NTPReply.Xmit1, NTPReply.Xmit2);
361 FNTPDelay := (T4 - T1) - (T2 - T3);
362 FNTPTime := t3 + FNTPDelay / 2;
363 FNTPOffset := (((T2 - T1) + (T3 - T4)) / 2) * 86400;
364 FNTPDelay := FNTPDelay * 86400;
365 if FSyncTime and ((abs(FNTPTime - t1) * 86400) <= FMaxSyncDiff) then
366 SetUTTime(FNTPTime);
367 Result := True;
368 end
369 else result:=false;
370 end;
371 end;
372end;
373
374end.
Note: See TracBrowser for help on using the repository browser.