code.consxy.com Git - candle/blob - src/main/server.lisp

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