(declare (unit tick-set))

(module tick-set ()

(import scheme)
(import (chicken base)
        (chicken format)
        (chicken string))
(import commands optimism simple-logger srfi-1)
(import tick)

(define-command 'set #<#EOF
set <ticket-id> [<properties>]
  Set properties of tickets.  Use an empty string to unset a value.

  <properties>:
    --summary|-S <summary>
      Ticket summary.

    --type|-t <type>
      Valid types: #{(string-intersperse (valid-types) ", ")}

    --component|-c <component>
      Valid components: #{(string-intersperse (valid-components) ", ")}

    --difficulty|-d <difficulty>
      Valid difficulties: #{(string-intersperse (valid-difficulties) ", ")}

    --priority|-p <priority>
      Valid priorities: #{(string-intersperse (valid-priorities) ", ")}

    --owner|-o <owner>
      Check the output of "tick list users" for the list of owners.

    --version|-v <version>
      Check the output of "tick list versions" for the list of versions.

    --milestone|-m <milestone>
      Check the output of "tick list milestones" for the list of versions.

    --status|-s <status>
      Valid statuses: #{(string-intersperse (valid-statuses) ", ")}

    --resolution|-r <resolution>
      Valid resolutions: #{(string-intersperse (valid-resolutions) ", ")}

    --cc|-C <cc>
      Users/emails to add as Cc for the ticket.

    --keywords|-k <keywords>
      Arbitrary keywords for the ticket.
EOF
  ;; --this-is-here-just-to-fool-emacs-syntax-highlight|
    (lambda (args*)
      (let* ((args (parse-command-line
                  args*
                  `(((--summary -S) . summary)
                    ((--type -t) .
                     ,(validate-arg '--type valid-types accept-empty?: #t))
                    ((--component -c) .
                     ,(validate-arg '--component valid-components accept-empty?: #t))
                    ((--difficulty -d) .
                     ,(validate-arg '--difficulty valid-difficulties accept-empty?: #t))
                    ((--priority -p) .
                     ,(validate-arg '--priority valid-priorities accept-empty?: #t))
                    ((--owner -o) .
                     ,(validate-arg '--owner valid-users accept-empty?: #t))
                    ((--version -v) .
                     ,(validate-arg '--version valid-versions accept-empty?: #t))
                    ((--milestone -m) .
                     ,(validate-arg '--milestone valid-milestones accept-empty?: #t))
                    ((--status -s) . ,(validate-arg '--status valid-statuses))
                    ((--keywords -k) . keywords)
                    ((--cc -C) . cc)
                    ((--resolution -r) .
                     ,(validate-arg '--resolution valid-resolutions accept-empty?: #t))
                    ((--) . tid))))
             (properties/vals
              `((summary    . ,(get-opt '(--summary -S) args))
                (type       . ,(get-opt '(--type -t) args))
                (component  . ,(get-opt '(--component -c) args))
                (difficulty . ,(get-opt '(--difficulty -d) args))
                (priority   . ,(get-opt '(--priority -p) args))
                (owner      . ,(get-opt '(--owner -o) args))
                (version    . ,(get-opt '(--version -v) args))
                (milestone  . ,(get-opt '(--milestone -m) args))
                (status     . ,(get-opt '(--status -s) args))
                (cc         . ,(get-opt '(--cc -C) args))
                (keywords   . ,(get-opt '(--keywords -k) args))
                (resolution . ,(get-opt '(--resolution -r) args))))
             (thash (let ((rest (get-opt '(--) args)))
                      (if (or (null? rest) (not (null? (cdr rest))))
                          (show-command-help 'set 1)
                          (ensure-ticket (car rest)))))
             (ticket (read-ticket thash))
             (remove-prop-change!
              (lambda (prop)
                (set! properties/vals (alist-delete prop properties/vals)))))

        (set-last-used-ticket-hash! thash)

        (enforce-workflow
         (lambda ()
           (ensure-set-workflow ticket properties/vals)))

        (define (commit-change property new-val)
          (when new-val
            (let* ((old-val (ticket-ref ticket property))
                   (descr
                    (cond ((and (string=? new-val "") (not old-val))
                           (log-warning "The value of ~a is already unset." property)
                           #f)
                          ((not old-val)
                           (sprintf "set ~a to ''~a''"
                                    property
                                    new-val))
                          ((string=? new-val "")
                           (sprintf "set ~a empty" property))
                          (else
                           (sprintf "changed ~a from ''~a'' to ''~a''"
                                    property
                                    old-val
                                    new-val)))))
              (ticket-set! ticket property (if (string=? new-val "")
                                               #f
                                               new-val))
              (when descr
                (write-ticket ticket)
                (write-ticket-change thash descr)
                (db-add-change thash descr)))))

        ;; Handle property changes that imply other changes (logging
        ;; of changes must be done in the proper order).  In these
        ;; cases, properties/vals will be mutated to avoid duplicate
        ;; change entries.
        (let ((new-owner (alist-ref 'owner properties/vals))
              (new-status (alist-ref 'status properties/vals)))
          (cond
           ;; A change of owner of an accepted ticket, without an
           ;; explicit request to change the ticket status, must
           ;; change the status of a ticket to assigned if the new
           ;; owner is not the current user.
           ((and new-owner
                 (not (string=? new-owner ""))
                 (not new-status)
                 (equal? (ticket-status ticket) "accepted"))
            (commit-change 'owner new-owner)
            (remove-prop-change! 'owner)
            ;; Only change the status to assigned if the new owner is
            ;; not the current user.
            (unless (string=? new-owner (get-username))
              (remove-prop-change! 'status)
              (commit-change 'status "assigned")))

           ;; Allow users to accept tickets without an owner,
           ;; implicitly setting themselves as owner.
           ((and (equal? new-status "accepted")
                 (not new-owner)
                 (not (ticket-owner ticket)))
            (let ((user (get-username)))
              (set! properties/vals
                    (alist-update! 'owner user properties/vals))))

           ;; Automatically remove owner when setting tickets back to
           ;; new.
           ((and (equal? new-status "new") (ticket-owner ticket))
            (set! properties/vals
                  (alist-update! 'owner "" properties/vals)))

           ;; Automatically update the ticket status to "new" if its
           ;; current status is not being change, and is assigned or
           ;; accepted, and its owner gets unset.
           ((and (equal? new-owner "")
                 (not new-status)
                 (member (ticket-status ticket) '("assigned" "accepted")))
            (log-warning
             "Setting ticket status to new as its owner is being removed.")
            (set! properties/vals
                  (alist-update! 'owner "" properties/vals))
            (set! properties/vals
                  (alist-update! 'status "new" properties/vals)))
           ) ;; end cond

          ;; Proceed to log the other changes
          (for-each (lambda (property/val)
                      (let ((property (car property/val))
                            (val (cdr property/val)))
                        (commit-change property val)))
                    properties/vals)))))

) ;; end module