source: trunk/source/cocoa-ide/ide-self-update.lisp @ 9636

Last change on this file since 9636 was 9636, checked in by mikel, 11 years ago

added dialog box to control self-update process

File size: 8.1 KB
Line 
1;;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10; Package: cl-user -*-
2;;;; ***********************************************************************
3;;;; FILE IDENTIFICATION
4;;;;
5;;;; Name:          svn-self.lisp
6;;;; Version:       0.1
7;;;; Project:       Cocoa IDE
8;;;; Purpose:       Cocoa UI for updating the Cocoa IDE from the source repo
9;;;;
10;;;; ***********************************************************************
11
12(in-package :ccl)
13
14;;; IDE: decide how and whether to handle cvs self-updates.
15;;; see the cvs/svn code in update-ccl in compile-ccl.lisp
16
17;;; use GUI::FIND-CCL-DIRECTORY to find the effective CCL directory
18;;; (it gracefully handles the case where we are running from an
19;;; app bundle, as well as the case where we are not)
20
21;;; How to self-update the IDE from the svn or cvs repo
22;;; 1. Find the ccl directory that corresponds to the running image
23;;; 2. determine whether this is an svn or cvs checkout
24;;; 3. SVN:
25;;;   a. find the .svn directory
26;;;   b. run svn info to get the svn URL
27;;;   c. determine from the URL whether we need to authenticate
28;;;   d. get auth tokens if we need them
29;;;   d. record the svn revision before we start (so we can roll back
30;;;      if things go horribly wrong)
31;;;   e. run svn status to check for potential merge conflicts before starting
32;;;      the update
33;;;   f. construct the svn command:
34;;;       i. cd to the proper CCL directory
35;;;      ii. run svn update
36;;;   g. run the svn command with external-process-status.
37;;;   h.  check the status of the external command for success or failure:
38;;;      i. if okay, queue a full-rebuild, and a rebuild of the IDE
39;;;         (need to make some infrastructure for queuing these activities
40;;;         and running them on next launch, or immediately in an external process)
41;;;     ii. if not okay, warn the user, and offer to roll back to the
42;;;         previously-recorded version (need to make some infrastructure for
43;;;         running a rollback)
44;;; TODO: make a cvs version if needed
45
46;;; -----------------------------------------------------------------
47;;; svn metadata utils
48;;; -----------------------------------------------------------------
49
50;;; VALIDATE-SVN-DATA-PATHNAME p
51;;; ---------------------
52;;; returns TRUE if P is really an existing directory that appears to
53;;; contain valid Subversion metadata; FALSE otherwise
54
55(defun validate-svn-data-pathname (p)
56  (and (probe-file p)
57       (directoryp p)
58       (string= ".svn" (first (last (pathname-directory p))))
59       ;; if we reached this point, it's an existing directory
60       ;; named ".svn". now, does it have Subversion metadata files
61       ;; in it?
62       (let ((subversion-metafiles '("dir-prop-base" "entries" "format"
63                                     "prop-base/" "props/" "text-base/")))
64         (every (lambda (f) (probe-file (merge-pathnames f p))) 
65                subversion-metafiles))))
66
67;;; given a valid-looking .svn directory, we should be able to use
68;;; the svn executable to get the repository URL. we call:
69;;;  svn info
70;;; and get a big block of info text. one line of the output
71;;; is of the form:
72;;;  URL: yatta-yatta
73;;; where yatta-yatta is the repository URL of the checked out directory
74;;; Another piece of information we want shows Up here, too: the
75;;; current revision, on a line of the form:
76;;; Revision: foobar
77
78(defun split-svn-info-line (line)
79  (let* ((split-sequence ": ")
80         (split-index (find-matching-subsequence split-sequence line :test #'char=))
81         (prefix (subseq line 0 split-index))
82         (suffix (subseq line (if split-index
83                                  (+ split-index (length split-sequence))
84                                  (length line)))))
85    (list prefix suffix)))
86
87(defun parse-svn-info (info-string)
88  (let ((info-lines (split-lines info-string)))
89    (mapcar #'split-svn-info-line info-lines)))
90
91(defun get-svn-info (p)
92  (parse-svn-info
93   (with-output-to-string (out)
94     (run-program "svn" `("info" ,(namestring p)) :output out))))
95
96;;; -----------------------------------------------------------------
97;;; authentication utils, for use with source control
98;;; -----------------------------------------------------------------
99
100;;; we infer from the information in the URL field of the svn info
101;;; whether we need to authenticate. The assumed criteria in this
102;;; implementation are that we don't need to authenticate if the
103;;; URL is an http:: URL; if it's an svn+ssh URL, then we do need
104;;; to authenticate
105
106(defparameter *authentication-window-controller* nil)
107
108(defclass authentication-window-controller (ns:ns-window-controller)
109    ((authentication-window :foreign-type :id :reader authentication-window)
110     (username-field :foreign-type :id :reader authentication-window-username-field)
111     (password-field :foreign-type :id :reader authentication-window-password-field))
112  (:metaclass ns:+ns-object))
113
114(objc:defmethod #/windowNibName ((self authentication-window-controller))
115  #@"Authenticate")
116
117(objc:defmethod (#/authOkay: :void) ((self authentication-window-controller) sender)
118  (declare (ignore sender))
119  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 1)
120  (#/orderOut: (authentication-window *authentication-window-controller*) +null-ptr+))
121
122(objc:defmethod (#/authCancel: :void) ((self authentication-window-controller) sender)
123  (declare (ignore sender))
124  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 0)
125  (#/orderOut: (authentication-window *authentication-window-controller*) +null-ptr+))
126
127(defun get-auth-window ()
128  (unless *authentication-window-controller*
129    (setf *authentication-window-controller* 
130          (make-instance 'authentication-window-controller))
131    (#/initWithWindowNibName: *authentication-window-controller* #@"Authenticate"))
132  (unless (#/isWindowLoaded *authentication-window-controller*)
133    (#/loadWindow *authentication-window-controller*))
134  (let ((window (authentication-window *authentication-window-controller*)))
135    (if (or (null window)
136            (%null-ptr-p window))
137        nil
138        window)))
139
140(defun get-svn-auth-data ()
141  (let ((auth-window (get-auth-window)))
142    (if auth-window
143        (let ((window-status (#/runModalForWindow: (#/sharedApplication (@class ns-application))
144                                                   auth-window)))
145          (if (zerop window-status)
146              nil
147              (let  ((username (lisp-string-from-nsstring (#/stringValue (authentication-window-username-field 
148                                                                          *authentication-window-controller*))))
149                     (password (lisp-string-from-nsstring (#/stringValue (authentication-window-password-field 
150                                                                          *authentication-window-controller*)))))
151                (cons username password))))
152        nil)))
153
154
155;;; -----------------------------------------------------------------
156;;; app delegate extensions to handle self-update UI
157;;; -----------------------------------------------------------------
158
159(defparameter *update-ccl-window-controller* nil)
160
161(defclass update-ccl-window-controller (ns:ns-window-controller)
162    ((update-window :foreign-type :id :reader update-window))
163  (:metaclass ns:+ns-object))
164
165(objc:defmethod #/windowNibName ((self update-ccl-window-controller))
166  #@"updateCCL")
167
168(objc:defmethod (#/updateCCLOkay: :void) ((self update-ccl-window-controller) sender)
169  (declare (ignore sender))
170  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 1)
171  (#/orderOut: (update-window *update-ccl-window-controller*) +null-ptr+))
172
173(objc:defmethod (#/updateCCLCancel: :void) ((self update-ccl-window-controller) sender)
174  (declare (ignore sender))
175  (#/stopModalWithCode: (#/sharedApplication (@class ns-application)) 0)
176  (#/orderOut: (update-window *update-ccl-window-controller*) +null-ptr+))
177
178(objc:defmethod (#/updateCCL: :void) ((self lisp-application-delegate)
179                                                sender)
180  (declare (ignore sender))
181  (when (null *update-ccl-window-controller*)
182    (setf *update-ccl-window-controller*
183          (make-instance 'update-ccl-window-controller))
184    (#/initWithWindowNibName: *update-ccl-window-controller* #@"updateCCL"))
185  (#/showWindow: *update-ccl-window-controller* self))
186
Note: See TracBrowser for help on using the repository browser.