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 (success code out err) (git project "branch" "-r" "--format" "%(refname) %(objectname)" "--list" "origin/*")
  81    (declare (ignore code err))
  82    (when (not success) (raise-candle-error :project-failed-to-get-branches))
  83    (mapcar (lambda (branch) (set-branch-in-git branch nil)) branches)
  84    (mapcar
  85     (lambda (line)
  86      (cl-ppcre:register-groups-bind (branch-name sha) ("refs/remotes/origin/(.*) (.*)" line)
  87       (let*
  88        ((job
  89          (or
  90           (find sha (find-job-by-project project) :test #'string= :key #'job-sha)
  91           (make-job :status :queued :sha sha :project project :create-date (get-universal-time))))
  92         (branch
  93          (or
  94           (find branch-name branches :test #'string= :key #'branch-name)
  95           (make-branch :name branch-name :project project))))
  96        (set-branch-in-git branch t)
  97        (set-branch-job branch job))))
  98     (cl-ppcre:split "\\n" out))))
  99  (awaken-processor-thread))
 100
 101 (defun delete-project (name)
 102  (let
 103   ((project (find-project-by-name-or-die name)))
 104   (sb-ext:delete-directory (project-dir project) :recursive t)
 105   (mapcar #'nremove-job (find-job-by-project project))
 106   (mapcar #'nremove-branch (find-branch-by-project project))
 107   (nremove-project project)))
 108
 109 (defun job->job-information (job)
 110  (list (project-name (job-project job)) (job-sha job) (job-status job) (job-create-date job)))
 111
 112 (defun project-branch-information (name)
 113  (let
 114   ((project (find-project-by-name-or-die name)))
 115   (mapcar
 116    (lambda (branch)
 117     (list
 118      (branch-name branch)
 119      (job->job-information (branch-job branch))))
 120    (remove-if-not #'branch-in-git (find-branch-by-project project)))))
 121
 122 (defun project-job-information (name)
 123  (let
 124   ((project (find-project-by-name-or-die name)))
 125   (mapcar #'job->job-information
 126    (if project
 127     (find-job-by-project project)
 128     *all-job*))))
 129
 130 (defun find-job-by-project-and-sha (project-name sha)
 131  (let*
 132   ((project (find project-name *all-project* :test #'string= :key #'project-name))
 133    (job
 134     (when project
 135      (find-if
 136       (lambda (job-sha)
 137        (and (<= (length sha) (length job-sha)) (string= sha (subseq job-sha 0 (length sha)))))
 138      (find-job-by-project project)
 139      :key #'job-sha))))
 140   (when (not job) (raise-candle-error :job-does-not-exist))
 141   job))
 142
 143 (defun get-job-log (project-name sha)
 144  (job-log (find-job-by-project-and-sha project-name sha)))
 145
 146 (defun retry-job (project-name sha)
 147  (set-job-status (find-job-by-project-and-sha project-name sha) :queued)
 148  (awaken-processor-thread))
 149
 150 (defun list-projects ()
 151  (mapcar
 152   (lambda (project)
 153    (list
 154     (project-name project)
 155     (project-src project)
 156     (failures (project-name project))))
 157   *all-project*))
 158
 159 (defun failures (project-name)
 160  (let
 161   ((project (find-project-by-name-or-die project-name)))
 162   (length
 163    (remove-if-not
 164     (lambda (branch) (and (branch-in-git branch) (eql :failed (job-status (branch-job branch)))))
 165     (if project (find-branch-by-project project) *all-branch*)))))