(in-package #:candle)

(defun server (port &optional (background t))
 "SERVER PORT &optional BACKGROUND => UNUSED

ARGUMENTS AND VALUES:

  PORT: the port to start the communication server on
  BACKGROUND: a boolean, defaulting to T
  UNUSED: the result is unused

DESCRIPTION:

  Starts the server, listening for commands from the client on PORT.

  If BACKGROUND is T, then the communication thread starts in the background,
  which is useful when starting the server from an already running process.
  Generally, if running from a script, you'll want BACKGROUND to be NIL,
  so that the process doesn't exit immediately."

 (when (not *candle-dir*) (error "Need a candle dir"))
 (let*
  ((data-dir (format nil "~Adata" *candle-dir*))
   (log-dir (format nil "~Alogs/" *candle-dir*)))
  (ensure-directories-exist *candle-dir*)
  (ensure-directories-exist data-dir)
  (ensure-directories-exist log-dir)
  (setf log-utils:*log-dir* log-dir)
  (log:add-appender #'log-utils:file-appender)
  (log:info "Starting server on port ~A" port)
  (lame-db:load-known-dbs data-dir)
  (log:info "Starting processor in ~(~A~) mode" *job-system*)
  (start-save-thread data-dir)
  (start-processor-thread)
  (communication:start-listener port background)))

(defun start-save-thread (data-dir)
 (log:info "Starting Save Thread")
 (let*
  ((mutex (sb-thread:make-mutex))
   (waitq (sb-thread:make-waitqueue))
   (active t)
   (save-thread
    (sb-thread:make-thread
     (lambda ()
      (loop
       :while active
       :do
       (sb-thread:with-mutex (mutex)
        (sb-thread:condition-wait waitq mutex)
        (lame-db:save-known-dbs data-dir))))
     :name "Save Thread")))
  (sb-thread:make-thread
   (lambda ()
    (loop
     (sleep (* 5 60))
     (sb-thread:with-mutex (mutex)
      (sb-thread:condition-broadcast waitq))))
   :name "Save Thread Trigger")
  (push
   (lambda ()
    (log:info "Shutting down save thread")
    (sb-thread:with-mutex (mutex)
     (setf active nil)
     (sb-thread:condition-broadcast waitq))
    (sb-thread:join-thread save-thread))
   sb-ext:*exit-hooks*)))

(defun find-project-by-name-or-die (name)
 (when name
  (or
   (find name *all-project* :test #'string= :key #'project-name)
   (raise-candle-error :project-does-not-exist))))

(defun add-project (name src)
 "ADD-PROJECT NAME SRC => RESULT

ARGUMENTS AND VALUES:

  NAME: a string, representing the name of the project
  SRC: a pathname, or pathstring, holding the location of the project
  RESULT: if no error generated, returns t

DESCRIPTION:

  Creates and adds a project to the database.  NAME must be a
  unique alphanumeric (hyphens allowed) string.  SRC must be a git
  accessible location for the running user, requiring keys to be set
  up or it be located on the local disk.

  In addition to adding to the database, it will also clone the project
  and analyze it intially (calling REFRESH-PROJECT)."
 (when
  (not (cl-ppcre:scan "^[0-9A-Za-z-]*$" name))
  (raise-candle-error :invalid-project-name))
 (when
  (not (git nil "ls-remote" src))
  (raise-candle-error :invalid-project-uri))
 (when
  (find name *all-project* :test #'string= :key #'project-name)
  (raise-candle-error :project-name-taken))
 (let
  ((project (make-project :name name :src src)))
  (ensure-directories-exist (project-dir project))
  (git project "clone" src ".")
  (refresh-project name))
 t)

(defun refresh-project (name)
 "REFRESH-PROJECT NAME => RESULT

ARGUMENTS AND VALUES:

  NAME: a string, representing the name of the project
  RESULT: unused

DESCRIPTION:

  Refreshes the project from git's origin.  Fetches, and then
  analysis all branches available to create jobs for any new
  commits that those branches are set to.  Then wakes up the
  processor thread to start working through those jobs."
 (let*
  ((project (find-project-by-name-or-die name))
   (branches (find-branch-by-project project)))
  (git project "fetch" "origin" "--prune")
  (multiple-value-bind
   (success code out err)
   (git project "branch" "-r" "--format" "%(refname) %(objectname)" "--list" "origin/*")
   (declare (ignore code err))
   (when (not success) (raise-candle-error :project-failed-to-get-branches))
   (mapcar (lambda (branch) (set-branch-in-git branch nil)) branches)
   (mapcar
    (lambda (line)
     (cl-ppcre:register-groups-bind (branch-name sha) ("refs/remotes/origin/(.*) (.*)" line)
      (let*
       ((job
         (or
          (find sha (find-job-by-project project) :test #'string= :key #'job-sha)
          (make-job :status :queued :sha sha :project project :create-date (get-universal-time))))
        (branch
         (or
          (find branch-name branches :test #'string= :key #'branch-name)
          (make-branch :name branch-name :project project))))
       (set-branch-in-git branch t)
       (set-branch-job branch job))))
    (cl-ppcre:split "\\n" out))))
 (awaken-processor-thread))

(defun delete-project (name)
 "DELETE-PROJECT NAME => RESULT

ARGUMENTS AND VALUES:

  NAME: a string, representing the name of the project
  RESULT: unused

DESCRIPTION:

  Removes a project from the database and the disk.  NAME must
  be an existing project."
 (let
  ((project (find-project-by-name-or-die name)))
  (sb-ext:delete-directory (project-dir project) :recursive t)
  (mapcar #'nremove-job (find-job-by-project project))
  (mapcar #'nremove-branch (find-branch-by-project project))
  (nremove-project project)))

(defun job->job-information (job)
 (list (project-name (job-project job)) (job-sha job) (job-status job) (job-create-date job)))

(defun project-branch-information (name)
 "PROJECT-BRANCH-INFORMATION NAME => BRANCHES-INFORMATION

  BRANCHES-INFORMATION: BRANCH-INFORMATION*
  BRANCH-INFORMATION: (BRANCH-NAME JOB-INFORMATION)
  JOB-INFORMATION: (JOB-PROJECT-NAME SHA STATUS CREATED-DATE)
  STATUS: :queued | :failed | :succeeded | :no-candle-file | :in-progress

ARGUMENTS AND VALUES:

  NAME: a string, the project for which we want information
  BRANCH-NAME: a string, the name of the branch
  JOB-PROJECT-NAME: a string, the project name for the attached job
  SHA: a string, the sha for this job
  CREATED-DATE: a universal time, the moment the job was first created

DESCRIPTION:

  Returns the information for all the branches in the given project,
  which includes the job information for the commit that the branch
  is currently pointing to."
 (let
  ((project (find-project-by-name-or-die name)))
  (mapcar
   (lambda (branch)
    (list
     (branch-name branch)
     (job->job-information (branch-job branch))))
   (remove-if-not #'branch-in-git (find-branch-by-project project)))))

(defun project-job-information (name)
 "PROJECT-JOB-INFORMATION NAME => JOBS-INFORMATION

  JOBS-INFORMATION: JOB-INFORMATION*
  JOB-INFORMATION: (JOB-PROJECT-NAME SHA STATUS CREATED-DATE)
  STATUS: :queued | :failed | :succeeded | :no-candle-file | :in-progress

ARGUMENTS AND VALUES:

  NAME: a string, the project for which we want information
  JOB-PROJECT-NAME: a string, the project name for the attached job
  SHA: a string, the sha for this job
  CREATED-DATE: a universal time, the moment the job was first created

DESCRIPTION:

  Returns the information for all the jobs in the given project."
 (let
  ((project (find-project-by-name-or-die name)))
  (mapcar #'job->job-information
   (if project
    (find-job-by-project project)
    *all-job*))))

(defun find-job-by-project-and-sha (project-name sha)
 (let*
  ((project (find project-name *all-project* :test #'string= :key #'project-name))
   (job
    (when project
     (find-if
      (lambda (job-sha)
       (and (<= (length sha) (length job-sha)) (string= sha (subseq job-sha 0 (length sha)))))
      (find-job-by-project project)
      :key #'job-sha))))
  (when (not job) (raise-candle-error :job-does-not-exist))
  job))

(defun get-job-log (project-name sha)
 "GET-JOB-LOG PROJECT-NAME SHA => LOG

ARGUMENTS AND VALUES:

  PROJECT-NAME: a string, representing the name of the project
  SHA: a string, the commit sha for the job
  LOG: the log from the run process

DESCRIPTION:

  Returns the log for the job specified.  When the job wasn't run
  (for instance, if no candle file), just returns NIL.  The SHA
  can be truncated, and if there are collisions, one of them will be
  returned."
 (job-log (find-job-by-project-and-sha project-name sha)))

(defun retry-job (project-name sha)
 "RETRY-JOB PROJECT-NAME SHA => UNUSED

ARGUMENTS AND VALUES:

  PROJECT-NAME: a string, representing the name of the project
  SHA: a string, the commit sha for the job
  UNUSED: the result is unused

DESCRIPTION:

  Sets the job specified by PROJECT-NAME and SHA to :queued, which will
  then be run.  Also awakes the processor thread to process it immediately
  if available."
 (set-job-status (find-job-by-project-and-sha project-name sha) :queued)
 (awaken-processor-thread))

(defun list-projects ()
 "LIST-PROJECTS => PROJECTS-INFORMATION

  PROJECTS-INFORMATION: PROJECT-INFORMATION*
  PROJECT-INFORMATION: (NAME SRC FAILURES)

ARGUMENTS AND VALUES:

  NAME: a string, representing the name of the project
  SRC: the git origin remote location
  FAILURES: the number of failing branches

DESCRIPTION:

  Returns the information for all the projects in the system, as
  is needed by the cli.  Returns it as a list of lists, as specified
  above."
 (mapcar
  (lambda (project)
   (list
    (project-name project)
    (project-src project)
    (failures (project-name project))))
  *all-project*))

(defun failures (&optional project-name)
 "FAILURES &optional NAME => NUM-FAILURES

ARGUMENTS AND VALUES:

  NAME: a string, representing the name of the project
  NUM-FAILURES: the number of failures

DESCRIPTION:

  Returns the number of failing branches.  When NAME is specified,
  the branches are limited to the project it refers to."
 (let
  ((project (find-project-by-name-or-die project-name)))
  (length
   (remove-if-not
    (lambda (branch) (and (branch-in-git branch) (eql :failed (job-status (branch-job branch)))))
    (if project (find-branch-by-project project) *all-branch*)))))