Added upload script.

.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}"

.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: