;;; RFC3339 datetime parser

;; Copyright (c) 2010 Jim Ursetto.  All Rights Reserved.
;; License: BSD.

(module rfc3339
  (
   ;; rfc3339 record
   make-rfc3339 rfc3339?
   rfc3339-year rfc3339-month rfc3339-day rfc3339-hours
   rfc3339-minutes rfc3339-seconds rfc3339-fractions rfc3339-offset

   ;; main interface
   string->rfc3339 rfc3339->string
   rfc3339->seconds
   time->rfc3339

   ;; convenience functions
   rfc3339->vector vector->rfc3339
   rfc3339
   seconds->rfc3339
   rfc3339->utc-time rfc3339->local-time
   utc-time->rfc3339
   )

;;; date handling

(import scheme (chicken base))
(import (only (chicken time posix) seconds->utc-time seconds->local-time utc-time->seconds))
(import (only (chicken format) fprintf))
(import (chicken irregex))
(import regex)
(import matchable)

(define +rx:datetime+
  (irregex '(: (submatch (= 4 num)) #\-
               (submatch (= 2 num)) #\-
               (submatch (= 2 num)) (or #\t #\T)
               (submatch (= 2 num)) #\:
               (submatch (= 2 num)) #\:
               (submatch (= 2 num))
               (? (submatch #\. (+ num)))
               (submatch (+ any)))))
(define +rx:datetime-tz+
  (irregex '(: (submatch (or #\+ #\-))
               (submatch (= 2 num)) #\:
               (submatch (= 2 num)))))

(define-record-type rfc3339
  (make-rfc3339 year month day hours minutes seconds fractions offset)
  rfc3339?
  (year rfc3339-year)
  (month rfc3339-month)
  (day rfc3339-day)
  (hours rfc3339-hours)
  (minutes rfc3339-minutes)
  (seconds rfc3339-seconds)
  (fractions rfc3339-fractions)
  (offset rfc3339-offset))

;; Parses an RFC3339 format date like "yyyy-mm-ddThh:mm:ss(.sss...)(Z|[+-]hh:mm)",
;; returning an rfc3339 record.
;; YEAR is the year AD e.g. 2010, MONTH is the month 1-12 (January = 1), DAY is the day 1-31,
;; HOURS is the hour 0-23, MINUTES is the minutes 0-59, SECONDS is the seconds 0-59,
;; FRACTIONAL-SECOND is a floating-point number 0 <= x < 1,
;; TZ-OFFSET is the number of seconds west of UTC.
;; As this vector is non-normalized, some of these values may be out of range.  The format
;; itself necessarily imposes some range limits, but we do not currently check the values;
;; therefore minutes may actually be in the range 00-99.  However, values will be
;; normalized when converted into seconds since epoch or a time value (10-element vector).
(define string->rfc3339
  (let ((s->n string->number))
    (lambda (str)
      (define (extract-tz tz)
        (if (or (string=? tz "Z")
                (string=? tz "z"))
            0
            (match (string-match +rx:datetime-tz+ tz)
                    ((_ polarity hh mm)
                     (let ((sec (+ (* (s->n hh) 3600)
                                   (* (s->n mm) 60))))
                       (if (string=? "+" polarity) (- sec) sec)))
                   (else #f))))
      (match (string-match +rx:datetime+ str)
             ((_ y m d hh mm ss fs tz)
              (and-let* ((etz (extract-tz tz)))
                (make-rfc3339 (s->n y) (s->n m) (s->n d) (s->n hh) (s->n mm) (s->n ss)
                              (if fs (s->n fs) 0)
                              etz)))
             (else #f)))))

;; Converts an rfc3339 record into seconds since the UNIX epoch (1970-01-01 00:00:00 UTC).
;; Out of range values are allowed as the record is normalized during conversion.
(define rfc3339->seconds
  (lambda (R)
    (match (rfc3339->vector R)
           (#(y m d hh mm ss fs tzoff)
            (+ tzoff
               (utc-time->seconds ;; This call is extremely slow on OS X.
                (vector ss mm hh d (- m 1) (- y 1900) 0 0 #f 0)))))))

;; Converts a 10-element time vector, such as that returned by seconds->utc-time or
;; seconds->local-time, to an rfc3339 record.  The timezone offset field is honored.
;; Values are not range-checked.
;;
;; See utc-time->rfc3339 if you notice that seconds->utc-time does not return
;; a timezone offset of 0 on your system.
(define time->rfc3339
  (lambda (time)
    ;; assumes normalized time!
    (match time
           (#(ss mm hh d m-1 y-1900 _ _ _ tzoff)
            (make-rfc3339
             (+ y-1900 1900) (+ m-1 1) d hh mm ss 0 tzoff)))))

;; Convert rfc3339 record to a RFC3339 string.  The "T" and "Z" characters
;; in the result string are always uppercase.  All fields are, by definition,
;; present except for fractional seconds, which are omitted if 0.
;; RFC3339 record values are not normalized before conversion,
;; so some values could be out of range; however values /are/ clamped to
;; the range 0-99 (or 0-9999 for years).
(define (rfc3339->string dtv)
  ;; Yes, this is terrible.
  (define (c2 x)
    (cond ((< x 0) "00")
          ((>= x 100) "99")
          (else (let ((s (number->string (inexact->exact x))))
                  (if (< x 10) (string-append "0" s) s)))))
  (define (c4 x)
    (cond ((< x 0) "0000")
          ((>= x 10000) "9999")
          (else (let ((s (number->string (inexact->exact x))))
                  (cond ((< x 10) (string-append "000" s))
                        ((< x 100) (string-append "00" s))
                        ((< x 1000) (string-append "0" s))
                        (else s))))))
  (define (cf x)   ;; Selectable padding would be nice.  Needs fmt.
    (cond ((= x 0) "")
          ((< x 0) "")
          ((>= x 1) "") ;?
          (else (let ((s (number->string x)))
                  (cond ((not s) "") ;?
                        ((eq? (string-ref s 0) #\0)
                         (substring s 1))
                        (else ""))))))
  (define (tzstr tzoff)
    (if (zero? tzoff)
        "Z"
        (string-append
         (if (< tzoff 0) "+" "-")
         (c2 (quotient (abs tzoff) 3600)) ":"
         (c2 (quotient (remainder (abs tzoff) 3600) 60)))))
  (match (rfc3339->vector dtv)
         (#(y m d hh mm ss fs tzoff)
          (string-append (c4 y)  "-" (c2 m)  "-" (c2 d) "T"
                         (c2 hh) ":" (c2 mm) ":" (c2 ss)
                         (cf fs) (tzstr tzoff)))))

(define-record-printer (rfc3339 x out)
  (fprintf out "#<rfc3339 ~s>" (rfc3339->string x)))

;;; convenience functions

(define (rfc3339->vector R)
  (vector (rfc3339-year R) (rfc3339-month R) (rfc3339-day R)
          (rfc3339-hours R) (rfc3339-minutes R) (rfc3339-seconds R)
          (rfc3339-fractions R) (rfc3339-offset R)))
(define (vector->rfc3339 R)
  (apply make-rfc3339 (vector->list R)))

(define (rfc3339 x)
  (cond ((string? x)
         (string->rfc3339 x))
        ((vector? x)
         (vector->rfc3339 x))
        (else (error 'rfc3339 "argument must be a string or vector"))))

(define (seconds->rfc3339 sec)
  (utc-time->rfc3339 (seconds->utc-time sec)))  ;; utc-time->rfc3339 just in case
(define (rfc3339->utc-time R)
  (seconds->utc-time (rfc3339->seconds R)))
(define (rfc3339->local-time R)
  (seconds->local-time (rfc3339->seconds R)))

;; Convert UTC time to RFC3339.  Normally you should use
;; time->rfc3339, but versions of Chicken < x.x.x may not zero out the
;; timezone offset in the return value from seconds->utc-time.  This
;; provides a convenient workaround.
(define (utc-time->rfc3339 tm)
  (define (vector-copy v)
    (let ((len (vector-length v)))
      (do ((vec (make-vector len))
           (i 0 (+ i 1)))
          ((= i len) vec)
        (vector-set! vec i (vector-ref v i)))))
  (let ((tm (vector-copy tm)))
    (vector-set! tm 8 #f)
    (vector-set! tm 9 0)
    (time->rfc3339 tm)))


)