upload.ros

#!/bin/sh
#|-*- mode:lisp -*-|#
#|
exec ros -Q -- $0 "$@"
|#
(progn ;;init forms
  (ros:ensure-asdf)
  #+quicklisp
  (ql:quickload '(log4cl
                  ngrok/slynk)
                :silent t))

(defpackage :ros.script.upload
  (:use :cl))
(in-package :ros.script.upload)


(defvar *current-dir*)


(define-condition unable-to-proceed (simple-error)
  ((message :initarg :message
            :reader get-message))
  (:report (lambda (condition stream)
             (format stream (get-message condition)))))


(define-condition subprocess-error-with-output (uiop::subprocess-error)
  ((stdout :initarg :stdout :reader subprocess-error-stdout)
   (stderr :initarg :stderr :reader subprocess-error-stderr))
  (:report (lambda (condition stream)
             (format stream "Subprocess ~@[~S~% ~]~@[with command ~S~% ~]exited with error~@[ code ~D ~]~@[~%STDOUT:~% ~S~]~@[~%STDERR:~% ~S~]"
                     (uiop:subprocess-error-process condition)
                     (uiop:subprocess-error-command condition)
                     (uiop:subprocess-error-code condition)
                     (subprocess-error-stdout condition)
                     (subprocess-error-stderr condition)))))


(defun run (command &key (raise t))
  "Runs command and returns it's stdout stderr and code.

If there was an error, raises subprocess-error-with-output, but this
behaviour could be overriden by keyword argument ``:raise t``."
  
  (multiple-value-bind (stdout stderr code)
      (uiop:run-program command
                        :output '(:string :stripped t)
                        :error-output '(:string :stripped t)
                        :ignore-error-status t)
    
    (when (and raise
               (not (eql code 0)))
      (error 'subprocess-error-with-output
             :stdout stdout
             :stderr stderr
             :code code
             :command command))
    (values stdout stderr code)))


(defun gh-pages-repository-initialized-p (docs-dir)
  "Checks if repository for documentation already initialized"
  (uiop:directory-exists-p (uiop:merge-pathnames* #P".git/"
                                                  docs-dir)))


(defun git (&rest commands)
  "Calls git command in gh-pages repository."
  
  (uiop:with-current-directory (*current-dir*)
    (let ((command (apply #'concatenate 'string
                          "git "
                          commands)))
        
      (log:info "Running" command "in" *current-dir*)
      (run command))))


(defun git-repository-was-changed-p ()
  ;; Here we only interested in entries which are starting from 1 (changed in porcelain v2 format).
  ;; And not in qlfile and qlfile.lock.
  ;; The "cat" at the end is to make 0 status code if there is no changed files.
  ;; Because we only want an output from grep.
  (> (length (git "status --porcelain=v2 | grep '^1' | grep -v -e qlfile -e .github/workflows | cat"))
     0))


(defun get-git-upstream ()
  ;; taken from http://stackoverflow.com/a/9753364/70293
  (let ((upstream (run "git rev-parse --abbrev-ref --symbolic-full-name @{u}" :raise nil)))
    (when (> (length upstream)
           0)
      (subseq upstream
              0
              (search "/" upstream)))))


(defun get-origin-to-push ()
  (cond
    ;; If we are running inside github actions
    ((uiop:getenv "GITHUB_ACTIONS")
     (unless (uiop:getenv "GITHUB_TOKEN")
       (error 'unable-to-proceed
              :message "Please, provide GITHUB_TOKEN environment variable."))
     (format nil "https://~A:~A@github.com/~A"
             (uiop:getenv "GITHUB_ACTOR")
             (uiop:getenv "GITHUB_TOKEN")
             (uiop:getenv "GITHUB_REPOSITORY")))
    ;; otherwise make it from travis secret token and repo slug
    ((uiop:getenv "TRAVIS_REPO_SLUG")
     (let ((repo-slug (uiop:getenv "TRAVIS_REPO_SLUG"))
           (repo-token (uiop:getenv "GH_REPO_TOKEN")))

       (unless (and repo-slug repo-token)
         (error 'unable-to-proceed
                :message "Current branch does not track any upstream and there is no TRAVIS_REPO_SLUG and GH_REPO_TOKEN env variables. Where to push gh-pages branch?"))

       (format nil "https://~A@github.com/~A"
               repo-token
               repo-slug)))
    ;; If there is already some remote upstream, then use it
    (t
     (let ((upstream (get-git-upstream)))
       (cond
         (upstream
          (run (concatenate 'string "git remote get-url " upstream)))
         (t
          (log:error "Unable to guess correct upstream URL")
          (values nil)))))))  


(defun push-gh-pages (docs-dir)
  (log:info "Pushing changes to gh-pages branch")

  (let ((*current-dir* docs-dir))
  
    (unless (gh-pages-repository-initialized-p docs-dir)
      (git "init")
    
      (git "remote add origin "
           (get-origin-to-push)))

    (git "add .")
  
    (cond
      ((git-repository-was-changed-p)
       (when (uiop:getenv "GITHUB_ACTIONS")
         (git "config --global user.name \"github-actions[bot]\"")
         (git "config --global user.email \"actions@github.com\""))
       (git "commit -m 'Update docs'")
    
       (git "push --force origin master:gh-pages"))
      ;; or
      (t (log:info "Everything is up to date."))))
  (values))


(defun empty-string-to-nil (value)
  (when (and value
             (not (string= value "")))
    value))


(defun get-head-ref ()
  (or
   ;; This should work when we are processing a pull-request
   (empty-string-to-nil
    (uiop:getenv "GITHUB_HEAD_REF"))
   ;; And this one for pushes to a branch
   (let ((full-ref (empty-string-to-nil
                    (uiop:getenv "GITHUB_REF")))
         (prefix "refs/heads/"))
     (when (and full-ref
                (search prefix full-ref))
       (subseq full-ref
               (length prefix))))))


(defun push-local-changes ()
  "Some documentation builders, like MGL-PAX or 40ANTS-DOC
   can update README file as well. In this case, we need
   to push the file into the current branch of the repository."
  (let ((*current-dir* (probe-file #P"")))
    (macrolet ((if-there-are-changes (&body body)
                 `(cond
                    ((git-repository-was-changed-p)
                     (log:info "Pushing local changes to the repository")
                     ,@body)
                    (t
                     (log:info "There is no local changes.")))))
      (flet ((make-commit ()
               (git "add -u")

               ;; We don't want to commit changes to qlfile,
               ;; because documentation builders might change them:
               (git "reset -- qlfile*")

               ;; If a project can change github workflows
               ;; during the build, like https://github.com/40ants/ci
               ;; does, then we need to reset it, because
               ;; GitHub prohibits workflow changes from the action.
               (git "reset -- .github/workflows")
                 
               (when (uiop:getenv "GITHUB_ACTIONS")

                 (git "config --global user.name \"github-actions[bot]\"")
                 (git "config --global user.email \"actions@github.com\""))
                 
               (git "commit -m 'Update docs'")))
        (let ((head-ref (get-head-ref)))
          (cond
            ((and head-ref
                  ;; For push events GITHUB_HEAD_REF env variable
                  ;; can be present but set to an empty string.
                  (not (string= head-ref "")))
             ;; Inside github action we are running on
             ;; detached commit. Github takes last commit
             ;; from the "master" branch and merges
             ;; a branch from pull-request settings.
             ;;
             ;; To push changes back, we need to change
             ;; our HEAD back to the pull-request's reference:
             (git "checkout " head-ref)
             ;; Here we need to check again if
             (if-there-are-changes
              (make-commit)
              (git "remote add upstream "
                   (get-origin-to-push))
              (git "push upstream HEAD:" head-ref)))
            (t
             (if-there-are-changes
              (make-commit)
              (git "push"))))))))
  (values))


(defun main (&rest argv)
  (let ((event-name (uiop:getenv "GITHUB_EVENT_NAME")))
    (when (and event-name
               (string-equal event-name "pull_request"))
      ;; We don't want to upload docs when they are built in pull requests.
      ;; Only push to master branch should lead to documentation update.

      (log:info "Skipping upload because action is used on pull_request.")
      (uiop:quit 0)))
  
  (log:info "Uploading documentation")

  (unless argv
    (log:error "Please, specify a directory with HTML docs.")
    (uiop:quit 1))

  (let ((docs-dir (uiop:parse-unix-namestring (first argv)
                                              :ensure-directory t)))

    (handler-bind ((error (lambda (condition)
                            (uiop:print-condition-backtrace condition :stream *error-output*)
                            (uiop:quit 1))))
      (unless (probe-file docs-dir)
        (log:error "Directory \"~A not found"
                   docs-dir)
        (uiop:quit 1))
      
      (uiop:with-output-file (s (uiop:merge-pathnames* #P".nojekyll"
                                                       docs-dir)
                                :if-exists :overwrite)
        (declare (ignorable s)))
      
      (unless (string= (or (uiop:getenv "NGROK_AUTH_TOKEN")
                           ;; If var is not given, uiop will return NIL,
                           ;; but inside github action, not required arguments
                           ;; are empty strings and env var will be empty string.
                           "")
                       "")
        (let ((url (ngrok/slynk:start 4005)))
          (when url
            (log:info "Waiting for connection to ~A" url)
            (log:info "do touch ~~/continue to let process continue" )
            (loop
              until (probe-file "~/continue")
              do (sleep 5)))))
      
      (push-gh-pages docs-dir)
      (push-local-changes))))