#lang scheme

(require (prefix-in psql: "psql.ss"))
(require (prefix-in times: "times.ss"))
(require (prefix-in general: "general.ss"))

(require "engine.ss")

(require srfi/19)

(define (apply-values l)
  (apply values l))

(define timestamp-casts
  `(("now" 
     ,(make-date 2370000 41 26 20 15 3 2009 -25200)
     #"\0\1\b,\353\231\213\202"
     #"\0\1\b2\311\243\a\202")
    ("later"
     ,(make-date 2370000 41 26 10 15 1 3009 -25200)
     #"\0q Y\fm\303\202"
     #"\0q ^\352w?\202")
    ("epoch"
     ,(make-date 0 0 0 0 1 1 2000 -25200)
     #"\0\0\0\0\0\0\0\0"
     #"\0\0\0\5\336\t|\0")
    ("one"
     ,(make-date 0 1 1 1 1 1 1 -25200)
     #"\377\37\343\0\237\322\315@"
     #"\377\37\343\6}\334I@")
    ("gmt"
     ,(make-date 5430000 50 5 11 16 3 2009 0)
     #"\0\1\b93\257t\266"
     #"\0\1\b93\257t\266")
    ("end of world"
     ,(make-date 0 0 0 0 25 12 2012 -25200)
     #"\0\1t\240\303|@\0"
     #"\0\1t\246\241\205\274\0")))

(define (for-timestamp l get-key get-value)
  (map 
   (λ (group)
     (list* (car group) (get-key group) (get-value group)))
   l))

(define (date-to-gmt date)
  (if (= (date-zone-offset date) 0) date
      (time-utc->date (date->time-utc date) 0)))

(define (throwaway-zone date)
  (make-date
   (date-nanosecond date)
   (date-second date)
   (date-minute date)
   (date-hour date)
   (date-day date)
   (date-month date)
   (date-year date)
   0))

(define timestamp-local-casts
  (for-timestamp timestamp-casts (compose date->time-utc throwaway-zone cadr) caddr))
(define timestamp-tz-casts
  (for-timestamp timestamp-casts (compose 
                                  date-to-gmt cadr) cadddr))

(define (to-hex char)
  (case char
    [(#\0) 0]
    [(#\1) 1]
    [(#\2) 2]
    [(#\3) 3]
    [(#\4) 4]
    [(#\5) 5]
    [(#\6) 6]
    [(#\7) 7]
    [(#\8) 8]
    [(#\9) 9]
    [(#\a) #xa]
    [(#\b) #xb]
    [(#\c) #xc]
    [(#\d) #xd]
    [(#\e) #xe]
    [(#\f) #xf]
    [else (error (format "Whubuh? ~s~n" char))]))

(define (absorb s)
  (let loop ([hexes (string->list s)] [result null])
    (if (null? hexes) (apply bytes-append (reverse result))
        (loop (cddr hexes)
              (cons
               (bytes (+ (* #x10 (to-hex (car hexes))) (to-hex (cadr hexes))))
               result)))))

(define (generate)
  (let-values ([(input output) (psql:generate)])
    (let loop ([casts timestamp-casts])
      (if (null? casts) (void)
          (let ([name (car (car casts))]
                [date (cadr (car casts))])
            (display name)(display "\n")
            (let typeloop ([types '("timestamp" "timestamptz")])
              (if (null? types) (void)
                  (let ([command 
                         (format "select encode(~a_send('~a'::~a),'hex');\n"
                                 (car types)
                                 (format (date->string date "~~a-~m-~d ~H:~M:~~a~z")
                                         (if (< (date-year date) 1000)
                                             (if (< (date-year date) 100)
                                                 (if (< (date-year date) 10)
                                                     (date->string date "000~Y")
                                                     (date->string date "00~Y"))
                                                 (date->string date "0~Y"))
                                             (date->string date "~Y"))
                                         (exact->inexact (+ (date-second date) (/ (date-nanosecond date) 1000000000))))
                                 (car types))])
                    (display command)
                    (display command output)
                    (write (absorb (read input)))
                    (display "\n")
                    (typeloop (cdr types)))))
            (loop (cdr casts)))))
    (close-input-port input)
    (close-output-port output)))


(general:set-info! (get-engine))
(times:set-info! (get-engine))

(require "codec-check.ss")

(define tests 
  (test-suite
   "timestamps"
   (let ([engine (get-engine)])
     (test-codec "timestamp-local" timestamp-local-casts
                 (λ (value) 
                   (send engine encode 1114 value))
                 (λ (bytes) 
                   (send engine decode 1114 bytes)))
     (test-codec "timestamp-tz" timestamp-tz-casts
                 (λ (value) 
                   (send engine encode 1184 value))
                 (λ (bytes) 
                   (send engine decode 1184 bytes))))))

(provide tests)