(use setup-api posix ssax sxpath sxpath-lolevel files utils)

(define (usage code)
  (print #<#EOF
usage: svn-eggtag [-n] RELEASE

  -h   -help                    Show this message
  -n   -no-update               No meta-file update

svn-eggtag will tag an egg for release with the name RELEASE and add a
corresponding entry to the .release-info file.  It will also update
the .meta-file's FILES section to contain all the files, unless -n is
passed.

EOF
)
(exit code))

(define (call-with-input-pipe* cmd proc)
  (let* ([p (open-input-pipe cmd)]
         [res (proc p)])
    (unless (zero? (close-input-pipe p))
      (error "Got an error while executing command " cmd))
    res))

(define (svn-xml cmd)
  (call-with-input-pipe* cmd (lambda (i) (ssax:xml->sxml i '()))))

(define (find-root-url)
  (let ((info (svn-xml "svn info --xml")))
    (let lp ((url ((if-car-sxpath '(info entry url *text*)) info)))
      (cond
       ((or (not url) (string=? url ""))
        (fprintf (current-error-port)
                 "Could not figure out root URL; Please run from the 'trunk' of your egg")
        (exit 1))
       ((and (string? (pathname-file url))
             (string=? (pathname-file url) "trunk"))
        (pathname-directory url))
       (else (lp (pathname-directory url)))))))

(define (ensure-clean-wc!)
  (let ((status (svn-xml "svn status --xml"))) ; -q doesn't work with --xml :(
    (when ((if-car-sxpath `(status target entry wc-status
                                   ;; There has to be a better way :(
                                   ,(lambda (x y)
                                      ((sxml:filter
                                        (lambda (x)
                                          (let ((s ((sxpath '(@ item)) x)))
                                            (not (string=? (sxml:text s)
                                                           "unversioned"))))) x))))
           status)
      (fprintf (current-error-port)
               (conc "Working copy is not clean. Please commit all outstanding "
                     "changes before tagging a release!~%"))
      (exit 1))))

(define (update-meta!)
  (system* "~A/bin/svn-update-meta" chicken-prefix))

(define (update-release-info! release-version)
  (let* ((release-infos (glob "*.release-info")))
    (cond ((null? release-infos)
           (fprintf (current-error-port)
                    "Error: No release-info file found! Please create one first~%")
           (exit 1))
          ((> (length release-infos) 1)
           (fprintf (current-error-port)
                    "Error: ~A release-info files found. Can only deal with one!~%"
                    (length release-infos))
           (exit 1))
          (else
           ;; First check if this release already exists
           (let lp ((contents (with-input-from-file (car release-infos) read-file)))
             (cond ((null? contents) #f)
                   ((and (eq? (caar contents) 'release)
                         (string=? (cadar contents) release-version))
                    (fprintf (current-error-port)
                             "Release ~A already exists in release-info file!~%"
                             release-version)
                    (exit 1))
                   (else (lp (cdr contents)))))
           (with-output-to-file (car release-infos)
             (lambda () (write `(release ,release-version)) (newline))
             #:append)))))

(define (copy-to-tags! egg-name root-url release-version)
  (let ((trunkdir (sprintf "~A/trunk" root-url))
        (tagdir   (sprintf "~A/tags/~A" root-url release-version)))
   (printf "Copying ~A\nto      ~A\n" trunkdir tagdir)
   (system* "svn copy --parents -m ~A ~A ~A"
            (qs (sprintf "~A: Tag release ~A" egg-name release-version))
            (qs trunkdir)
            (qs tagdir))))

(define (check-tag-does-not-exist! root-url release-version)
  (when (and ((if-car-sxpath `(// name (equal? "tags")))
              (svn-xml (sprintf "svn ls --xml ~A" (qs root-url))))
             ((if-car-sxpath `(// name (equal? ,release-version)))
              (svn-xml (sprintf "svn ls --xml ~A/tags" (qs root-url)))))
    (fprintf (current-error-port)
             "There's already a tag that matches your release version ~S!~%"
             release-version)
    (exit 1)))

(define (commit-all! egg-name release-version)
  (system* "svn commit -m ~A ~A ~A"
           (qs (sprintf "~A: Add release ~A" egg-name release-version))
           (qs (car (glob "*.release-info")))
           (if *update-meta-file* (qs (car (glob "*.meta"))) "")))

(define (update-to-latest!)
  (system* "svn update"))

(define (tag-egg release-version)
  (let* ((root-url (find-root-url))
         (egg-name (or (pathname-file root-url)
                       (pathname-file (pathname-directory root-url)))))
    (ensure-clean-wc!)
    (check-tag-does-not-exist! root-url release-version)
    (update-release-info! release-version)
    (when *update-meta-file* (update-meta!))
    (commit-all! egg-name release-version)
    (copy-to-tags! egg-name root-url release-version)
    (update-to-latest!)))

(define *update-meta-file* #t)

(define *short-options* '(#\h #\n))

(define (main args)
  (let loop ((args args))
    (if (null? args)
        (usage 1)
        (let ((arg (car args)))
          (cond ((or (string=? arg "-help")
                     (string=? arg "-h")
                     (string=? arg "--help"))
                 (usage 0))
                ((or (string=? arg "-n") (string=? arg "-no-update"))
                 (set! *update-meta-file* #f)
                 (loop (cdr args)))
                ((and (positive? (string-length arg))
                      (char=? #\- (string-ref arg 0)))
                 (if (> (string-length arg) 2)
                     (let ((sos (string->list (substring arg 1))))
                       (if (null? (lset-intersection eq? *short-options* sos))
                           (loop (append (map (cut string #\- <>) sos) (cdr args)))
                           (usage 1)))
                     (usage 1)))
                ((= (length args) 1) (tag-egg (car args)))
                (else (usage 1)))))))

(main (command-line-arguments))