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

   1 (in-package #:candle)
   2
   3 (defun server (port &optional (background t))
   4  (when (not *candle-dir*) (error "Need a candle dir"))
   5  (let*
   6   ((data-dir (format nil "~Adata" *candle-dir*)))
   7   (ensure-directories-exist *candle-dir*)
   8   (ensure-directories-exist data-dir)
   9   (lame-db:load-known-dbs data-dir)
  10   (format t "Starting processor in ~(~A~) mode~%" *job-system*)
  11   (start-save-thread data-dir)
  12   (start-processor-thread)
  13   (communication:start-listener port background)))
  14
  15 (defun start-save-thread (data-dir)
  16  (format t "Starting Save Thread~%")
  17  (let*
  18   ((mutex (sb-thread:make-mutex))
  19    (waitq (sb-thread:make-waitqueue))
  20    (active t)
  21    (save-thread
  22     (sb-thread:make-thread
  23      (lambda ()
  24       (loop
  25        :while active
  26        :do
  27        (sb-thread:with-mutex (mutex)
  28         (sb-thread:condition-wait waitq mutex)))
  29       (lame-db:save-known-dbs data-dir))
  30      :name "Save Thread")))
  31   (sb-thread:make-thread
  32    (lambda ()
  33     (loop
  34      (sleep (* 1 60))
  35      (sb-thread:with-mutex (mutex)
  36       (sb-thread:condition-broadcast waitq))))
  37    :name "Save Thread Trigger")
  38   (push
  39    (lambda ()
  40     (format t "Shutting down save thread~%")
  41     (sb-thread:with-mutex (mutex)
  42      (setf active nil)
  43      (sb-thread:condition-broadcast waitq))
  44     (sb-thread:join-thread save-thread))
  45    sb-ext:*exit-hooks*)))
  46
  47 (defun add-project (name src)
  48  (when
  49   (not (cl-ppcre:scan "^[0-9A-Za-z-]*$" name))
  50   (error "Name contains invalid characters"))
  51  (when
  52   (not (git nil "ls-remote" src))
  53   (error "Project uri is not a valid git repository"))
  54  (when
  55   (find name *all-project* :test #'string= :key #'project-name)
  56   (error "Project name already taken"))
  57  (let
  58   ((project (make-project :name name :src src)))
  59   (ensure-directories-exist (project-dir project))
  60   (git project "clone" src ".")
  61   (refresh-project name))
  62  t)
  63
  64 (defun refresh-project (name)
  65  (let*
  66   ((project (find name *all-project* :test #'string= :key #'project-name))
  67    (branches (find-branch-by-project project)))
  68   (git project "fetch" "origin" "--prune")
  69   (multiple-value-bind (success code out err) (git project "branch" "-r" "--format" "%(refname) %(objectname)" "--list" "origin/*")
  70    (declare (ignore code err))
  71    (when (not success) (error "Failed to get branches"))
  72    (mapcar (lambda (branch) (set-branch-in-git branch nil)) branches)
  73    (mapcar
  74     (lambda (line)
  75      (cl-ppcre:register-groups-bind (branch-name sha) ("refs/remotes/origin/(.*) (.*)" line)
  76       (let*
  77        ((job
  78          (or
  79           (find sha (find-job-by-project project) :test #'string= :key #'job-sha)
  80           (make-job :status :queued :sha sha :project project :create-date (get-universal-time))))
  81         (branch
  82          (or
  83           (find branch-name branches :test #'string= :key #'branch-name)
  84           (make-branch :name branch-name :project project))))
  85        (set-branch-in-git branch t)
  86        (set-branch-job branch job))))
  87     (cl-ppcre:split "\\n" out))))
  88  (awaken-processor-thread))
  89
  90 (defun delete-project (name)
  91  (let
  92   ((project (find name *all-project* :test #'string= :key #'project-name)))
  93   (when (not project) (error "Project does not exist"))
  94   (sb-ext:delete-directory (project-dir project) :recursive t)
  95   (mapcar #'nremove-job (find-job-by-project project))
  96   (mapcar #'nremove-branch (find-branch-by-project project))
  97   (nremove-project project)))
  98
  99 (defun job->job-information (job)
 100  (list (job-sha job) (job-status job) (job-create-date job)))
 101
 102 (defun project-branch-information (name)
 103  (let
 104   ((project (find name *all-project* :test #'string= :key #'project-name)))
 105   (when (not project) (error "Project does not exist"))
 106   (mapcar
 107    (lambda (branch)
 108     (list
 109      (branch-name branch)
 110      (job->job-information (branch-job branch))))
 111    (remove-if-not #'branch-in-git (find-branch-by-project project)))))
 112
 113 (defun project-job-information (name)
 114  (let
 115   ((project (when name (find name *all-project* :test #'string= :key #'project-name))))
 116   (when (and name (not project)) (error "Project does not exist"))
 117   (mapcar #'job->job-information
 118    (if project
 119     (find-job-by-project project)
 120     *all-job*))))
 121
 122 (defun find-job-by-project-and-sha (project-name sha)
 123  (let*
 124   ((project (find project-name *all-project* :test #'string= :key #'project-name))
 125    (job
 126     (when project
 127      (find-if
 128       (lambda (job-sha)
 129        (and (<= (length sha) (length job-sha)) (string= sha (subseq job-sha 0 (length sha)))))
 130      (find-job-by-project project)
 131      :key #'job-sha))))
 132   (when (not project) (error "Project does not exist"))
 133   (when (not job) (error "Job does not exist"))
 134   job))
 135
 136 (defun get-job-log (project-name sha)
 137  (job-log (find-job-by-project-and-sha project-name sha)))
 138
 139 (defun retry-job (project-name sha)
 140  (set-job-status (find-job-by-project-and-sha project-name sha) :queued)
 141  (awaken-processor-thread))
 142
 143 (defun list-projects ()
 144  (mapcar
 145   (lambda (project)
 146    (list
 147     (project-name project)
 148     (project-src project)))
 149   *all-project*))
 150
 151 (defun failures (project-name)
 152  (length
 153   (remove-if-not
 154    (lambda (branch) (eql :failed (job-status (branch-job branch))))
 155    (if project-name
 156      (find-branch-by-project
 157       (find project-name *all-project* :test #'string= :key #'project-name))
 158      *all-branch*))))