/*- + * Copyright (c) 2001,2003 Scott C. Klement + * All rights reserved. + * + * Redistribution and use in source and binary forms, with or without + * modification, are permitted provided that the following conditions + * are met: + * 1. Redistributions of source code must retain the above copyright + * notice, this list of conditions and the following disclaimer. + * 2. 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. + * + * THIS SOFTWARE IS PROVIDED BY THE AUTHOR 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 AUTHOR 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. + * + */ + ** This program synchronizes the system clock with an Internet ** time server, using the SNTP (Simple Network Time Protocol). ** ** This uses definitions of the sockets API and utility functions ** from my RPG IV Socket Tutorial. Get them here: ** http://www.scottklement.com/rpg/socktut/ ** ** To compile: ** CRTBNDRPG ISOSNTPR4 SRCFILE(XXX/XXX) DBGVIEW(*LIST) ** ** To run: ** CALL ISOSNTPR4 PARM('some.timeserver.net') ** ** TODO: ** -- Find out the actual system date & time formats instead ** of hard-coding it to MMDDYY and HHMMSS ** -- Deal with leap seconds instead of ignoring them ** -- Set clock to the correct fraction of a second (instead of ** simply dropping fractions) ** -- Make a nice, easy-to-distribute package for this that ** includes the socket dependencies ** ** H DFTACTGRP(*NO) ACTGRP(*NEW) OPTION(*SRCSTMT: *NOSHOWCPY) H BNDDIR('QC2LE') BNDDIR('SOCKTUT/SOCKUTIL') D/copy socktut/qrpglesrc,socket_h D/copy socktut/qrpglesrc,sockutil_h D******************************************************************* D* This structure defines the format of a "message" in the NTP D* and SNTP protocols: D******************************************************************* ** <--------------------------- bits -----------------------------> ** 1 2 3 ** 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0 1 ** +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ ** |LI | VN |Mode | Stratum | Poll | Precision | ** +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ ** | Root Delay | ** +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ ** | Root Dispersion | ** +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ ** | Reference Identifier | ** +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ ** | | ** | Reference Timestamp (64) | ** | | ** +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ ** | | ** | Originate Timestamp (64) | ** | | ** +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ ** | | ** | Receive Timestamp (64) | ** | | ** +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ ** | | ** | Transmit Timestamp (64) | ** | | ** +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ ** | Key Identifier (optional) (32) | ** +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ ** | | ** | | ** | Message Digest (optional) (128) | ** | | ** | | ** +-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+ d dsNTP DS D dsNtpLiVnMod 3U 0 inz(0) D dsNtpStratum 3U 0 inz(0) D dsNtpPoll 3U 0 inz(0) D dsNtpPrec 3U 0 inz(0) D dsNtpRtDly 10U 0 inz(0) D dsNtpRtDisp 10U 0 inz(0) D dsNtpRefID 10U 0 inz(0) D dsNtpRefTS 8A inz(*ALLx'00') D dsNtpOrgTS 8A inz(*ALLx'00') D dsNtpRcvTS 8A inz(*ALLx'00') D dsNtpXmtTS 8A inz(*ALLx'00') D************************************************************* D* These are multipliers to offset the values for the D* mode, version number and leap indicator in dsNtpLiVnMod D************************************************************* D NTP_MODE C CONST(0) D NTP_VN C CONST(8) D NTP_LI C CONST(64) D************************************************************* D* Prototype for the API that registers a procedure to D* be run if the call-level ends abnormally. D************************************************************* D CEERTX PR ExtProc('CEERTX') D procedure * procptr D someptr 1A options(*omit) D feedback 1A options(*omit) D************************************************************* D* Prototypes for local procedures D************************************************************* D GetCurTS PR 8A D DiffTS PR 8F D peTS1 8A D peTS2 8A D diag PR D diagmsg 256A Const D error PR D errmsg 256A const D c_error PR D c_errmsg 128A const D CloseSock PR D OffsetClock PR D peOffset 8F value D************************************************************* D* Local (global) variables D************************************************************* D wkSock S 10I 0 D wkOpt S 10I 0 D peServer S 32A D wkServIP S 10U 0 D wkNtpPort S 5U 0 D wkAddrLen S 10I 0 inz(%size(sockaddr)) D wkDoneTS S 8A D wkOffset S 8F D wkOffDiag S 18P 6 D wkSet S 28A D bindto S like(sockaddr) D destaddr S like(sockaddr) D timeout S like(timeval) D p_AbnEnd S * procptr c eval *inlr = *on D************************************************************* C* Get & check parameters: D************************************************************* c *entry plist c parm peServer c if %parms < 1 c callp error('No server specified!') c return c endif C************************************************************* C* set up a UDP socket for network communications: C************************************************************* C* Create a new socket C******************************************* c eval wkSock = socket(AF_INET: SOCK_DGRAM: c IPPROTO_UDP) c if wkSock < 0 c callp c_error('socket') c return c endif C******************************************* C* Register a procedure to close the socket C* if the program should end abnormally C******************************************* c eval p_AbnEnd = %paddr('CLOSESOCK') c callp CEERTX(p_AbnEnd:*OMIT:*OMIT) C******************************************* C* Allow reuse of the port. C******************************************* c eval wkOpt = 1 c if setsockopt(wkSock: SOL_SOCKET: c SO_REUSEADDR: %addr(wkOpt): c %size(wkOpt)) < 0 c callp c_error('setsockopt') c return c endif C******************************************* C* Look up the port number for the NTP C* protocol. (SNTP is a subset of NTP) C******************************************* c eval p_servent = getservbyname('ntp':'udp') c if p_servent = *NULL c callp error('Can''t find NTP service in ' + c 'system service table!') c return c endif c eval wkNtpPort = s_port c callp diag('NTP appears to be on port ' + c %trim(%EditC(wkNtpPort: 'Z'))) C******************************************* C* Bind to the NTP port C******************************************* c eval p_sockaddr = %addr(bindto) c eval sin_family = AF_INET c eval sin_port = wkNtpPort c eval sin_addr = INADDR_ANY c eval sin_zero = *ALLx'00' c if bind(wkSock: %addr(bindto): c %size(bindto) ) < 0 c callp c_error('bind') c return c endif C******************************************* C* Set up descriptor set for select() API C* so we dont have to do it when timing is C* more critical later. C* C* Note that "tv_sec" is effectively the C* timeout value for receiving data from C* the server. C******************************************* c callp FD_ZERO(wkSet) c callp FD_SET(wkSock: wkSet) c eval p_timeval = %addr(timeout) c eval tv_sec = 10 c eval tv_usec = 0 C************************************************************* C* Set up a sockaddr structure to send packets to: C************************************************************* C* Resolve the server's IP address C******************************************* c eval wkServIP = inet_addr(%trim(peServer)) c if wkServIP = INADDR_NONE c eval p_hostent =gethostbyname(%trim(peServer)) c if p_hostent = *NULL c callp error('Name lookup failed for: ' + c %trim(peServer)) c return c endif c eval wkServIP = h_addr c endif c callp diag('NTP server is at ' + c %str(inet_ntoa(wkServIP))) C******************************************* C* Build the destaddr socket address struct C******************************************* c eval p_sockaddr = %addr(destaddr) c eval sin_family = AF_INET c eval sin_port = wkNtpPort c eval sin_addr = wkServIP c eval sin_zero = *ALLx'00' C************************************************************* C* Send the SNTP request to the server C************************************************************* C* LI (Leap Indicator) = 0 (not a leap second) C* VN (version number) = 1 (for max compatibility) C* MODE (operating mode) = 3 (client) C******************************************* c reset dsNTP c eval dsNtpLiVnMod = (0*NTP_LI) + (1*NTP_VN) + c (3*NTP_MODE) c eval dsNtpXmtTS = GetCurTS C******************************************* C* Send the NTP message to the server C******************************************* c if SendTo(wkSock: %addr(dsNTP):%size(dsNTP): c 0: %addr(destaddr): %size(destaddr))<1 c callp c_error('sendto') c return c endif C************************************************************* C* Get a reply from the server C************************************************************* C* Wait for data to appear on the socket C* this will timeout based on the value of C* tv_sec set above. C******************************************* c if select(wkSock+1: %addr(wkSet): *NULL: c *NULL: p_timeval) < 1 c or FD_ISSET(wkSock: wkSet) = *OFF c callp error('No response from server!') c return c endif C******************************************* C* Get back the server's reply into the C* NTP message formatted data structure C******************************************* c if recvfrom(wkSock: %addr(dsNTP): c %size(dsNTP): 0: %addr(destaddr): c wkAddrLen) < 1 c callp c_error('recvfrom') c return c endif c eval wkDoneTS = getCurTS c callp CloseSock C************************************************************* C* Calculate the amount our clock is currently off by C* and then offset the current system time by that amount C************************************************************* c eval wkOffset = c ( DiffTS( dsNtpRcvTS: dsNtpOrgTS ) + c DiffTS( dsNtpXmtTS: wkDoneTS ) ) / 2 c eval wkOffDiag = wkOffset c callp diag('Clock offset = ' + c %trim(%editc(wkOffDiag:'M'))) c callp OffsetClock(wkOffset) c return *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * This returns the current UTC time from the system clock * in NTP timestamp format. *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P GetCurTS B D GetCurTS PI 8A D CEEUTC PR ExtProc('CEEUTC') D LillDays 10I 0 D LillSecs 8F D Feedback 1A options(*omit) D SHIFT32 C CONST(4294967296) D ww1582to1900 C CONST(10010390400) D wwSecsFrom1900 S 8F D wwSecs S 8F D wwDays S 10I 0 D wwFract S 8F D dsRet DS D dsRetVal 8A D dsRetSecs 10U 0 overlay(dsRetVal:1) D dsRetFract 10U 0 overlay(dsRetVal:5) c callp CEEUTC(wwDays: wwSecs: *omit) c eval wwSecsFrom1900 = wwSecs - ww1582to1900 c eval dsRetSecs = wwSecsFrom1900 c eval wwFract = wwSecsFrom1900 - dsRetSecs c eval wwFract = wwFract * SHIFT32 c eval dsRetFract = wwFract c return dsRetVal P E *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * This returns the difference between two NTP timestamps * in NTP timestamp format. *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P DiffTS B D DiffTS PI 8F D peTS1 8A D peTS2 8A D p_TS1 s * D dsTS1 DS based(p_TS1) D dsTS1_secs 10U 0 D dsTS1_fract 10U 0 D p_TS2 s * D dsTS2 DS based(p_TS2) D dsTS2_secs 10U 0 D dsTS2_fract 10U 0 D SHIFT32 C CONST(4294967296) D ww1 S 8F D ww2 S 8F D wwDiff S 8F D wwFract S 8F c eval p_TS1 = %addr(peTS1) c eval p_TS2 = %addr(peTS2) c eval ww1 = dsTS1_secs c eval ww2 = dsTS2_secs c eval wwDiff = ww1 - ww2 c eval ww1 = dsTS1_fract c eval ww2 = dsTS2_fract c eval wwFract = ww1 - ww2 c eval wwDiff = wwDiff + c (wwFract / SHIFT32) c return wwDiff P E *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * Kill program and return an escape message that corresponds * to the current ILE C error number. *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P c_error B D c_error PI D peErrMsg 128A const D geterrno PR * ExtProc('__errno') D strerror PR * ExtProc('strerror') D errno 10I 0 value D p_errno S * D errno S 10I 0 based(p_errno) c eval p_errno = geterrno c callp error(%trimr(peErrMsg)+' ' + c %str(strerror(errno))) P E *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ * Kill program and return an escape message *+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P error B D error PI D peMsg 256A const D SndPgmMsg PR ExtPgm('QMHSNDPM') D MessageID 7A Const D QualMsgF 20A Const D MsgData 256A Const D MsgDtaLen 10I 0 Const D MsgType 10A Const D CallStkEnt 10A Const D CallStkCnt 10I 0 Const D MessageKey 4A D ErrorCode 1A D dsEC DS D dsECBytesP 1 4I 0 inz(256) D dsECBytesA 5 8I 0 inz(0) D dsECMsgID 9 15 D dsECReserv 16 16 D dsECMsgDta 17 256 D wwMsgKey S 4A D wwMsg S 52A c callp SndPgmMsg('CPF9897': 'QCPFMSG *LIBL': c peMsg: %len(peMsg): '*ESCAPE': c '*PGMBDY': 1: wwMsgKey: dsEC) c if dsECBytesA > 0 c eval wwMsg = dsECMsgID + ' occurred ' + c 'calling QMHSNDPM API' c dsply wwMsg c endif c return P E P*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P* This puts a diagnostic message into the job log P* Useful for placing debugging/status info into programs P* for programmers to check later. P* P* Returns 0 for success, -1 for error. P*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P Diag B D Diag PI D peMsgTxt 256A Const D***************************************************** D* API error code data structure D***************************************************** D dsEC DS D dsECBytesP 1 4I 0 INZ(256) D dsECBytesA 5 8I 0 INZ(0) D dsECMsgID 9 15 D dsECReserv 16 16 D dsECMsgDta 17 256 D SndPgmMsg PR ExtPgm('QMHSNDPM') D MessageID 7A Const D QualMsgF 20A Const D MsgData 256A Const D MsgDtaLen 10I 0 Const D MsgType 10A Const D CallStkEnt 10A Const D CallStkCnt 10I 0 Const D MessageKey 4A D ErrorCode 1A D wwMsgLen S 10I 0 D wwTheKey S 4A c ' ' checkr peMsgTxt wwMsgLen c if wwMsgLen<1 c return c endif c callp SndPgmMsg('CPF9897': 'QCPFMSG *LIBL': c peMsgTxt: wwMsgLen: '*DIAG': c '*': 0: wwTheKey: dsEC) c if dsECBytesA > 0 c return c endif c return P E P*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P* This'll be called by the system if we end abnormally, P* so that the NTP port will always get closed. P*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P CloseSock B D CloseSock PI c if wkSock >= 0 c callp close(wkSock) c eval wkSock = -1 c endif P E P*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P* This'll be called by the system if we end abnormally, P* so that the NTP port will always get closed. P*+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ P OffsetClock B D OffsetClock PI D peOffset 8F value D CEELOCT PR ExtProc('CEELOCT') D Lillian 10I 0 D Seconds 8F D Gregorian 23A D CEEDATM PR ExtProc('CEEDATM') OPDESC D Seconds 8F D Picture 12A const D DateTime 12A D Cmd PR ExtPgm('QCMDEXC') D command 50A const D length 15P 5 const D wwDays S 10I 0 D wwSecs S 8F D wwGreg S 23A D wwDateAndTime S 12A C* Get an updated time from the system clock & offset it: C* FIXME: Drops any fractions from the seconds... c callp CEELOCT(wwDays: wwSecs: wwGreg) c eval wwSecs = wwSecs + peOffset c callp CEEDATM(wwSecs: 'MMDDYYHHMISS': c wwDateAndTime) C* Set time ASAP: C* FIXME: Assumes time is in HHMMSS format c callp(e) Cmd('CHGSYSVAL SYSVAL(QTIME) VALUE(''' + c %subst(wwDateAndTime:7:6) +''')': 50) c if %error c callp error('Unable to set time!') c return c endif c callp diag('Time set to ' + c %subst(wwDateAndTime:7:6)) C* Set date: C* FIXME: Assumes date is in MMDDYY format c callp(e) Cmd('CHGSYSVAL SYSVAL(QDATE) VALUE(''' + c %subst(wwDateAndTime:1:6) +''')': 50) c if %error c callp error('Unable to set date!') c return c endif c callp diag('Date set to ' + c %subst(wwDateAndTime:1:6)) P E