;; Author: David Krentzlin <david@lisp-unleashed.de>
;; Copyright (c) 2011 David Krentzlin <david@lisp-unleashed.de>
;; 
;;   Permission is hereby granted, free of charge, to any person
;;   obtaining a copy of this software and associated documentation
;;   files (the "Software"), to deal in the Software without
;;   restriction, including without limitation the rights to use,
;;   copy, modify, merge, publish, distribute, sublicense, and/or sell
;;   copies of the Software, and to permit persons to whom the
;;   Software is furnished to do so, subject to the following
;;   conditions:
;; 
;;   The above copyright notice and this permission notice shall be
;;   included in all copies or substantial portions of the Software.
;; 
;;   THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
;;   EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES
;;   OF MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
;;   NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT
;;   HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY,
;;   WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING
;;   FROM, OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR
;;   OTHER DEALINGS IN THE SOFTWARE.
;; 
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(module nomads
(debug database-credentials migration-directory
       filename-pattern filename-partitioner filename-joiner versioner 
       version? version-less? version-equal? version< migrate
       db-with-connection db-with-transaction db-schema-information-exists?
       db-schema-version-table  db-initialize-schema-information db-version-list
       migration-version migration-filename migration? error-on-non-existent-version
       db-add-version db-remove-version db-execute-sql db-error? db-message-from-error
       generate-migration db-latest-version version->string
       string->version error-on-duplicate-migrations)

(import chicken scheme)
(require-library posix filepath defstruct data-structures srfi-1 srfi-13 extras)

(import
  defstruct
  (only posix glob directory?)
  (only extras sprintf printf)
  (only data-structures sort compose string-split)
  (only srfi-1 filter fold any)
  (only srfi-13 string-downcase string-join)
  (only filepath filepath:drop-extension filepath:combine filepath:split-file-name))

(define debug (make-parameter #f))

(define (dbg fmt . args)
  (when (debug)
    (display "*dbg*: ")
    (apply printf fmt args)
    (newline)
    (flush-output)))

(define error-on-duplicate-migrations  (make-parameter #t))
(define error-on-non-existent-version  (make-parameter #t))

(define database-credentials          (make-parameter #f))
(define migration-directory           (make-parameter #f))

;; the following procedures help to abstract away the formatting of
;; migratons-file-names as well as the versioning scheme
(define filename-pattern              (make-parameter "*-*"))
(define filename-partitioner      (make-parameter
                                   (lambda (filename)
                                     (let ((parts (string-split filename "-")))
                                       (cond
                                        ((< (length parts) 2) (cons #f filename))
                                        (((string->version) (car parts))
                                         => (lambda (num) (cons num (string-join (cdr parts) "-"))))
                                        (else (cons #f filename)))))))

(define filename-joiner           (make-parameter
                                   (lambda (version file)
                                     (sprintf "~A-~A" version file))))


;; Parameterize this to implement you own versioning scheme
(define versioner       (make-parameter
                         (lambda (max-version)
                           (if max-version
                               (+ max-version 1)
                               1))))



(define version?        (make-parameter number?))
(define version-less?   (make-parameter <))
(define version-equal?  (make-parameter =))

(define version->string (make-parameter
                         (lambda (str)
                           (cond
                            ((string? str) str)
                            ((number? str) (number->string str))
                            (else #f)))))

(define string->version (make-parameter
                         (lambda ( version)
                           (cond
                            ((number? version) version)
                            ((string? version) (string->number version))
                            (else #f)))))

(define (version< lhs rhs)
  ((version-less?) lhs rhs))

(define (version> lhs rhs)
  (version< rhs lhs))

(define (version= lhs rhs)
  ((version-equal?) lhs rhs))

(define (version<= lhs rhs)
  (or (version< lhs rhs) (version= lhs rhs)))

(define (version-max version . other-versions)
  (fold (lambda (x xs)
          (if (version> x xs) x xs))
        version
        other-versions))

;;representation of a migration
(defstruct migration version filename statements)

;; If you want to provide a database-api you have to
;; bind these parameters

(define db-schema-version-table       (make-parameter "schema_info"))

;;(lambda (db-credentials proc) ...)
(define db-with-connection                (make-parameter #f))

;;(lambda (db thunk) ...)
(define db-with-transaction               (make-parameter #f))

;;(lambda (db) ...)
(define db-schema-information-exists?     (make-parameter #f))

;;(lambda (db) ...)
(define db-initialize-schema-information  (make-parameter #f))

;;(lambda (db) ...)
(define db-version-list                 (make-parameter #f))

;;(lambda (db version) ...)
(define db-add-version                    (make-parameter #f))

;;(lambda (db version) ...)
(define db-remove-version                 (make-parameter #f))

;;(lambda (db sql) ...)
(define db-execute-sql                    (make-parameter #f))

;;(lambda (exn) ...)
(define db-error?                         (make-parameter #f))

;;(lambda (exn) ...)
(define db-message-from-error             (make-parameter #f))


(define (db-latest-version db)
  (let loop ((ls (map (string->version) ((db-version-list) db (db-schema-version-table)))) (latest #f))
    (unless (null? ls)
      (dbg "Checking: ~S" (car ls)))
    (cond
     ((null? ls)                 latest)
     ((not latest)               (loop (cdr ls) (car ls)))
     ((version< latest (car ls)) (loop (cdr ls) (car ls)) )
     (else                       (loop (cdr ls) latest)))))

(define migration-template "((UP\n  \"Fill in upward statements\")\n(DOWN\n  \"Fill in downward statements\"))")

;;generate a migration stub and return its name
(define (generate-migration name)
  (unless (migration-directory)
    (error "Migration directory has not been set"))
  
  (let* ((filename (generate-migration-file-name name))
         (full-path (filepath:combine (migration-directory) filename)))
    (call-with-output-file full-path (cut display migration-template <>))
    filename))

(define (generate-migration-file-name name)
  (let ((latest (latest-file-version)))
    ((filename-joiner) ((versioner) latest) name)))

(define (latest-file-version)
  (let ((migs (reverse (load-migrations))))
    (if (null? migs) #f (migration-version (car migs)))))

(define (make-nomads-condition  message arguments)
  (apply make-property-condition
         'nomads-error
         (append
          (if message (list 'message message) '())
          (if (and arguments (not (null? arguments))) (list 'arguments arguments) '()))) )

(define (complain kind fmt . args)
  (signal
   (make-composite-condition
    (make-nomads-condition fmt args)
    (make-property-condition kind))))

(define (default-callback checkpoint irreversible? #!key (message "") (error #f))
  (let ((direction (car checkpoint))
        (migration (cdr checkpoint)))

    (if error
        (printf "[Error] ~A~%" message)
        (printf "[~A][~A]: ~A [~A]~%"
          (migration-version migration)
          direction
          (filepath:drop-extension
           (migration-filename migration))
          (if irreversible? "IRREVERSIBLE" "OK")))))

;; This is the basic migration procedure
;; version :: can be a specific version or either of (latest
;;            earliest)
;; callback :: a procedure that is called after the invocation of
;; each checkpoint. It is passed the check-point and a boolean that
;; indicates if the checkpoint was irreversible
(define (migrate #!key (version 'latest) (callback default-callback))
  (assert-proper-version version)
  (assert-proper-configuration)
  ((db-with-connection) (database-credentials)
   (cut load-and-run-migrations <> callback version)))

(define (assert-proper-configuration)
  (unless (migration-directory)
    (error "Migration directory has not been set"))

  (unless (directory? (migration-directory))
    (error "The migration directory does not seem to be a directory. " (migration-directory)))
  
  (unless (database-credentials)
    (error "You must set the database credentials")))

(define (assert-proper-version version)

  (unless (or (eq? version 'latest)
              (eq? version 'earliest)
              ((version?) version))
    (error "You need to supply a valid version")))

(define (load-and-run-migrations db callback #!optional (target-version 'latest))    
  (unless ((db-schema-information-exists?) db (db-schema-version-table))
    ((db-initialize-schema-information) db (db-schema-version-table)))
  
  (let ((migration-path (build-migration-path db target-version)))
    (call-with-current-continuation
     (lambda (exit)
       (for-each
        (lambda (check-point)
          (unless (run-check-point db check-point exit callback)
            (exit #f))) migration-path)
       #t))))

;; this procedure builds up the migration path to walk.
;; It returns a list of check-points to visit.
;; The loading of the actual migration code is limited to those
;; migrations that are actually needed. This is a feature.
(define (build-migration-path db target-version)
  (let ((migrations (load-migrations)))
    (dbg "migrations: ~A" migrations)

    ;;perform checks on the target version
    (if (and (error-on-non-existent-version)
             (not (or (eq? target-version 'earliest)
                      (eq? target-version 'latest)
                      (any (lambda (mig) (version= (migration-version mig) target-version)) migrations))))
      (complain 'non-existent-version "The requested target version does not exist" target-version))
    (if (null? migrations) (list)
        (let ((max-file-version (apply version-max (map migration-version migrations)))
              (db-version (db-latest-version db)))
          (dbg "Max: ~A DB: ~A" max-file-version db-version)
          (cond
           ((and (not db-version) (eq? target-version 'latest))
            (map (cut build-check-point 'up <>) migrations))
           ((and (not db-version) (eq? target-version 'earliest))
            (list))
           ((not db-version)
            (map (cut build-check-point 'up <>)   (select-range migrations to: target-version)))
           ((eq? target-version 'latest)
            (map (cut build-check-point 'up <>)   (select-range migrations from: db-version to: max-file-version)))
           ((eq? target-version 'earliest)
            (map (cut build-check-point 'down <>) (reverse (select-range migrations to: db-version))))
           ((version> target-version db-version)
            (map (cut build-check-point 'up <>)   (select-range migrations from: db-version to: target-version)))
           ((version< target-version db-version)
            (map (cut build-check-point 'down <>) (reverse (select-range migrations from: target-version to: db-version))))
           (else (list)))))))

;; a check-point is a complete migration (with statemts read) plus
;; its direction
(define (build-check-point direction migration)
  (migration-statements-set! migration (load-migration-file migration))
  (cons direction migration))

;; load the content of the migration
(define (load-migration-file mig)
  (let ((path (filepath:combine
               (migration-directory)
               ((filename-joiner) (migration-version mig) (migration-filename mig)))))
    (if (file-exists? path)
        (handle-exceptions
            exn
            (complain 'invalid-migration "Invalid migration file: " path)
          (let ((form (eval (list 'quasiquote (call-with-input-file path read)))))
            (unless (list? form)
              (complain 'invalid-migration "Invalid migration file: " path))
            form)))))

(define (select-range migs #!key (from #f) (to #f))
  (cond
   ((and (not from) (not to)) migs)
   ((not from)
    (filter
     (lambda (mig)
       (version<= (migration-version mig) to)) migs))
   (else
    (filter
     (lambda (mig)
       (and (version>  (migration-version mig) from)
            (version<= (migration-version mig) to))) migs))))

;; create the migration objects from the migration-files in the
;; migration-directory.
;; NOTE: this procedure returns only partial migrations. In
;; particular, the migrations have no valid statements-attribute yet
(define (load-migrations)
  (let ((pattern (filepath:combine (migration-directory) (filename-pattern))))
    (sort
     (filter migration? (map build-migration (glob pattern)))
     (lambda (lhs rhs)
       (when (and (error-on-duplicate-migrations)
                  (version= (migration-version lhs) (migration-version rhs)))
         (complain 'duplicate-version "You have two migrations with equal versions: " (migration-filename lhs) (migration-filename rhs)))
       (version< (migration-version lhs)
                 (migration-version rhs))))))

(define (build-migration path)
  (let* ((parts (filepath:split-file-name path))
         (particels ((filename-partitioner) (cadr parts))))
    (dbg "Extracted particels ~A" particels)
    (if (car particels)
        (make-migration version: (car particels) filename: (cdr particels))
        #f)))

;; This is the piece of code that does actually execute a step of
;; the migration.
;; Each check-point is executed in a transaction.
(define (run-check-point db check-point exit callback)
  (dbg "Running check-point")
  (let* ((direction (car check-point))
         (migration (cdr check-point))
         (stmts     (statements-for-direction db (migration-statements migration) direction)))
    (handle-exceptions exn
        (begin
          (callback check-point #f message: (error-message exn) error: exn)
          #f)        
        ((db-with-transaction) db
         (lambda ()
           (run-statements db stmts (lambda (#!optional (message ""))
                                      (callback check-point #t message: message)
                                      (exit #f)))
           (finish-check-point db migration direction)))
      (callback check-point #f)
      #t)))

(define (error-message exn)
  (cond
   (((db-error?) exn)
    ((db-message-from-error) exn))
   (else ((condition-property-accessor 'exn 'msg "Unknown Error") exn))))

(define (statements-for-direction db statements direction)
  (let loop ((ls statements))
    (cond
     ((null? ls) (list ""))
     ((symbol-equal-ci? (caar ls) direction)
      (cdar ls))
     (else (loop (cdr ls))))))

(define (symbol-equal-ci? lsym rsym)
  (let ((str/down (compose string-downcase symbol->string)))
    (equal? (str/down lsym) (str/down rsym))))

(define (run-statements db statements irreversible)
  (for-each
   (lambda (stmt)
     (cond
      ((eq? stmt #f)     (irreversible))
      ((and (pair? stmt) (eq? (car stmt) #f) (string? (cdr stmt)))
       (irreversible (cdr stmt)))
      ((procedure? stmt) (stmt db))
      ((string? stmt)    ((db-execute-sql) db stmt))
      (else              (error "Invalid Statement given"))))
   statements))

(define (finish-check-point db migration direction)
  (case direction
    ((down) ((db-remove-version) db ((version->string) (migration-version migration)) (db-schema-version-table)))
    ((up)   ((db-add-version)    db ((version->string) (migration-version migration)) (db-schema-version-table)))
    (else                        (error "Invalid direction"))))
)
;; module