diff --git a/.github/actions/build-docs/action.yml b/.github/actions/build-docs/action.yml index e17301d..1d24020 100644 --- a/.github/actions/build-docs/action.yml +++ b/.github/actions/build-docs/action.yml @@ -24,12 +24,16 @@ runs: echo ::endgroup:: - name: Build Docs + id: build-docs shell: bash run: | - set -x - ls .qlot - ls .qlot/bin - echo $PATH - cat qlfile - - build-docs ${{ inputs.asdf-system }} + OUTPUT_DIR=$(build-docs ${{ inputs.asdf-system }}) + + echo "::set-output name=build-dir::${OUTPUT_DIR}" + + - name: Upload Docs + shell: bash + run: | + BUILD_DIR=${{ steps.build-docs.outputs.build-dir }} + + ${{ github.action_path }}/upload.ros "${BUILD_DIR}" diff --git a/.github/actions/build-docs/upload.ros b/.github/actions/build-docs/upload.ros new file mode 100755 index 0000000..ce34c5c --- /dev/null +++ b/.github/actions/build-docs/upload.ros @@ -0,0 +1,170 @@ +#!/bin/sh +#|-*- mode:lisp -*-|# +#| +exec ros -Q -- $0 "$@" +|# +(progn ;;init forms + (ros:ensure-asdf) + #+quicklisp(ql:quickload '() :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 ~]~@[ and this text at stderr:~% ~S~]" + (uiop:subprocess-error-process condition) + (uiop:subprocess-error-command condition) + (uiop:subprocess-error-code 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 () + "Checks if repository for documentation already initialized" + (uiop:directory-exists-p "docs/build/.git")) + + +(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" path) + (run command)))) + + +(defun git-repository-was-changed-p () + ;; if git status returns something, then repository have uncommitted changes + (> (length (git "status --porcelain")) + 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 () + (let ((upstream (get-git-upstream))) + + (cond + (upstream + ;; If there is already some remote upstream, then use it + (run (concatenate 'string "git remote get-url " upstream))) + ;; 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 + (t + (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)))))) + + +(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) + (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."))))) + + +(defun main (&rest argv) + (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))) + (push-gh-pages docs-dir)))) + +;;; vim: set ft=lisp lisp: