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