(module tick *

(import scheme)
(import (chicken base)
        (chicken condition)
        (chicken errno)
        (chicken file)
        (chicken fixnum)
        (chicken format)
        (chicken io)
        (chicken irregex)
        (chicken memory representation)
        (chicken pathname)
        (chicken port)
        (chicken pretty-print)
        (chicken process)
        (chicken process-context)
        (chicken sort)
        (chicken string)
        (chicken time)
        (chicken time posix))
(import simple-logger simple-sha1 srfi-1 srfi-13 xdg-basedir)
(import tick-params)

(define +required-db-version+ 0)

(define +default-server-url+ "https://tick.call-cc.org/tickets")

(define +ticket-filename+ "ticket.wiki")
(define +ticket-metadata-filename+ "metadata")

(define +conf-dir+
  (or (get-environment-variable "TICK_CONF_DIR")
      (make-pathname (xdg-config-home) "tick")))

(define +cache-dir+
  (or (get-environment-variable "TICK_CACHE_DIR")
      (make-pathname (xdg-cache-home) "tick")))

(define +conf-file+
  (make-pathname +conf-dir+ "conf.scm"))

(define +credentials-file+
  (make-pathname +conf-dir+ "credentials.conf"))

(define +last-used-ticket-hash-file+
  (make-pathname +cache-dir+ "last-used-ticket-hash"))

(unless (listing-format)
  (listing-format
   (lambda (ticket)
     (printf "~a [~a] ~a (~a)\n"
             (shorten-hash (ticket-id ticket))
             (ticket-status ticket)
             (ticket-summary ticket)
             (ticket-reporter ticket)))))

(define (tickets-dir)
  (make-pathname (db-dir) "tickets"))

(define (ticket-changes-dir thash)
  (let ((changes-dir (make-pathname (list (tickets-dir) thash) "changes")))
    (create-directory changes-dir 'parents)
    changes-dir))

(define (ticket-attachments-dir thash)
  (let ((attachments-dir
         (make-pathname (list (tickets-dir) thash) "attachments")))
    (create-directory attachments-dir 'parents)
    attachments-dir))

(define (ticket-change-filename changes-dir author count #!key (usecs (utc-useconds)))
  (let next ((count count))
    (let ((fname
           (time->string
            (seconds->utc-time (inexact->exact (truncate (/ usecs 1000000))))
            ;; Ignore the user part to handle changes made by
            ;; different users at the same second (unlikely to happen
            ;; in real cases, but happens in tests).
            (sprintf "%Y-%m-%d_%H-%M-%S_~a_*.wiki" count))))
      ;; If the change file already exists, it is because multiple
      ;; changes were made by multiple executions of tick within the
      ;; same second.
      (if (null? (glob (make-pathname changes-dir fname)))
          (string-translate* fname `(("*.wiki" . ,(string-append author ".wiki"))))
          (next (add1 count))))))

(define (shorten-hash hash #!optional (size 6))
  (substring hash 0 size))

(define (read-all file)
  (let ((text (with-input-from-file file read-string)))
    (if (eof-object? text)
        ""
        text)))

;; Adapted from chicken-doc (thanks zb)
(define (with-output-to-pager thunk)
  (cond ((or (get-environment-variable "EMACS")
             (equal? "dumb" (get-environment-variable "TERM")))
         (thunk))  ; Don't page in emacs subprocess.
        ((not (terminal-port? (current-output-port)))
         (thunk))  ; Don't page if stdout is not a TTY.
        (else
         (unless (get-environment-variable "LESS")
           (set-environment-variable! "LESS" "FRXis"))  ; Default 'less' options
         (let ((pager (or (get-environment-variable "TICK_PAGER")
                          (get-environment-variable "PAGER")
                          (pager))))
           (if (or (not pager) (string=? pager "cat"))
               (thunk)
               ;; with-output-to-pipe does not close pipe on
               ;; exception, borking tty
               (let ((pipe (open-output-pipe pager))
                     (rv #f))
                 (handle-exceptions exn
                   (begin (close-output-pipe pipe)
                          (signal exn))
                   ;; Can't reliably detect if pipe open fails.
                   (set! rv (with-output-to-port pipe thunk)))
                 (handle-exceptions exn
                   'ignore
                   (close-output-pipe pipe))
                 rv))))))

(define (prompt prompt-text #!key (options '()) allow-empty?)
  (unless (terminal-port? (current-input-port))
    (die! "input port is not a terminal"))
  (display (sprintf "~a~a: "
                    prompt-text
                    (if (null? options)
                        ""
                        (sprintf " [~a]"
                                 (string-intersperse (map ->string options)
                                                     ", ")))))
  (let ((answer (string-trim-both (read-line)))
        (rec-prompt
         (lambda ()
           (prompt prompt-text
                   options: options
                   allow-empty?: allow-empty?))))
    (if (string=? answer "")
        (if allow-empty?
            #f
            (rec-prompt))
        (if (or (null? options) (member answer options))
            answer
            (rec-prompt)))))

(define (prompt-editor field #!key (file #f))
  (display
   (sprintf
    (string-append
     "Your text editor will be opened for you to edit the ~a of the ticket.  "
     "Press ENTER to continue or C-c to abort.")
    field))
  (if (terminal-port? (current-input-port))
      (read-line)
      (newline))
  (let ((target-file (or file (create-temporary-file))))
    ((editor) target-file)
    (let ((answer (with-input-from-file target-file read-string)))
      ;; Delete target-file if it is a temporary one
      (unless file
        (delete-file* target-file))
      answer)))

(define (cleanup-environment!)
  (for-each unset-environment-variable!
            '("GIT_DIR"  ;; set by git to `.' when calling hook scripts
              "GIT_INDEX_FILE"
              "GIT_INDEX_VERSION"
              "GIT_OBJECT_DIRECTORY"
              "GIT_ALTERNATE_OBJECT_DIRECTORIES"
              "GIT_WORK_TREE"
              "GIT_NAMESPACE"
              "GIT_CEILING_DIRECTORIES"
              "GIT_COMMON_DIR"
              "GIT_DEFAULT_HASH"
              "GIT_DEFAULT_REF_FORMAT")))

(define (git args #!key (dir (db-dir)))
  (define (run-git)
    (let ((actual-args
           (if (member "-C" args)
               args
               (append (list "-C" (db-dir)) args))))
      (log-debug "Running: ~a ~a"
                 (git-program)
                 (string-intersperse actual-args))
      (process (git-program) actual-args)))

  (define (handle-git-proc pout pin pid proc)
    (let loop ()
      (let ((line (read-line pout)))
        (unless (eof-object? line)
          (log-debug line)
          (loop))))
    (let-values (((pid exit-normal? status) (process-wait proc)))
      (close-input-port pout)
      (close-output-port pin)
      (if (zero? status)
          0
          (error 'git "Error running" (git-program) args))))

  (cond-expand
   (chicken-5
    (receive (pout pin pid)
        (run-git)
      (handle-git-proc pout pin pid pid)))
   (else
    (let ((proc (run-git)))
      (handle-git-proc (process-output-port proc)
                       (process-input-port proc)
                       (process-id proc)
                       proc)))))

(define (server-url)
  (or (get-environment-variable "TICK_SERVER_URL")
      (handle-exceptions exn
        (die!
         (string-append
          "Could not determine the server URL.  Check your credentials file "
          "(~a) or run `tick init --force`.")
         +credentials-file+)
        (alist-ref 'server-url (read-file +credentials-file+)))))

(define (db-version-file)
  (make-pathname (db-dir) "DB_VERSION"))

(define (db-version)
  (with-input-from-file (db-version-file) read))

(define (db-check-compatibility)
  (let ((version (db-version)))
    (unless (= +required-db-version+ version)
      (die!
       (string-append
        "Incompatible DB version.  tick is compatible with DB version ~a, "
        "but the actual DB version is ~a")
       +required-db-version+
       version))))

(define (db-exists?)
  (directory-exists? (make-pathname (db-dir) ".git")))

(define (db-pull)
  (git `("pull" "origin" "master" "--rebase")))

(define (db-push)
  (git `("push" "origin" "master")))

(define (db-init)
  (create-directory (db-dir) 'parents)
  (git `("-C" ,(pathname-directory (db-dir)) "clone"
         ,(server-url) ,(pathname-strip-directory (db-dir)))))

(define (db-ticket-ids)
  (map pathname-file (directory (tickets-dir))))

(define (db-add-ticket ticket)
  (let ((thash (ticket-id ticket)))
    (git `("add" ,(ticket-dir thash)))
    (git `("commit" "-m" ,(sprintf "New ticket by ~a (~a): ~a"
                                   (get-username)
                                   thash
                                   (ticket-summary ticket))))))

(define (db-add-change thash #!optional description)
  (git `("add" ,(ticket-dir thash)))
  (let* ((commit-summary
          (list "-m"
                (sprintf "New change by ~a to ticket ~a"
                         (get-username)
                         thash)))
         (commit-msg (if description
                         (append commit-summary `("-m" ,description))
                         commit-summary)))
    (git `("commit" ,@commit-msg))))

(define (db-add-attachment thash attachment-abs-path)
  (git `("add" ,(ticket-dir thash)))
  (git `("commit" "-m" ,(sprintf "New attachment (~a) by ~a to ticket ~a"
                                 (pathname-strip-directory attachment-abs-path)
                                 (get-username)
                                 thash))))

(define (db-delete-attachment thash attachment-abs-path)
  (if (file-exists? attachment-abs-path)
      (begin
        (git `("rm" "-f" ,attachment-abs-path))
        (git `("add" ,(ticket-dir thash)))
        (git `("commit" "-m"
               ,(sprintf "Attachment (~a) of ticket ~a deleted by ~a"
                         (pathname-strip-directory attachment-abs-path)
                         thash
                         (get-username)))))
      (log-warning "~a is not attached to ticket ~a"
                   attachment-abs-path
                   thash)))

(define valid-global-data
  '(aliases
    components
    difficulties
    milestones
    priorities
    resolutions
    statuses
    types
    users
    versions))

(define (db-file file-type)
  (if (memq file-type valid-global-data)
      (make-pathname (db-dir) (symbol->string file-type))
      (error 'db-file "Invalid file type" file-type)))

(define (get-opt options parsed-args #!key multiple? flag? position)
  (cond (multiple?
         (filter-map (lambda (opt)
                       (and (memq (car opt) options)
                            (cdr opt)))
                     parsed-args))
        (flag?
         (let loop ((parsed-args parsed-args))
           (if (null? parsed-args)
               #f
               (let ((arg (car parsed-args)))
                 (if (and (pair? arg) (memq (car arg) options))
                     #t
                     (loop (cdr parsed-args)))))))
        (position
         (let ((positional (alist-ref '-- parsed-args)))
           (and (< position (length positional))
                (list-ref positional position))))
        (else
         (any (lambda (opt)
                (alist-ref opt parsed-args))
              options))))

(define %ticket-slots
  ;; If you add slots here, update the record definition and
  ;; make-ticket below
  '(cc
    %changes ;; Only set when importing tickets from Trac
    %attachments ;; Only set when importing tickets from Trac
    changetime
    component
    difficulty
    body
    id
    keywords
    milestone
    owner
    priority
    reporter
    resolution
    status
    summary
    time ;; in microseconds
    trac-id
    type
    version))

(define (ticket-slot-index slot-name)
  (list-index (lambda (elt) (eq? elt slot-name)) %ticket-slots))

(define-record ticket
  ;; If you add slots here, update %ticket-slots above and make-ticket
  ;; below
  cc
  %changes
  %attachments
  changetime
  component
  difficulty
  body
  id
  keywords
  milestone
  owner
  priority
  reporter
  resolution
  status
  summary
  time
  trac-id
  type
  version)

(define %make-ticket make-ticket)

(define (make-ticket #!key cc
                           %changes
                           %attachments
                           changetime
                           component
                           difficulty
                           body
                           id
                           keywords
                           milestone
                           owner
                           priority
                           reporter
                           resolution
                           status
                           summary
                           time
                           trac-id
                           type
                           version)
  (%make-ticket
   cc
   %changes
   %attachments
   changetime
   component
   difficulty
   body
   id
   keywords
   milestone
   owner
   priority
   reporter
   resolution
   status
   summary
   time
   trac-id
   type
   version))

(set-record-printer! ticket
  (lambda (obj out)
    (print "#<ticket")
    (for-each
     (lambda (slot)
       (printf "    ~a: ~S\n" slot (ticket-ref obj slot)))
     %ticket-slots)
    (display ">")))

(define (ticket-ref ticket slot-name)
  (record-instance-slot ticket (ticket-slot-index slot-name)))

(define (ticket-set! ticket slot-name value)
  (record-instance-slot-set! ticket (ticket-slot-index slot-name) value))

(define (ticket-dir thash)
  (make-pathname (tickets-dir) thash))

(define (ticket-file thash)
  (make-pathname (ticket-dir thash) +ticket-filename+))

(define (ticket-metadata-file thash)
  (make-pathname (ticket-dir thash) +ticket-metadata-filename+))

(define (ticket-exists? thash)
  (and thash
       (directory-exists? (make-pathname (tickets-dir) thash))))

(define (valid-ticket? tid)
  (let* ((maybe-number (if (number? tid)
                           tid
                           (string->number tid)))
         (trac-id (and maybe-number
                       ;; Trac didn't have so many tickets
                       (< maybe-number 10000)
                       maybe-number)))
    (if trac-id
        (let ((aliases (read-file (db-file 'aliases) read-list)))
          (alist-ref maybe-number aliases =))
        (if (string=? "-" tid)
            (get-last-used-ticket-hash)
            (let ((hashlen (string-length tid)))
              (cond ((fx> hashlen 40) #f)
                    ((fx= hashlen 40)
                     tid)
                    (else
                     (let ((thashes
                            (glob (make-pathname (tickets-dir)
                                                 (string-append tid "*")))))
                       (cond
                        ((null? thashes) #f)
                        ((null? (cdr thashes))
                         (pathname-strip-directory (car thashes)))
                        (else thashes))))))))))

(define (ensure-ticket tid)
  (unless tid
    (die! "A ticket id is required."))
  (let ((thash (valid-ticket? tid)))
    (cond ((not thash)
           (die! "Ticket ~a doesn't exist." tid))
          ((list? thash)
           (fprintf (current-error-port)
                    "Multiple tickets matching ~a:\n"
                    tid)
           (for-each
             (lambda (path)
               (fprintf (current-error-port)
                        "~a\n"
                        (pathname-strip-directory path)))
             thash)
           (exit 1))
          ((not (ticket-exists? thash))
            (die! "Ticket ~a doesn't exist." tid))
          (else thash))))

(define (read-ticket-body thash)
  (with-input-from-file (ticket-file thash)
    read-string))

(define (read-ticket thash #!key metadata-only?)
  (let* ((read-body? (not metadata-only?))
         (body (and read-body? (read-ticket-body thash)))
         (metadata (read-file (ticket-metadata-file thash))))
    (make-ticket cc: (alist-ref 'cc metadata)
                 changetime: (alist-ref 'changetime metadata)
                 component: (alist-ref 'component metadata)
                 difficulty: (alist-ref 'difficulty metadata)
                 body: (and read-body?
                            (if (eof-object? body)
                                #f
                                body))
                 id: thash
                 keywords: (alist-ref 'keywords metadata)
                 milestone: (alist-ref 'milestone metadata)
                 owner: (alist-ref 'owner metadata)
                 priority: (alist-ref 'priority metadata)
                 reporter: (alist-ref 'reporter metadata)
                 resolution: (alist-ref 'resolution metadata)
                 status: (alist-ref 'status metadata)
                 summary: (alist-ref 'summary metadata)
                 time: (alist-ref 'time metadata)
                 trac-id: (alist-ref 'trac-id metadata)
                 type: (alist-ref 'type metadata)
                 version: (alist-ref 'version metadata))))

(define (read-ticket-changes thash)
  (let* ((changes-dir (ticket-changes-dir thash))
         (change-files (sort (glob (make-pathname changes-dir "*.wiki"))
                             (lambda (f1 f2)
                               (string<? f1 f2)))))
    (if (null? change-files)
        ""
        (with-output-to-string
          (lambda ()
            (display "== Changes and comments")
            (for-each
             (lambda (change-file)
               (newline)
               (newline)
               (display (string-trim-right (read-all change-file))))
             change-files))))))

(define +required-properties+ '(reporter status summary type))

(define (make-missing-property-value-condition property)
  (make-composite-condition
   (make-property-condition 'tick)
   (make-property-condition 'missing-property-value 'property property)
   (make-property-condition
    'exn
    'location 'write-ticket
    'message (sprintf "Required property '~a' is empty" property))))

(define (assert-required-properties ticket)
  (for-each
   (lambda (prop)
     (when (and (memq prop +required-properties+)
                (not (ticket-ref ticket prop)))
       (signal (make-missing-property-value-condition prop))))
   %ticket-slots))

(define (write-ticket ticket)
  ;; changetime is always updated to utc-useconds.
  (assert-required-properties ticket)
  (let ((thash (or (ticket-id ticket)
                   ;; Only hash new tickets
                   (hash-ticket ticket))))
    (create-directory (ticket-dir thash) 'parents)
    (with-output-to-file (ticket-file thash)
      (lambda ()
        (print (string-trim-both (or (ticket-body ticket) "")))))
    (with-output-to-file (ticket-metadata-file thash)
      (lambda ()
        (pp `((summary    . ,(ticket-summary ticket))
              (cc         . ,(ticket-cc ticket))
              (changetime . ,(utc-useconds))
              (component  . ,(ticket-component ticket))
              (id         . ,(ticket-id ticket))
              (keywords   . ,(ticket-keywords ticket))
              (milestone  . ,(ticket-milestone ticket))
              (owner      . ,(ticket-owner ticket))
              (priority   . ,(ticket-priority ticket))
              (reporter   . ,(ticket-reporter ticket))
              (resolution . ,(ticket-resolution ticket))
              (status     . ,(ticket-status ticket))
              (time       . ,(ticket-time ticket))
              (type       . ,(ticket-type ticket))
              (version    . ,(ticket-version ticket))
              (difficulty . ,(ticket-difficulty ticket))
              (trac-id    . ,(ticket-trac-id ticket))
              ))))
    thash))

(define write-ticket-change
  ;; Count is used to prevent multiple changes by the same author
  ;; within the same second to clobber each other.
  (let ((count 0))
    (lambda (thash change)
      (let* ((changes-dir (ticket-changes-dir thash))
             (change-file
              (make-pathname
               changes-dir
               (ticket-change-filename changes-dir (get-username) count)))
             (ticket (read-ticket thash))
             (now (utc-useconds)))
        (with-output-to-file change-file
          (lambda ()
            (display
             (sprintf "=== [~a] ~a ~a"
                      (useconds->string now)
                      (get-username)
                      change))))
        (ticket-changetime-set! ticket now)
        (write-ticket ticket)
        (set! count (fx+ 1 count))
        change-file))))

(define (list-ticket-attachments ticket)
  (let ((attachments-dir
         (make-pathname (list (tickets-dir) (ticket-id ticket))
                        "attachments")))
    (if (directory-exists? attachments-dir)
        (glob (make-pathname attachments-dir "*"))
        '())))

(define (add-ticket-attachments thash attachments clobber?)
  (let ((attachments-dir (ticket-attachments-dir thash)))
    (for-each
     (lambda (attachment)
       (let* ((attachment-no-dir (pathname-strip-directory attachment))
              (dest (make-pathname attachments-dir attachment-no-dir)))
         (copy-file attachment dest clobber?)
         (write-ticket-change thash (sprintf "attached ~a" attachment-no-dir))
         (db-add-attachment thash dest)))
     attachments)))

(define (delete-ticket-attachments thash attachments)
  (let ((attachments-dir (ticket-attachments-dir thash)))
    (for-each
     (lambda (attachment)
       (let ((to-remove (if (absolute-pathname? attachment)
                            attachment
                            (make-pathname attachments-dir attachment))))
         (write-ticket-change thash
                              (sprintf "removed attachment ~a" attachment))
         (db-delete-attachment thash to-remove)))
     attachments)))

(define (empty? val)
  (member val '("" #f ())))

(define (maybe-show-empty val)
  (if (empty? val)
      ""
      val))

(define (change-time change) (truncate (/ (car change) 1000000))) ;; timestamps are in microseconds
(define change-author cadr)
(define change-field caddr)
(define change-old-value cadddr)
(define change-new-value (compose cadr cdddr))

(define (read-file file #!optional (reader read))
  ;; If file doesn't exist, return the empty list
  (condition-case
   (with-input-from-file file reader)
   ((exn file) #f)
   ((exn syntax) (die! "~a: syntax error" file))))

(define (valid-components)
  (or (read-file (make-pathname (db-dir) "components")) '()))

(define (valid-difficulties)
  (or (read-file (make-pathname (db-dir) "difficulties")) '()))

(define (valid-milestones)
  (or (read-file (make-pathname (db-dir) "milestones")) '()))

(define (valid-statuses)
  (or (read-file (make-pathname (db-dir) "statuses")) '()))

(define (valid-resolutions)
  (or (read-file (make-pathname (db-dir) "resolutions")) '()))

(define (valid-versions)
  (or (read-file (make-pathname (db-dir) "versions")) '()))

(define (valid-priorities)
  (or (read-file (make-pathname (db-dir) "priorities")) '()))

(define (valid-users)
  (or (read-file (make-pathname (db-dir) "users")) '()))

(define (valid-types)
  (or (read-file (make-pathname (db-dir) "types")) '()))

(define (validate-arg param valid-args-thunk #!key accept-empty?)
  ;; E.g., (validate-arg '--priority valid-priorities)
  (lambda (arg)
    (and (or (member arg (valid-args-thunk))
             (and accept-empty? (equal? arg ""))
             (die! "~a: Invalid argument: ~a" param arg))
         arg)))

(define (hash-ticket ticket)
  (string->sha1sum
   (sprintf "~a~a~a"
            (ticket-summary ticket)
            (ticket-reporter ticket)
            (ticket-time ticket))))

(define (utc-useconds)
  (* 1000000
     (string->number
      (time->string (seconds->utc-time (current-seconds)) "%s"))))

(define (useconds->string usecs)
  ;; If you modify the format of the string returned by this
  ;; procedure, don't forget to update
  ;; get-date/time-from-comment-heading too!
  (time->string
   (seconds->local-time (inexact->exact (truncate (/ usecs 1000000))))
   "%Y-%m-%d %H:%M:%S UTC"))

(define get-username
  (let ((u #f))
    (lambda ()
      (unless u
        (let ((credentials (read-file +credentials-file+)))
          (unless credentials
            (die! "Credentials file not found: ~a" +credentials-file+))
          (set! u (alist-ref 'username credentials))
          (unless u
            (die! "Could not determine username."))))
      u)))

(define (write-credentials username server-url)
  (create-directory +conf-dir+ 'parents)
  (with-output-to-file +credentials-file+
    (lambda ()
      (pp `((username   . ,username)
            (server-url . ,(or server-url
                               +default-server-url+)))))))

;;; Query support
(define (date-string? str)
  (and str
       (let ((year '(= 4 num))
             (month '(= 2 num))
             (day '(= 2 num)))
         (or (irregex-match year str)
             (irregex-match `(: ,year "-" ,month) str)
             (irregex-match `(: ,year "-" ,month "-" ,day) str)))))

(define (seconds->date usecs)
  (time->string (seconds->local-time (round (/ usecs 1000000))) "%Y-%m-%d"))

(define (date->seconds date)
  (local-time->seconds (string->time date "%Y-%m-%d")))

(define (date>= d1 d2)
  (>= (date->seconds d1) (date->seconds d2)))

(define (overloaded>= t1 t2)
  (cond
   ;; Numbers
   ((and (number? t1) (number? t2))
    (>= t1 t2))
   ;; Dates
   ((and (date-string? t1) (date-string? t2))
    (date>= t1 t2))
   ;; Strings
   ((and (string? t1) (string? t2))
    (string>=? t1 t2))
   (else
    (equal? t1 t2))))

(define (overloaded= t1 t2)
  (cond
   ;; Numbers
   ((and (number? t1) (number? t2))
    (= t1 t2))
   ;; Dates
   ((and (date-string? t1) (date-string? t2))
    (string=? t1 t2))
   ;; Strings
   ((and (string? t1) (string? t2))
    (string=? t1 t2))
   (else
    (equal? t1 t2))))

(define (~= t1 t2)
  (cond
   ;; Numbers
   ((and (number? t1) (number? t2))
    (= t1 t2))
   ;; Dates
   ((and (date-string? t1) (date-string? t2))
    (string-ci=? t1 t2))
   ;; Strings
   ((and (string? t1) (string? t2))
    (string-ci=? t1 t2))
   (else
    (equal? t1 t2))))

(define (overloaded> t1 t2)
  (and (not (overloaded= t1 t2))
       (overloaded>= t1 t2)))

(define (overloaded< t1 t2)
  (and (not (overloaded= t1 t2))
       (not (overloaded>= t1 t2))))

(define (overloaded<= t1 t2)
  (or (overloaded= t1 t2)
      (not (overloaded>= t1 t2))))

(define (~ regex obj)
  (irregex-search regex (->string obj)))

(define query-ops/vars
  `(
    ;; Operators
    (>  . ',overloaded>)
    (>  . ',overloaded>)
    (<  . ',overloaded<)
    (=  . ',overloaded=)
    (<> . ',(lambda (a b) (not (overloaded= a b))))
    (<= . ',overloaded<=)
    (>= . ',overloaded>=)
    (!= . ',(lambda (a b) (not (overloaded= a b))))
    (~  . ',~)
    (~= . ',~=)

    ;; Variables
    (id         . (,ticket-id ticket))
    (trac-id    . (,ticket-trac-id ticket))
    (type       . (,ticket-type ticket))
    (date       . (,seconds->date (,ticket-time ticket)))
    (changetime . (,ticket-changetime ticket))
    (component  . (,ticket-component ticket))
    (difficulty . (,ticket-difficulty ticket))
    (priority   . (,ticket-priority ticket))
    (owner      . (,ticket-owner ticket))
    (status     . (,ticket-status ticket))
    (reporter   . (,ticket-reporter ticket))
    (cc         . (,ticket-cc ticket))
    (version    . (,ticket-version ticket))
    (milestone  . (,ticket-milestone ticket))
    (resolution . (,ticket-resolution ticket))
    (summary    . (,ticket-summary ticket))
    (body       . (,ticket-body ticket))
    (keywords   . (,ticket-keywords ticket))
    ))


(define (determine-query-required-bindings expr)
  ;; Walk through expr determining which variables/operators are
  ;; required and return a list of bindings to be used in the let*
  ;; form in eval-query.
  (define (collect expr)
    (cond ((null? expr)
           '())
          ((pair? expr)
           (let ((head (car expr)))
             (if (pair? head)
                 (append-map collect expr)
                 (cond ((alist-ref head query-ops/vars)
                        => (lambda (val)
                             (cons (list head val)
                                   (collect (cdr expr)))))
                       (else (collect (cdr expr)))))))
          (else
            (or (and-let* ((val (alist-ref expr query-ops/vars)))
                  (list (list expr val)))
                '()))))
  (delete-duplicates (collect expr)
    (lambda (a b) (eq? (car a) (car b)))))

(define (eval-query expr bindings dry-run)
  (let ((to-eval
          `(lambda (ticket)
             (let* ((me ',(get-username))
                    ,@bindings)
               ,expr))))
    (log-debug "eval-query: to-eval: ~S" to-eval)
    (when dry-run
      (pp to-eval)
      (exit))
    (eval to-eval)))

(define (define-named-query name query #!key listing-format)
  (named-queries
   (cons (list name query listing-format) (named-queries))))

(define (define-named-listing name format-proc)
  ;; format-proc is a one-argument procedure that will be given a
  ;; ticket object.
  (named-listings
   (cons (cons name format-proc) (named-listings))))

;;; End query support

;;; Sorting
(define (define-named-sorter name sorter-proc)
  ;; sorter-proc is a one-argument procedure that will be given a list
  ;; of ticket objects to be sorted.
  (named-sorters
   (cons (cons name sorter-proc) (named-sorters))))

(define (sort-tickets-by-creation-time tickets)
  ;; Newer ones first
  (sort tickets
        (lambda (t1 t2)
          (> (ticket-time t1) (ticket-time t2)))))
;; End Sorting

(define (customize-listing-format format-string)
  (define (str x) (->string (or x "")))
  (listing-format
   (lambda (ticket)
     (print
      (string-translate*
       format-string
       `(("{hash}"       . ,(str (ticket-id ticket)))
         ("{short-hash}" . ,(str (shorten-hash (ticket-id ticket))))
         ("{trac-id}"    . ,(str (ticket-trac-id ticket)))
         ("{summary}"    . ,(str (ticket-summary ticket)))
         ("{changetime}" . ,(useconds->string (ticket-changetime ticket)))
         ("{datetime}"   . ,(useconds->string (ticket-time ticket)))
         ("{owner}"      . ,(str (ticket-owner ticket)))
         ("{reporter}"   . ,(str (ticket-reporter ticket)))
         ("{status}"     . ,(str (ticket-status ticket)))
         ("{version}"    . ,(str (ticket-version ticket)))
         ("{milestone}"  . ,(str (ticket-milestone ticket)))
         ("{priority}"   . ,(str (ticket-priority ticket)))
         ("{keywords}"   . ,(str (ticket-keywords ticket)))
         ("{cc}"         . ,(str (ticket-cc ticket)))
         ("{type}"       . ,(str (ticket-type ticket)))
         ("{resolution}" . ,(str (ticket-resolution ticket)))))))))

(define +format-option-help+
  "\
  --format|-f and --named-listing|-L are mutually exclusive.  If none
  of --format|-f or --named-listing|-L is provided, the default listing
  format will used.

  --named-listing|-L <named-listing>
    <named-listing> is a named listing defined in the `named-listings'
    parameter.

  --format|-f <listing-format>
    Used when listing tickets.  <listing-format> is a string where the
    following substitutions will be applied:
    * {hash}       => Ticket hash
    * {short-hash} => Ticket short hash
    * {trac-id}    => Ticket Trac id (for tickets imported from Trac)
    * {summary}    => Ticket summary
    * {changetime} => Ticket last modification time (%Y-%m-%d %H:%M:%S UTC)
    * {datetime}   => Ticket creation time (%Y-%m-%d %H:%M:%S UTC)
    * {owner}      => Ticket owner
    * {reporter}   => Ticket reporter
    * {status}     => Ticket status
    * {version}    => Ticket version
    * {milestone}  => Ticket milestone
    * {priority}   => Ticket priority
    * {keywords}   => Ticket keywords
    * {cc}         => Ticket cc
    * {type}       => Ticket type
    * {resolution} => Ticket resolution")

(define (render-ticket ticket)
  (print "== Summary")
  (print (ticket-summary ticket))
  (newline)
  (print "== Metadata")
  (print "* Id: " (ticket-id ticket))
  (print "* Trac id: " (or (ticket-trac-id ticket) ""))
  (print "* Type: " (or (ticket-type ticket) ""))
  (print "* Reporter: " (ticket-reporter ticket))
  (print "* Owner: " (or (ticket-owner ticket) ""))
  (print "* Cc: " (or (ticket-cc ticket) ""))
  (print "* Status: " (ticket-status ticket))
  (print "* Component: " (or (ticket-component ticket) ""))
  (print "* Estimated difficulty: " (or (ticket-difficulty ticket) ""))
  (print "* Resolution: " (or (ticket-resolution ticket) ""))
  (print "* Priority: " (or (ticket-priority ticket) ""))
  (print "* Milestone: " (or (ticket-milestone ticket) ""))
  (print "* Version: " (or (ticket-version ticket) ""))
  (print "* Changetime: " (useconds->string (ticket-changetime ticket)))
  (print "* Created: " (useconds->string (ticket-time ticket)))
  (print "* Keywords: " (or (ticket-keywords ticket) ""))
  (newline)
  (let ((attachments (list-ticket-attachments ticket)))
    (unless (null? attachments)
      (print "== Attachments")
      (for-each (lambda (attachment)
                  (print "* " attachment))
                attachments)
      (newline)))
  (print "== Description")
  (display (or (ticket-body ticket) ""))
  (let ((changes (read-ticket-changes (ticket-id ticket))))
    (unless (string=? changes "")
      (newline)
      (display changes)
      (newline))))

;;; Workflows

(define (make-workflow-condition cmd msg)
  (make-composite-condition
   (make-property-condition 'tick)
   (make-property-condition 'workflow)
   (make-property-condition 'exn 'location cmd 'message msg)))

(define (ensure-create-workflow status owner)
  (define (err msg)
    (signal (make-workflow-condition 'create msg)))
  (cond ((and (equal? status "assigned")
              (not owner))
         (err "Assigned tickets require an owner."))
        ((and owner (equal? status "new"))
         (err "New tickets do not have an owner (maybe you mean the assigned status?)."))
        ((and (equal? status "accepted") (not owner))
         (log-warning "Assigning the ticket to yourself, as no owner has been provided."))
        ((and (equal? status "accepted")
              owner
              (not (string=? owner (get-username))))
         (err (sprintf
               "You cannot accept a ticket on behalf of someone else (owner=~a)."
               owner)))
        ((member status '("reopened" "closed"))
         (err (sprintf "Creating a ~a ticket doesn't make sense." status)))))

(define (ensure-set-workflow ticket properties/vals)
  ;; `properties/vals' is an alist ((property . value) ...) representing
  ;; user inputs.  `ticket' is the unmodified ticket from the database.
  (let* ((err (lambda (msg) (signal (make-workflow-condition 'set msg))))
         (owner (alist-ref 'owner properties/vals))
         (cur-ticket-owner (ticket-owner ticket))
         (status (alist-ref 'status properties/vals))
         (validate-change
          (lambda (property new-val)
            (let ((cur-val (ticket-ref ticket property)))
              (when (and new-val (equal? new-val cur-val))
                (log-warning "~a: its value already is ~a"
                             property new-val))))))
    (cond
     ((and (equal? status "assigned")
           (not cur-ticket-owner)
           (or (not owner)
               ;; Attempt to remove owner while assigning
               (equal? owner "")))
      (err "Assigned tickets require an owner."))
     ((and (equal? status "accepted")
           (or (and owner
                    cur-ticket-owner
                    (not (string=? owner cur-ticket-owner)))
               (and (or (not owner)
                        (string=? owner ""))
                    cur-ticket-owner
                    (not (equal? (get-username) cur-ticket-owner)))))
      (err (sprintf
            "You cannot accept a ticket on behalf of someone else (current owner=~a)."
            cur-ticket-owner)))
     ((and (equal? status "new") owner (not (string=? owner "")))
      (err (string-append
            "New tickets cannot have an owner (set status to assigned or "
            "accepted instead).")))
     ((and (equal? status "reopened")
           (not (equal? (ticket-status ticket) "closed")))
      (err "Cannot reopen a ticket which is not closed.")))

    (for-each (lambda (property/val)
                (let ((property (car property/val))
                      (val (cdr property/val)))
                  (validate-change property val)))
              properties/vals)))

(define (enforce-workflow thunk)
  ;; Helper to handle workflow validation conditions.  This procedure
  ;; will actually make the program exit in case of validation errors.
  ;; `thunk' is supposed to wrap ensure-{create,set}-workflow.
  (condition-case (thunk)
    (exn (tick workflow)
         (die! (get-condition-property exn 'exn 'message)))
    (exn () (print-error-message exn))))

;;; Last used ticket hash
(define (get-last-used-ticket-hash)
  (handle-exceptions exn
    (if (eq? (get-condition-property exn 'exn 'errno) errno/noent)
        #f
        (signal exn))
    (let ((thash
           (with-input-from-file +last-used-ticket-hash-file+ read-line)))
      (and (not (eof-object? thash))
           thash))))

(define (set-last-used-ticket-hash! thash)
  ;; Nevermind problems caused by concurrent writes.
  (with-output-to-file +last-used-ticket-hash-file+
    (cut print thash)))

;;; Misc

(define (get-date/time-from-comment-heading heading)
  ;; "=== [YYYY-MM-DD hh:mm:ss UTC] <user> <action> ..." => "YYYY-MM-DD hh:mm:ss"
  ;;      ^                   ^
  ;;      5                   24
  (substring heading 5 24))

) ;; end module