release.lisp 8.88 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33
(in-package :asdf-tools)

;;; Getting a list of source files in a system

(defun enough-namestring! (base pathname)
  (let ((e (enough-namestring base pathname)))
    (assert (relative-pathname-p e))
    e))

(defun enough-namestrings (base pathnames)
  (loop :with b = (ensure-pathname base :want-absolute t :want-directory t)
        :for p :in pathnames
        :collect (enough-namestring! p b)))

(defun system-source-files (system &key monolithic)
  (let* ((sys (find-system system))
         (components
           (required-components system
                                :other-systems monolithic
                                :goal-operation 'load-op
                                :keep-operation 'load-op
                                :keep-component 'file-component))
         (dir (ensure-pathname
               (system-source-directory sys)
               :want-absolute t :want-directory t))
         (pathnames (mapcar 'component-pathname components)))
    (enough-namestrings dir pathnames)))


;;; Making release tarballs for asdf, asdf/defsystem, uiop.

(defun tarname (name) (strcat name ".tar.gz"))

34 35 36 37 38 39 40 41 42 43 44 45 46
(defun make-tarball-under-build (name base files)
  (check-type name string)
  (ensure-pathname base :want-absolute t :want-existing t :want-directory t)
  (dolist (f files)
    (check-type f string))
  (let* ((base
           (ensure-pathname
            base
            :want-absolute t :want-directory t
            :want-existing t :truename t))
         (destination
           (ensure-pathname
            name
47
            :defaults (build-dir)
48 49 50 51 52
            :want-relative t :ensure-absolute t
            :ensure-subpath t :ensure-directory t))
         (tarball
           (ensure-pathname
            (tarname name)
53
            :defaults (build-dir)
54 55 56 57 58 59 60 61
            :want-relative t :ensure-absolute t
            :ensure-subpath t :want-file t
            :ensure-directories-exist t)))
    (assert (< 6 (length (pathname-directory destination))))
    (when (probe-file* destination)
      (error "Destination ~S already exists, not taking chances - you can delete it yourself."
             destination))
    (ensure-directories-exist destination)
62
    (run* `(cp "-pHux" --parents ,@files ,destination) :directory base :show t)
63
    (run* `(tar "zcf" ,tarball "-C" ,(build-dir)
64 65 66 67
                ;; TODO: Have better autodetection for which tar is being used,
                ;; and fall back to no option if not recognized.
                ;; #+linux (* :owner root :group root) ;; assume GNU tar on Linux.
                ;; #+darwin (* :uid 0 :gid 0) ;; assume BSD tar on Darwin.
68 69
               (,name /)) :show t)
    (delete-directory-tree destination :validate #'(lambda (x) (equal x destination)))
70
    (success)))
71

72
(defun uiop-files ()
73
  "list files in uiop"
74 75
  (list* "README.md" "uiop.asd" "asdf-driver.asd" (system-source-files "uiop")))
(defun uiop-name ()
76
  (format nil "uiop-~A" (version-from-file)))
77
(deftestcmd make-uiop-tarball ()
78
  (make-tarball-under-build (uiop-name) (uiop-dir) (uiop-files)))
79 80

(defun asdf-defsystem-files ()
81
  "list files in asdf/defsystem"
82 83 84
  (list* "build/asdf.lisp" ;; for bootstrap purposes
         "asdf.asd" "version.lisp-expr" "header.lisp"
         (system-source-files "asdf/defsystem")))
85
(defun asdf-defsystem-name ()
86
  (format nil "asdf-defsystem-~A" (version-from-file)))
87 88
(deftestcmd make-asdf-defsystem-tarball ()
  (build-asdf)
89
  (make-tarball-under-build (asdf-defsystem-name) (asdf-dir) (asdf-defsystem-files)))
90

91
(defun asdf-all-name ()
92
  (strcat "asdf-" (version-from-file)))
93 94 95 96 97
(defun asdf-all-files ()
  (remove-if #'(lambda (x) (string-prefix-p "ext/" x))
             (with-asdf-dir () (run/lines '(git ls-files)))))
(deftestcmd make-asdf-all-tarball ()
  (build-asdf)
98
  (make-tarball-under-build (asdf-all-name) (asdf-dir) (asdf-all-files)))
99 100

(defun asdf-lisp-name ()
101
  (format nil "asdf-~A.lisp" (version-from-file)))
102
(deftestcmd make-asdf-lisp ()
103 104
  (build-asdf)
  (concatenate-files (list (pn "build/asdf.lisp"))
105
                     (pn "build/" (asdf-lisp-name))))
106

107
(deftestcmd make-archive ()
108
  "build tarballs for release"
109
  (make-uiop-tarball)
110
  (make-asdf-defsystem-tarball)
111
  (make-asdf-all-tarball)
112
  (make-asdf-lisp))
113 114 115 116 117 118 119 120


;;; Publishing tarballs onto the public repository

(defvar *clnet* "common-lisp.net")
(defvar *clnet-asdf-public* "/project/asdf/public_html/")
(defun public-path (x) (strcat *clnet-asdf-public* x))

121
(deftestcmd publish-archive ()
122
  "publish tarballs to the website"
123
  (let ((tarballs (mapcar 'tarname (list (uiop-name) (asdf-defsystem-name) (asdf-all-name)))))
124 125 126
    (run* `(rsync "--times" "--chmod=a+rX,ug+w"
                  ,@tarballs ,(asdf-lisp-name) (,*clnet* ":" ,(public-path "archives/")))
          :show t :directory (pn "build/")))
127 128
  (format t "~&To download the tarballs, point your browser at:~%
        http://common-lisp.net/project/asdf/archives/
129
~%"))
130

131
(deftestcmd link-archive ()
132
  "symlink new tarballs on the website"
133
  (run* (format nil "ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S ; ln -sf ~S ~S"
134
                (tarname (uiop-name))
135 136 137
                (public-path "archives/uiop.tar.gz")
                (tarname (asdf-defsystem-name))
                (public-path "archives/asdf-defsystem.tar.gz")
138
                (tarname (asdf-all-name))
139 140 141 142 143 144
                (public-path "archives/asdf.tar.gz")
                (asdf-lisp-name)
                (public-path "archives/asdf.lisp"))
        :show t :host *clnet*))

(deftestcmd make-and-publish-archive ()
145
  "make and publish tarballs"
146 147 148 149
  (make-archive)
  (publish-archive)
  (link-archive))

150 151
(defalias archive make-and-publish-archive)
(defalias install make-and-publish-archive)
152

153 154 155
(defun get-debian-packager-keyid ()
  (or (getenv "DEBSIGN_KEYID")
      (error "Please export variable DEBSIGN_KEYID to be the 8-hex hash of your GnuPG secret key")))
156 157

;;; Making a debian package
158
(deftestcmd debian-package ((release "release"))
159
  "build a debian package"
160
  (let* ((debian-version (debian-version-from-file release))
161 162 163 164
         (version (version-from-file release))
         (has-ext-p (probe-file* (pn "ext/inferior-shell/inferior-shell.asd")))
         (branch (get-git-branch))
         (keyid (get-debian-packager-keyid)))
165
    (unless (equal version (parse-debian-version debian-version))
166
      (error "Debian version ~A doesn't match asdf version ~A" debian-version version))
167
    (git-all-committed-p)
168
    (clean)
169 170
    (ext-clear)
    (git '(checkout release))
171
    (format t "building package version ~A~%" (debian-version-from-file))
172 173
    (run* `(git-buildpackage
            ;; --git-ignore-new ;; for testing purpose
174 175
            ;; Override of the signing key, don't extract the name from the Changelog:
            (--git-builder="debuild -k0x",keyid" -i -I")
176 177 178 179 180 181 182 183
            (--git-debian-branch= ,release)
            (--git-upstream-tag="%(version)s")
            ;;--git-upstream-tree=tag ;; if the changelog says 3.1.2, looks at that tag
            ;;(--git-upstream-branch= ,version) ;; if the changelog says 3.1.2, looks at that tag
            --git-tag --git-retag
            ;; --git-no-pristine-tar
            --git-force-create
            --git-ignore-branch)
184 185 186 187
          :directory (pn) :show t)
    (git `(checkout ,branch))
    (when has-ext-p (ext-reset))
    (success)))
188

189 190 191
(defun debian-architecture ()
  (run/ss `(dpkg --print-architecture)))

192
(deftestcmd publish-debian-package (release)
193
  "publish a debian package"
194
  (let ((changes (strcat "cl-asdf_" (debian-version-without-epoch (debian-version-from-file release))
195 196
                         "_" (debian-architecture) ".changes")))
    (run* `(dput mentors ,(pn "../" changes)))))
197

198
(deftestcmd release (new-version lisps scripts systems)
199
  "all steps to release the code (NOT YET IMPLEMENTED)"
200 201 202 203 204 205 206 207 208
  (break) ;; for each function, offer to do it or not (?)
  (with-asdf-dir ()
    (let ((log (newlogfile "release" "all"))
          (releasep (= (length (parse-version new-version)) 3)))
      (when releasep
        (let ((debian-version (debian-version-from-file)))
          (unless (equal new-version (parse-debian-version debian-version))
            (error "You're trying to release version ~A but the debian/changelog wasn't properly updated"
                   new-version)))
209
        (when (nth-value 1 (run '(dpkg-parsechangelog) :output nil :error-output :lines))
210
          (error "Malformed debian/changelog entry")))
211
      scripts ;; TODO: needs to be passed as argument!
212 213 214 215 216 217 218 219 220 221 222 223 224 225 226 227 228
      (git-all-committed-p)
      (test-all-no-stop) ;; TODO: NEED ARGUMENTS!
      (test-load-systems lisps systems)
      (bump new-version)
      (when releasep
        (and
         (debian-package)
         (publish-debian-package)
         (merge-master-into-release)))
      ;; SUCCESS! now publish more widely
      (%push)
      (archive)
      (website)
      (when releasep
        (log! log t "Don't forget to send a debian mentors request!"))
      (log! log "Don't forget to send announcement to asdf-announce, asdf-devel, etc.")
      (log! log "Don't forget to move all fixed bugs from Fix Committed -> Fix Released on launchpad"))))