build-docs.ros

#!/bin/sh
#|-*- mode:lisp -*-|#
#| <Put a one-line description here>
exec ros -Q -- $0 "$@"
|#
(progn ;;init forms
  (ros:ensure-asdf)
  #+quicklisp
  (ql:quickload '(log4cl)
                :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) (directory "./"))
  "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``."

  (log:info "Running" command "in" directory)
  
  (multiple-value-bind (stdout stderr code)
      (uiop:with-current-directory (directory)
        (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/")
  
  (uiop:with-current-directory ("./docs/")
    (run "make html")))


(defun gh-pages-repository-initialized-p ()
  "Checks if repository for documentation already initialized"
  (uiop:directory-exists-p "docs/build/html/.git"))


(defun git (command &key raise)
  "Calls git command in gh-pages repository."
  (let ((command (concatenate 'string
                              "git "
                              command)))
        
    (run command
         :raise raise
         :directory "docs/build/html/")))


(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 (git "rev-parse --abbrev-ref --symbolic-full-name @{u}" :raise nil)))
    (when (> (length upstream)
           0)
      (subseq upstream
              0
              (search "/" upstream)))))


(defun get-repo-slug ()
  (let ((result (or (uiop:getenv "TRAVIS_REPO_SLUG")
                    (when (uiop:getenv "CIRCLE_PROJECT_REPONAME")
                      (format nil "~A/~A"
                              (uiop:getenv "CIRCLE_PROJECT_USERNAME")
                              (uiop:getenv "CIRCLE_PROJECT_REPONAME"))))))
    (unless result
      (error 'unable-to-proceed
             :message "There is no TRAVIS_REPO_SLUG or CIRCLE_PROJECT_REPONAME env variables. Where to push gh-pages branch?"))
    result))


(defun get-repo-token ()
  (let ((result (uiop:getenv "GH_REPO_TOKEN")))
    (unless result
      (error 'unable-to-proceed
             :message "There is no GH_REPO_TOKEN env variable. Get this token here: https://github.com/settings/tokens"))
    result))


(defun get-remote-url (upstream)
  ;; Previously it was:
  ;; (run (concatenate 'string "git remote get-url " upstream))
  ;; but get-url is only supported in git >= 2.7
  ;; and it is absent in my base lisp image:
  ;; https://github.com/40ants/base-lisp-image/blob/master/Dockerfile
  ;; because it uses Ubuntu 14.04
  (run (format nil "git remote --verbose | grep '~A.*fetch' | awk '{print $2}'"
               upstream)))


(defun get-origin-to-push ()
  (let ((upstream (get-git-upstream)))
    (if upstream
        ;; If there is already some remote upstream, then use it
        (get-remote-url upstream)
        ;; otherwise make it from travis secret token and repo slug
        (format nil "https://~A@github.com/~A"
                (get-repo-token)
                (get-repo-slug)))))


(defun push-gh-pages (branch)
  (log:info "Pushing changes to remote branch" branch)
  
  (unless (gh-pages-repository-initialized-p)
    (git "init")
    
    (git (concatenate 'string
                      "remote add origin "
                      (get-origin-to-push))))

  (git "add .")
  
  (cond
   ((git-repository-was-changed-p)
    (git "config --global user.email \"svetlyak.40wt@gmail.com\"")
    (git "config --global user.name \"Alexander Artemenko\"")
    (git "commit -m 'Update docs'")
    
    (git (format nil "push --force origin master:~A" branch)))
   ;; 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)
    
    (let ((branch (second (member "--push-to"
                                  argv
                                  :test #'string-equal)))
          (on-master
           (or (and (string-equal (uiop:getenv "TRAVIS_BRANCH")
                                  "master")
                    (string-equal (uiop:getenv "TRAVIS_PULL_REQUEST")
                                  "false"))
               (and (string-equal (uiop:getenv "CIRCLE_BRANCH")
                                  "master")
                    (null (uiop:getenv "CIRCLE_PULL_REQUEST"))))))
      (when (and on-master branch)
        (push-gh-pages branch)))))