;;; various-db.scm

;; Copyright (C) 2002, 2003, 2004, 2005, 2006, 2007, 2009,
;;   2010, 2011, 2012 Thien-Thi Nguyen
;;
;; This file is part of ttn-do, released under the terms of the
;; GNU General Public License as published by the Free Software
;; Foundation; either version 3, or (at your option) any later
;; version.  There is NO WARRANTY.  See file COPYING for details.

;;; Code:

(define-module (ttn-do zzz various-db)
  #:export (get-meta-file
            set-meta-file!
            personal-pgtable-all
            personal-pgtable-defs
            personal-pgtable-manager
            personal-pgtable-worker
            text-db-table-meta
            read-text-db-table)
  #:use-module ((ttn-do zzz 0gx forms-from) #:select (forms<-file))
  #:use-module ((ttn-do zzz filesystem) #:select (safe-rewind))
  #:use-module ((ice-9 mapping) #:select (hash-table-mapping
                                          mapping-ref
                                          mapping-set!))
  #:use-module ((ice-9 rdelim) #:select (read-line
                                         read-delimited))
  #:use-module ((srfi srfi-13) #:select (string-trim-both
                                         string-prefix?))
  #:use-module ((database postgres-table) #:select (pgtable-manager
                                                    pgtable-worker)))

;; cache

(define *cache* (hash-table-mapping #:equal string=?))

;; the meta file

(define *pgtable-defs* (or (getenv "TTN_PGTABLE_DEFS")
                           (in-vicinity (getenv "HOME") ".pgtable-defs")))

(define *pgtable-defs-mtime* -1)

;; procs

;; Return the meta-file filename.
;;
(define (get-meta-file)
  *pgtable-defs*)

;; Set the meta-file to be @var{filename}.
;;
(define (set-meta-file! filename)
  (set! *pgtable-defs-mtime* -1)
  (set! *pgtable-defs* filename))

(define (all-defs)
  (or (file-exists? *pgtable-defs*)
      (error "could not find defs file:" *pgtable-defs*))
  (let ((mtime (stat:mtime (stat *pgtable-defs*))))
    (cond ((> mtime *pgtable-defs-mtime*)
           (set! *pgtable-defs-mtime* mtime)
           (mapping-set!
            *cache* *pgtable-defs*
            (apply-to-args
             (forms<-file *pgtable-defs*)
             (lambda (kws all)
               (letrec ((sub (lambda (x)
                               (cond ((keyword? x)
                                      (or (and=> (assq-ref kws x) car)
                                          (error "unknown keyword:" x)))
                                     ((pair? x)
                                      (map sub x))
                                     (else x)))))
                 (sub all)))))))
    (mapping-ref *cache* *pgtable-defs*)))

;; Return a list of all the definitions described in the meta-file.
;;
(define (personal-pgtable-all) (all-defs))

;; Return the definitions for database @var{db}, table @var{table}.
;;
(define (personal-pgtable-defs db table)
  (assoc-ref (assoc-ref (all-defs) db) table))

;; Return a ``pgtable manager'' procedure
;; (@pxref{Single-Table Abstraction,,,guile-pg})
;; for database @var{db}, table @var{table}.
;;
(define (personal-pgtable-manager db table)
  (pgtable-manager db table (personal-pgtable-defs db table)))

;; Return a ``pgtable worker'' procedure
;; (@pxref{Single-Table Abstraction,,,guile-pg})
;; for database @var{db}, table @var{table}.
;;
(define (personal-pgtable-worker db table)
  (pgtable-worker db table (personal-pgtable-defs db table)))

(define (read-zonk-trailing-ws port)    ; handle eol: LF, CR, CRLF
  (let ((val (read port)))
    (let loop ((c (peek-char port)))
      (case c
        ((#\space #\tab)
         (read-char port)
         (loop (peek-char port)))
        ((#\cr)
         (read-char port)
         (and (char=? #\newline (peek-char port))
              (read-char port)))
        ((#\newline)
         (read-char port))))
    val))

(define (text-db-table-config flags . stuff)
  (let* ((delim (assq-ref stuff 'delim))
         (specs (assq-ref stuff 'fields))
         (fgroks (map (lambda (spec)
                        (case (cadr spec)
                          ((sexp) read)
                          ((sexp-line) read-zonk-trailing-ws)
                          ((line) read-line)
                          ((rest-lines)
                           (lambda (port)
                             (read-delimited delim port)))
                          ((rest-lines-trim)
                           (lambda (port)
                             (string-trim-both (read-delimited delim port))))
                          (else
                           (error "unknown fgrok type:" spec))))
                      specs))
         (meta (assq-ref stuff 'meta))  ; opaque
         (rr-data (lambda (port)
                    (catch 'done
                           (lambda ()
                             (map (lambda (name fgrok)
                                    (let ((val (fgrok port)))
                                      (if (eof-object? val)
                                          (throw 'done val)
                                          (if (memq #:list flags)
                                              val
                                              (cons name val)))))
                                  (map car specs) fgroks))
                           (lambda args
                             (cadr args)))))
         (rr-closure (lambda (port)
                       (let ((record (rr-data port)))
                         (cond ((eof-object? record)
                                record)
                               ((memq #:list flags)
                                (lambda (sel)
                                  (list-ref record sel)))
                               (else
                                (lambda (key)
                                  (assq-ref record key)))))))
         (read-record (if (memq #:closure flags)
                          rr-closure
                          rr-data)))
    (lambda (key)
      (case key
        ((meta) meta)
        ((delim) delim)
        ((names) (map car specs))
        ((read-record) read-record)))))

(define text-db-table-meta (make-object-property))

;; Read a text-db-table from @var{filename/port}, return a list of records.
;; Each record is an alist whose keys are the field names, in order.
;; @var{filename/port} can be a filename (string), or an input port.
;; In the latter case, it is left open when done.
;;
;; As a side effect, the property @code{text-db-table-meta} (procedure with
;; setter) for the returned list is set to the table's metadata, if any.
;;
;; @var{flags} is a list of zero or more keywords that change the default
;; behavior.  These are the recognized flags:
;;
;; @table @code
;; @item #:list
;; Return each record as a list instead of as an alist.
;;
;; @item #:closure
;; Return each record as a closure (procedure) that accepts one arg
;; @var{sel}.  If @code{#:list} is specified, @var{sel} is a 0-based integer to
;; index into the record's data.  Otherwise, @var{sel} names a field in the
;; record's data.
;; @end table
;;
(define (read-text-db-table filename/port . flags)
  (let* ((port (if (string? filename/port)
                   (open-input-file filename/port)
                   (safe-rewind filename/port)))
         (config (let loop ((start (seek port 0 SEEK_CUR))
                            (line (read-line port)))
                   (cond ((string-prefix? "(text-db-table-config" line)
                          (seek port start SEEK_SET)
                          (apply text-db-table-config flags (cdr (read port))))
                         (else
                          (loop (seek port 0 SEEK_CUR)
                                (read-line port))))))
         (records (list #f)))
    (read-delimited (config 'delim) port)
    (let loop ((record ((config 'read-record) port)) (tp records))
      (if (eof-object? record)
          (let ((rv (cdr records)))
            (and (string? filename/port)
                 (close-port port))
            (set! (text-db-table-meta rv) (config 'meta))
            rv)                         ; rv
          (loop ((config 'read-record) port)
                (cdr (append! tp (list record))))))))

;;; various-db.scm ends here