Merge pull request #190 from equwal/more-versioning

Git versioned plugin

docs/plugin-use.md

@@ -212,7 +212,24 @@ CL-USER> (chirp:complete-authentication "4173325")
 
 **Example**: `(twitter-summary-card :twitter-handle "@redline6561")
 
-## Versioned Deploys
+## Versioning Deploys
+
+Either [automatic git interaction](#git-versioned) or [double
+versioning](#double-versioning)
+
+### Git Versioned
+
+**Description**: Automatically stages, commits, and/or pushes the server's
+sources. Assumes that a git repository exists in the server's directory. Pushing
+is optional.
+
+**Examples**: 
+`(git-versioned "~/src/dir/" 'stage 'commit 'push)`
+
+
+`(git-versioned "~/src/dir/" 'stage 'commit)`
+
+### Double Versioning
 
 **Description**: Originally, this was Coleslaw's only deploy behavior.
   Instead of deploying directly to `:deploy-dir`, creates `.curr` and

plugins/git-versioned.lisp

@@ -0,0 +1,46 @@
+(defpackage :coleslaw-git-versioned
+  (:use :cl)
+  (:import-from :coleslaw
+                #:*config*
+                #:run-lines)
+  (:import-from :uiop #:ensure-directory-pathname))
+
+(in-package :coleslaw-git-versioned)
+
+(defconstant +nothing-to-commit+ 1
+  "Error code when git-commit has nothing staged to commit.")
+
+;; These have their symbol-functions set in order to close over the src-dir
+;; variable.
+(defun git-versioned ()
+  "Run all git commands as specified in the .coleslawrc.")
+(defun command (args)
+  "Automatically git commit and push the blog to remote."
+  (declare (ignore args)))
+
+(defun enable (src-dir &rest commands)
+  "Define git-versioned functions at runtime."
+  (setf (symbol-function 'git-versioned)
+        (lambda ()
+          (loop for fsym in commands
+                do (funcall (symbol-function (intern (symbol-name fsym)
+                                                     :coleslaw-git-versioned))))))
+  (setf (symbol-function 'command)
+        (lambda (args)
+          (run-lines src-dir
+                     (format nil "git ~A" args)))))
+(defmethod coleslaw:deploy :before (staging)
+  (declare (ignore staging))
+  (git-versioned))
+
+(defun stage () (command "stage -A"))
+(defun commit (&optional (commit-message "Automatic commit."))
+  (handler-case (command (format nil "commit -m '~A'" commit-message))
+    (uiop/run-program:subprocess-error (error)
+      (case (uiop/run-program:subprocess-error-code error)
+        (+nothing-to-commit+ (format t "Nothing to commit. Error ~d"
+                                     +nothing-to-commit+))
+        (otherwise (error error))))))
+
+(defun upload ()
+  (command "push"))

src/util.lisp

@@ -100,6 +100,12 @@ If ARGS is provided, use (fmt path args) as the value of PATH."
 use (fmt program args) as the value of PROGRAM."
   (inferior-shell:run (fmt program args) :show t))
 
+(defun run-lines (dir &rest programs)
+  "Runs some programs, in a directory."
+  (mapc (lambda (line)
+          (run-program "cd ~A && ~A" dir line))
+        programs))
+
 (defun take-up-to (n seq)
   "Take elements from SEQ until all elements or N have been taken."
   (subseq seq 0 (min (length seq) n)))