;; A simple net-set-time for Pocket Scheme.
;; Talks to servers using TCP/Time protocol (RFC 868).
;; goetter 19-May-2000
;;  created after sleeping on this for six months
;; goetter 6-Oct-2000
;;  wasn't truncating a division correctly in 64-bit arithmetic
;; goetter 25-Oct-2000
;;  pscheme 1.1.0 no longer reverts to inexact math
;; goetter 10-May-2005
;;  ported to pscheme 1.2 (raw-number I/O, 64-bit rawvecs)

(require "ss.dll")
(require "w32.dll")

(define *kdll* 
  (cond-expand (windows-nt "kernel32.dll")
	       (windows-ce "coredll.dll")))


(define GetSystemTime
  (w32:foreign-procedure *kdll* "GetSystemTime" '(w32api void lpvoid)))
(define SetSystemTime
  (w32:foreign-procedure *kdll* "SetSystemTime" '(w32api bool lpvoid)))
(define SystemTimeToFileTime
  (w32:foreign-procedure *kdll* "SystemTimeToFileTime" '(w32api bool lpvoid lpvoid)))
(define FileTimeToSystemTime
  (w32:foreign-procedure *kdll* "FileTimeToSystemTime" '(w32api bool lpvoid lpvoid)))

(define (dump-systemtime rgw)
  (for-each (lambda (k) (display k))
    (list "Year " (raw-vector-ref rgw 0) " Month " (raw-vector-ref rgw 1)
       " D.O.W. " (raw-vector-ref rgw 2) " Day " (raw-vector-ref rgw 3)
       " Hour " (raw-vector-ref rgw 4) " Minute " (raw-vector-ref rgw 5)
       " Second " (raw-vector-ref rgw 6) " uSec " (raw-vector-ref rgw 7) #\newline )))
        
(define (ftp-time host)
  (let ((s (tcp:connect-client host 37))
        (rgw (make-raw-vector 8 'u16))
        (rgqw (make-raw-vector 1 'u64))
        (n 0))
    (GetSystemTime rgw)
    (SystemTimeToFileTime rgw rgqw)
    ;; Convert filetime to seconds since midnight, Jan 1 1970 UTC, per MSKB Q167296
    (set! n (raw-vector-ref rgqw 0))
    (set! n (quotient n 10000000))
    (set! n (- n 11644473600))
    ;; Now bias from Jan 1 1970 to Jan 1 1900, per RFC 868
    (set! n (+ n 2208988800))

    ;; Poke server
    (write-raw-number n
		      (tcp:connection-output s)
		      4
		      'network)
    ;; Get response
    (set! n (read-raw-number (tcp:connection-input s)
			     4
			     'network))
    (if (not (number? n))
	(error "Host responded incorrectly to TCP Time query."))

    (set! n (- n 2208988800))
    (set! n (+ n 11644473600))
    (set! n (* n 10000000))
    (raw-vector-set! rgqw 0 n)
    (FileTimeToSystemTime rgqw rgw)
    (SetSystemTime rgw)))