;; This program expects the tick test environment to be set (e.g., by
;; run-tests.sh).  It will load its first argument.

(import (chicken base)
        (chicken condition)
        (chicken errno)
        (chicken file)
        (chicken file posix)
        (chicken format)
        (chicken io)
        (chicken load)
        (chicken pathname)
        (chicken port)
        (chicken pretty-print)
        (chicken process)
        (chicken process-context)
        (chicken sort)
        (chicken string))
(import test srfi-13)
(import tick tick-params)

(define tick-program "tick")

(define work-dir (get-environment-variable "TICK_TEST_WORK_DIR"))
(define server-git-repo-dir (get-environment-variable "TICK_SERVER_GIT_REPO_DIR"))
(define server-git-url (get-environment-variable "TICK_SERVER_URL"))

(define test-conf-dir (get-environment-variable "TICK_CONF_DIR"))
(create-directory test-conf-dir 'parents)

(define test-db-dir
  (make-pathname (get-environment-variable "TICK_CACHE_DIR") "db"))
(create-directory test-db-dir 'parents)

(unless (and work-dir server-git-repo-dir test-conf-dir test-db-dir)
  (with-output-to-port (current-error-port)
    (lambda ()
      (print "This program is supposed to be called by run-tests.sh.  Aborting")
      (exit 1))))

(define (tick args #!key input (read-output? #t))

  (define (handle-tick-process pout pin pid perr proc)
    (let ((result (and read-output? (with-input-from-port pout read-string))))
      (when input
        (write input pin))
      (close-output-port pin)
      (close-input-port pout)
      (receive (_ ok? status/signal)
          (process-wait proc)
        (unless ok?
          (error 'tick
                 (sprintf "Terminated abnormally with signal ~A"
                          status/signal)))
        (unless (zero? status/signal)
          (let ((err (read-string #f perr)))
            (close-input-port perr)
            (error 'tick
                   (sprintf "Failed with exit status ~A:~%~A"
                            status/signal
                            err)))))
      result))

  (cond-expand
   (chicken-5
    ;; see https://bugs.call-cc.org/ticket/766
    (define (process** cmd #!optional args env)
      (let*-values
          (((in-in   in-out) (create-pipe))
           ((out-in out-out) (create-pipe))
           ((err-in err-out) (create-pipe))
           ((pid) (process-fork
                   (lambda ()
                     (duplicate-fileno in-in fileno/stdin)
                     (duplicate-fileno out-out fileno/stdout)
                     (duplicate-fileno err-out fileno/stderr)
                     (file-close in-out)
                     (file-close in-in)
                     (file-close out-in)
                     (file-close out-out)
                     (file-close err-in)
                     (file-close err-out)
                     (process-execute cmd args env)))))
        (file-close in-in)
        (file-close out-out)
        (file-close err-out)
        (values (open-input-file*  out-in)
                (open-output-file* in-out)
                pid
                (open-input-file*  err-in))))

    (receive (pout pin pid perr)
        (process** tick-program args)
      (handle-tick-process pout pin pid perr pid)))
   (else
    (let ((proc (process tick-program args)))
      (handle-tick-process (process-output-port proc)
                           (process-input-port proc)
                           (process-id proc)
                           (process-error-port proc)
                           proc)))))

(define (init-server-repo)
  (create-directory server-git-repo-dir 'parents)
  (git `("-C" ,server-git-repo-dir "--bare" "init")))

(define (populate-server-repo)
  (let* ((tmp-dir (create-temporary-directory))
         (tmp-repo
          (make-pathname tmp-dir
                         (pathname-strip-directory server-git-repo-dir)))
         (write-properties
          (lambda (file properties)
            (with-output-to-file (make-pathname tmp-repo file)
              (lambda ()
                (pp properties)))
            (git `("-C" ,tmp-repo "add" ,file)))))

    (git `("-C" ,tmp-dir "clone" ,server-git-url))

    (write-properties "statuses"
                      '("accepted" "assigned" "closed" "new" "reopened"))
    (write-properties "components" '("build system" "compiler"))
    (write-properties "users" '("foo" "bar" "baz"))
    (write-properties "types" '("defect" "enhancement" "task"))
    (write-properties "priorities" '("critical" "major" "minor"))
    (write-properties "versions" '("4.13.0" "5.4.0" "6.0.0"))
    (write-properties "difficulties" '("easy" "hard" "insane"))
    (write-properties "resolutions" '("duplicate" "fixed" "invalid"))
    (write-properties "milestones" '("4.0.0" "5.0.0" "6.0.0"))
    (git `("-C" ,tmp-repo "commit" "-m" "Initialize properties"))

    ;; Write DB_VERSION file
    (let ((version-file
           (make-pathname tmp-repo
                          (pathname-strip-directory (db-version-file)))))
      (with-output-to-file version-file
        (lambda ()
          (write +required-db-version+)))
      (git `("-C" ,tmp-repo "add" ,version-file))
      (git `("-C" ,tmp-repo "commit" "-m" "Add DB_VERSION file"))
      (git `("-C" ,tmp-repo "push")))))

(define (get-last-modified-ticket)
  (let ((ticket-dirs
         (glob (make-pathname (list test-db-dir "tickets") "*"))))
    (pathname-strip-directory
     (car
      (sort ticket-dirs
            (lambda (d1 d2)
              (> (file-modification-time d1)
                 (file-modification-time d2))))))))

(define (with-another-username new-username thunk)
  (let ((backup (string-append +credentials-file+ ".bkp")))
    (if (file-exists? +credentials-file+)
        (let ((cur-creds (read-file +credentials-file+)))
          (rename-file +credentials-file+ backup 'clobber)
          (write-credentials new-username
                             (and cur-creds
                                  (alist-ref 'server-url cur-creds))))
        (write-credentials new-username #f))
    (let ((err #f))
      (handle-exceptions exn
        (set! err exn)
        (thunk))
      (rename-file backup +credentials-file+ 'clobber)
      (when err (signal err)))))

(define (delete-directory/missing-ok dir-path)
  (handle-exceptions exn
    (if (eq? (get-condition-property exn 'exn 'errno) errno/noent)
        #f
        (signal exn))
    (delete-directory dir-path 'recursive)))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

(if (get-environment-variable "TICK_TEST_REUSE_WORK_DIR")
    (printf "Not setting up ~a, as TICK_TEST_REUSE_WORK_DIR is set\n"
            work-dir)
    (begin
      (delete-directory/missing-ok server-git-repo-dir)
      (delete-directory/missing-ok test-db-dir)
      (init-server-repo)
      (populate-server-repo)
      (tick `("init" "--username" "foo" "--server-url" ,server-git-url))))

(load-relative (car (command-line-arguments)))