setup-lisp/docs/scripts/build.ros
2021-02-06 12:41:50 +03:00

163 lines
5.1 KiB
Common Lisp
Executable file

#!/bin/sh
#|-*- mode:lisp -*-|#
#| <Put a one-line description here>
exec ros -Q -- $0 "$@"
|#
(progn ;;init forms
(ros:ensure-asdf)
#+quicklisp
(ql:quickload '(log4cl
example-docs)
:silent t))
(defpackage :script.build-docs
(:use :cl))
(in-package :script.build-docs)
(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 build-docs ()
(log:info "Building documentation in ./docs/")
(example-docs:build-docs)
(uiop:with-output-file (s "docs/build/.nojekyll" :if-exists :overwrite)
(declare (ignorable s))))
(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."
(let ((directory "docs/build/"))
(uiop:with-current-directory (directory)
(let ((command (apply #'concatenate 'string
"git "
commands)))
(log:info "Running" command "in" directory)
(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 ()
(log:info "Pushing changes to gh-pages branch")
(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)
(declare (ignorable argv))
(log:config :debug)
(log:info "Building documentation")
(handler-bind ((error (lambda (condition)
(uiop:print-condition-backtrace condition :stream *error-output*)
(uiop:quit 1))))
(build-docs)
(push-gh-pages)))