#!/bin/sh
exec ${GUILE-guile} -e '(ttn-do make-pgtable)' -s $0 "$@" # -*- scheme -*-
!#
;;; make-pgtable

;; Copyright (C) 2001, 2003, 2004, 2005, 2007, 2009, 2010,
;;   2011 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.

;;; Commentary:

;; Usage: make-pgtable [OPTIONS] TABLE...
;;
;; Create PostgreSQL table(s) in a database.
;; OPTIONS can be one or more of:
;;   -l, --list        list all db and table names and exit successfully
;;   -L, --list-fully  like ‘--list’ but also include defs
;;   -s, --show-defs   show defs for TABLE but do not create it
;;   -d, --db NAME     use db NAME [default: value of USER env var]
;;   -x, --go-away     delete table
;;   -e, --echo        display the SQL command before dispatch
;;
;; The name of the meta-file required by make-pgtable can be specified
;; by env var ${USER}_PGTABLE_DEFS, where ${USER} is the value of env
;; var USER, upcased.  For example:
;;
;;   "jrhacker" => "JRHACKER_PGTABLE_DEFS"
;;
;; See docs for module (ttn-do zzz various-db) for a description of the
;; meta-file format.

;;; Code:

(define-module (ttn-do make-pgtable)
  #:export (main)
  #:use-module ((ttn-do zzz banalities) #:select (check-hv
                                                  qop<-args))
  #:use-module ((database postgres) #:select (pg-result-status
                                              pg-result-error-message))
  #:use-module ((database postgres-col-defs)
                #:prefix DEF: #:select (type-name))
  #:use-module ((database postgres-meta)
                #:prefix META: #:select (check-type/elaborate))
  #:use-module ((ttn-do zzz personally) #:select (FE fs fso fse))
  #:use-module ((ttn-do zzz various-db) #:select (personal-pgtable-all
                                                  personal-pgtable-defs
                                                  personal-pgtable-worker)))

(setenv "TTN_PGTABLE_DEFS"
        (getenv (string-append (string-upcase (getenv "USER"))
                               "_PGTABLE_DEFS")))

(define *trace-port* #f)

(define *db* (getenv "USER"))

(define *all-defs* (personal-pgtable-all))

(define (fln s . args)
  (apply fso s args)
  (newline))

(define (fln-err s . args)
  (apply fse s args)
  (newline (current-error-port)))

(define (worker message db table)
  (FE (personal-pgtable-defs db table)
      (lambda (def)
        (META:check-type/elaborate (DEF:type-name def))))
  (fln "~A table ~A in db ~A" message table db)
  (let ((w (personal-pgtable-worker db table)))
    (w #:trace-exec *trace-port*)
    w))

(define (make-table! db table)
  (let* ((w (worker "making" db table))
         (res (w #:create)))
    (fln " => ~A" res)
    (or (eq? 'PGRES_COMMAND_OK (pg-result-status res))
        (begin
          (fln-err "~A" (pg-result-error-message res))
          #f))))

(define (delete-table! db table)
  (let* ((w (worker "deleting" db table))
         (res (w #:drop))
         (rv #t))
    (fln " => ~A" res)
    (FE res (lambda (sub)
              (or (eq? 'PGRES_COMMAND_OK (pg-result-status sub))
                  (begin
                    (fln-err "~A" (pg-result-error-message res))
                    (set! rv #f)))))
    rv))

(define (list-everything details?)
  (FE *all-defs*
      (lambda (db)
        (fln "- ~A" (car db))
        (FE (cdr db)
            (lambda (table)
              (fln "~A  - ~A"
                   (if details? "\n" "")
                   (car table))
              (and details?
                   (FE (cdr table)
                       (lambda (def)
                         (fln "    - ~S" def))))))
        (newline))))

(define (main args)
  (check-hv args '((package . "ttn-do")
                   (version . "2.2")
                   (help . commentary)))
  (let ((qop (qop<-args
              args '((db         (single-char #\d) (value #t))
                     (go-away    (single-char #\x))
                     (echo       (single-char #\e))
                     (show-defs  (single-char #\s))
                     (help       (single-char #\h))
                     (list       (single-char #\l))
                     (list-fully (single-char #\L))))))
    (cond ((qop 'list)
           (list-everything #f)
           (exit #t))
          ((qop 'list-fully)
           (list-everything #t)
           (exit #t))
          ((null? (qop '()))
           (error "must specify TABLE")))
    (let ((db (or (qop 'db) *db*)))
      (or (assoc db *all-defs*)
          (error "no such database:" db))
      (and (qop 'echo) (set! *trace-port* (current-output-port)))
      (FE (qop '())
          (lambda (table)
            (cond ((qop 'show-defs)
                   (or (and=> (personal-pgtable-defs db table)
                              (lambda (data)
                                (fs "(~S" (car data))
                                (FE (cdr data)
                                    (lambda (x)
                                      (fs "~% ~S" x)))
                                (fln ")")))
                       (error "no such table:" table)))
                  ((qop 'go-away)
                   (delete-table! db table))
                  (else
                   (make-table! db table))))))))

;;; make-pgtable ends here