e1b8cb696cdcbcf1ebe1f6fc53f92c23ae0b385a
[candle] / src / main / server.lisp
1 (in-package #:candle)
2
3 (defun server (port &optional (background t))
4  "SERVER PORT &optional BACKGROUND => UNUSED
5
6 ARGUMENTS AND VALUES:
7
8   PORT: the port to start the communication server on
9   BACKGROUND: a boolean, defaulting to T
10   UNUSED: the result is unused
11
12 DESCRIPTION:
13
14   Starts the server, listening for commands from the client on PORT.
15
16   If BACKGROUND is T, then the communication thread starts in the background,
17   which is useful when starting the server from an already running process.
18   Generally, if running from a script, you'll want BACKGROUND to be NIL,
19   so that the process doesn't exit immediately."
20
21  (when (not *candle-dir*) (error "Need a candle dir"))
22  (let*
23   ((data-dir (format nil "~Adata" *candle-dir*))
24    (log-dir (format nil "~Alogs/" *candle-dir*)))
25   (ensure-directories-exist *candle-dir*)
26   (ensure-directories-exist data-dir)
27   (ensure-directories-exist log-dir)
28   (setf log-utils:*log-dir* log-dir)
29   (log:add-appender #'log-utils:file-appender)
30   (log:info "Starting server on port ~A" port)
31   (lame-db:load-known-dbs data-dir)
32   (log:info "Starting processor in ~(~A~) mode" *job-system*)
33   (start-save-thread data-dir)
34   (start-processor-thread)
35   (communication:start-listener port background)))
36
37 (defun start-save-thread (data-dir)
38  (log:info "Starting Save Thread")
39  (let*
40   ((mutex (sb-thread:make-mutex))
41    (waitq (sb-thread:make-waitqueue))
42    (active t)
43    (save-thread
44     (sb-thread:make-thread
45      (lambda ()
46       (loop
47        :while active
48        :do
49        (sb-thread:with-mutex (mutex)
50         (sb-thread:condition-wait waitq mutex)
51         (lame-db:save-known-dbs data-dir))))
52      :name "Save Thread")))
53   (sb-thread:make-thread
54    (lambda ()
55     (loop
56      (sleep (* 5 60))
57      (sb-thread:with-mutex (mutex)
58       (sb-thread:condition-broadcast waitq))))
59    :name "Save Thread Trigger")
60   (push
61    (lambda ()
62     (log:info "Shutting down save thread")
63     (sb-thread:with-mutex (mutex)
64      (setf active nil)
65      (sb-thread:condition-broadcast waitq))
66     (sb-thread:join-thread save-thread))
67    sb-ext:*exit-hooks*)))
68
69 (defun find-project-by-name-or-die (name)
70  (when name
71   (or
72    (find name *all-project* :test #'string= :key #'project-name)
73    (raise-candle-error :project-does-not-exist))))
74
75 (defun add-project (name src)
76  "ADD-PROJECT NAME SRC => RESULT
77
78 ARGUMENTS AND VALUES:
79
80   NAME: a string, representing the name of the project
81   SRC: a pathname, or pathstring, holding the location of the project
82   RESULT: if no error generated, returns t
83
84 DESCRIPTION:
85
86   Creates and adds a project to the database.  NAME must be a
87   unique alphanumeric (hyphens allowed) string.  SRC must be a git
88   accessible location for the running user, requiring keys to be set
89   up or it be located on the local disk.
90
91   In addition to adding to the database, it will also clone the project
92   and analyze it intially (calling REFRESH-PROJECT)."
93  (when
94   (not (cl-ppcre:scan "^[0-9A-Za-z-]*$" name))
95   (raise-candle-error :invalid-project-name))
96  (when
97   (not (git nil "ls-remote" src))
98   (raise-candle-error :invalid-project-uri))
99  (when
100   (find name *all-project* :test #'string= :key #'project-name)
101   (raise-candle-error :project-name-taken))
102  (let
103   ((project (make-project :name name :src src)))
104   (ensure-directories-exist (project-dir project))
105   (git project "clone" src ".")
106   (refresh-project name))
107  t)
108
109 (defun refresh-project (name)
110  "REFRESH-PROJECT NAME => RESULT
111
112 ARGUMENTS AND VALUES:
113
114   NAME: a string, representing the name of the project
115   RESULT: unused
116
117 DESCRIPTION:
118
119   Refreshes the project from git's origin.  Fetches, and then
120   analysis all branches available to create jobs for any new
121   commits that those branches are set to.  Then wakes up the
122   processor thread to start working through those jobs."
123  (let*
124   ((project (find-project-by-name-or-die name))
125    (branches (find-branch-by-project project)))
126   (git project "fetch" "origin" "--prune")
127   (multiple-value-bind
128    (success code out err)
129    (git project "branch" "-r" "--format" "%(refname) %(objectname)" "--list" "origin/*")
130    (declare (ignore code err))
131    (when (not success) (raise-candle-error :project-failed-to-get-branches))
132    (mapcar (lambda (branch) (set-branch-in-git branch nil)) branches)
133    (mapcar
134     (lambda (line)
135      (cl-ppcre:register-groups-bind (branch-name sha) ("refs/remotes/origin/(.*) (.*)" line)
136       (let*
137        ((job
138          (or
139           (find sha (find-job-by-project project) :test #'string= :key #'job-sha)
140           (make-job :status :queued :sha sha :project project :create-date (get-universal-time))))
141         (branch
142          (or
143           (find branch-name branches :test #'string= :key #'branch-name)
144           (make-branch :name branch-name :project project))))
145        (set-branch-in-git branch t)
146        (set-branch-job branch job))))
147     (cl-ppcre:split "\\n" out))))
148  (awaken-processor-thread))
149
150 (defun delete-project (name)
151  "DELETE-PROJECT NAME => RESULT
152
153 ARGUMENTS AND VALUES:
154
155   NAME: a string, representing the name of the project
156   RESULT: unused
157
158 DESCRIPTION:
159
160   Removes a project from the database and the disk.  NAME must
161   be an existing project."
162  (let
163   ((project (find-project-by-name-or-die name)))
164   (sb-ext:delete-directory (project-dir project) :recursive t)
165   (mapcar #'nremove-job (find-job-by-project project))
166   (mapcar #'nremove-branch (find-branch-by-project project))
167   (nremove-project project)))
168
169 (defun job->job-information (job)
170  (list (project-name (job-project job)) (job-sha job) (job-status job) (job-create-date job)))
171
172 (defun project-branch-information (name)
173  "PROJECT-BRANCH-INFORMATION NAME => BRANCHES-INFORMATION
174
175   BRANCHES-INFORMATION: BRANCH-INFORMATION*
176   BRANCH-INFORMATION: (BRANCH-NAME JOB-INFORMATION)
177   JOB-INFORMATION: (JOB-PROJECT-NAME SHA STATUS CREATED-DATE)
178   STATUS: :queued | :failed | :succeeded | :no-candle-file | :in-progress
179
180 ARGUMENTS AND VALUES:
181
182   NAME: a string, the project for which we want information
183   BRANCH-NAME: a string, the name of the branch
184   JOB-PROJECT-NAME: a string, the project name for the attached job
185   SHA: a string, the sha for this job
186   CREATED-DATE: a universal time, the moment the job was first created
187
188 DESCRIPTION:
189
190   Returns the information for all the branches in the given project,
191   which includes the job information for the commit that the branch
192   is currently pointing to."
193  (let
194   ((project (find-project-by-name-or-die name)))
195   (mapcar
196    (lambda (branch)
197     (list
198      (branch-name branch)
199      (job->job-information (branch-job branch))))
200    (remove-if-not #'branch-in-git (find-branch-by-project project)))))
201
202 (defun project-job-information (name)
203  "PROJECT-JOB-INFORMATION NAME => JOBS-INFORMATION
204
205   JOBS-INFORMATION: JOB-INFORMATION*
206   JOB-INFORMATION: (JOB-PROJECT-NAME SHA STATUS CREATED-DATE)
207   STATUS: :queued | :failed | :succeeded | :no-candle-file | :in-progress
208
209 ARGUMENTS AND VALUES:
210
211   NAME: a string, the project for which we want information
212   JOB-PROJECT-NAME: a string, the project name for the attached job
213   SHA: a string, the sha for this job
214   CREATED-DATE: a universal time, the moment the job was first created
215
216 DESCRIPTION:
217
218   Returns the information for all the jobs in the given project."
219  (let
220   ((project (find-project-by-name-or-die name)))
221   (mapcar #'job->job-information
222    (if project
223     (find-job-by-project project)
224     *all-job*))))
225
226 (defun find-job-by-project-and-sha (project-name sha)
227  (let*
228   ((project (find project-name *all-project* :test #'string= :key #'project-name))
229    (job
230     (when project
231      (find-if
232       (lambda (job-sha)
233        (and (<= (length sha) (length job-sha)) (string= sha (subseq job-sha 0 (length sha)))))
234       (find-job-by-project project)
235       :key #'job-sha))))
236   (when (not job) (raise-candle-error :job-does-not-exist))
237   job))
238
239 (defun get-job-log (project-name sha)
240  "GET-JOB-LOG PROJECT-NAME SHA => LOG
241
242 ARGUMENTS AND VALUES:
243
244   PROJECT-NAME: a string, representing the name of the project
245   SHA: a string, the commit sha for the job
246   LOG: the log from the run process
247
248 DESCRIPTION:
249
250   Returns the log for the job specified.  When the job wasn't run
251   (for instance, if no candle file), just returns NIL.  The SHA
252   can be truncated, and if there are collisions, one of them will be
253   returned."
254  (job-log (find-job-by-project-and-sha project-name sha)))
255
256 (defun retry-job (project-name sha)
257  "RETRY-JOB PROJECT-NAME SHA => UNUSED
258
259 ARGUMENTS AND VALUES:
260
261   PROJECT-NAME: a string, representing the name of the project
262   SHA: a string, the commit sha for the job
263   UNUSED: the result is unused
264
265 DESCRIPTION:
266
267   Sets the job specified by PROJECT-NAME and SHA to :queued, which will
268   then be run.  Also awakes the processor thread to process it immediately
269   if available."
270  (set-job-status (find-job-by-project-and-sha project-name sha) :queued)
271  (awaken-processor-thread))
272
273 (defun list-projects ()
274  "LIST-PROJECTS => PROJECTS-INFORMATION
275
276   PROJECTS-INFORMATION: PROJECT-INFORMATION*
277   PROJECT-INFORMATION: (NAME SRC FAILURES)
278
279 ARGUMENTS AND VALUES:
280
281   NAME: a string, representing the name of the project
282   SRC: the git origin remote location
283   FAILURES: the number of failing branches
284
285 DESCRIPTION:
286
287   Returns the information for all the projects in the system, as
288   is needed by the cli.  Returns it as a list of lists, as specified
289   above."
290  (mapcar
291   (lambda (project)
292    (list
293     (project-name project)
294     (project-src project)
295     (failures (project-name project))))
296   *all-project*))
297
298 (defun failures (&optional project-name)
299  "FAILURES &optional NAME => NUM-FAILURES
300
301 ARGUMENTS AND VALUES:
302
303   NAME: a string, representing the name of the project
304   NUM-FAILURES: the number of failures
305
306 DESCRIPTION:
307
308   Returns the number of failing branches.  When NAME is specified,
309   the branches are limited to the project it refers to."
310  (let
311   ((project (find-project-by-name-or-die project-name)))
312   (length
313    (remove-if-not
314     (lambda (branch) (and (branch-in-git branch) (eql :failed (job-status (branch-job branch)))))
315     (if project (find-branch-by-project project) *all-branch*)))))