code.consxy.com Git - candle/blob - 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*)))))