Adds the deploy command

Author: ralt

src/cli.lisp

@@ -20,6 +20,7 @@
 (defvar *ip-regex* "^(\\d+)\\.(\\d+)\\.(\\d+)\\.(\\d+)")
 (defvar *lxc-interfaces-file* #p"etc/network/interfaces")
 (defvar *lxc-package-extension* ".tar.gz")
+(defvar *lxc-config* #p"config")
 
 (defmacro defcommand (name args &body body)
   `(progn
@@ -57,6 +58,7 @@
 				*hosts-file*
 				*lxc-interfaces-file*
 				*lxc-package-extension*
+				*lxc-config*
 				*default-shell*)
 	  (if command
 	      (funcall (gethash (string-upcase command) *commands*) name (cdr parsed-args))

src/lxc-wrapper.lisp

@@ -13,7 +13,7 @@
 (defcommand create (name args)
   "Creates an LXC"
   (destructuring-bind (&key base template)
-      (car args)
+      args
     (if base
 	(create-clone base name)
 	(create-base name template))))
@@ -22,37 +22,45 @@
   "Creates a clone of another LXC"
   (let ((cli-base (adapt-arg base))
 	(cli-name (adapt-arg name)))
+    (format t "Cloning ~A..." cli-base)
     (run
       "lxc-clone"
       "--orig" cli-base
       "--new" cli-name)
+    (format t " done.~%")
     (init-lxc cli-name *hosts-file*)))
 
 (defun create-base (name template)
   "Creates an LXC from no base"
   (let ((cli-name (adapt-arg name))
 	(cli-template (adapt-arg template)))
+    (format t "Creating ~A..." cli-name)
     (run
       "lxc-create"
       "--name" cli-name
       "-t" cli-template)
+    (format t " done.~%")
     (init-lxc cli-name *hosts-file*)))
 
 (defcommand start (name &rest args)
   "Starts an LXC"
   (declare (ignore args))
   (let ((cli-name (adapt-arg name)))
+    (format t "Starting ~A..." cli-name)
     (run
       "lxc-start"
-      "--name" cli-name)))
+      "--name" cli-name)
+    (format t " done.~%")))
 
 (defcommand stop (name &rest args)
   "Stops an LXC"
   (declare (ignore args))
   (let ((cli-name (adapt-arg name)))
+    (format t "Stopping ~A..." cli-name)
     (run
       "lxc-stop"
-      "--name" cli-name)))
+      "--name" cli-name)
+    (format t " done.~%")))
 
 (defcommand ls (&rest args)
   "Lists all the LXC"
@@ -65,10 +73,14 @@
   "Destroys an LXC and its leftovers"
   (declare (ignore args))
   (let ((cli-name (adapt-arg name)))
+    (format t "Destroying ~A..." cli-name)
     (run
       "lxc-destroy"
       "--name" cli-name)
-    (remove-lxc-leftovers cli-name)))
+    (format t " done.~%")
+    (format t "Removing leftovers...")
+    (remove-lxc-leftovers cli-name)
+    (format t " done.~%")))
 
 (defcommand package (name &rest args)
   "Packages an LXC"
@@ -86,6 +98,23 @@
       ".")
     (format t "Created ~A~%" archive)))
 
+(defcommand deploy (name args)
+  "Deploys an archive created by lxc-wrapper"
+  (let* ((cli-name (adapt-arg name))
+	 (lxc-path (merge-pathnames (concatenate 'string cli-name "/")
+				    *lxc-default-folder*)))
+    (destructuring-bind (&key archive)
+	args
+      (run
+	"mkdir" "-p" lxc-path)
+      (format t "Deploying ~A..." cli-name)
+      (run
+	"tar"
+	"xf" archive
+	"-C" lxc-path)
+      (fix-lxc-config cli-name lxc-path *lxc-config*)
+      (format t " done.~%")
+      (init-lxc cli-name *hosts-file*))))
 (defun adapt-arg (name)
   "Adapts an argument to string"
   (when (symbolp name)

src/lxc.lisp

@@ -6,14 +6,16 @@
 - Adding the static IP to the host's /etc/hosts
 - Making a symlink to the rootfs somewhere
 - Making the container directory readable by all"
+  (format t "Initializing ~A..." name)
   (let ((ip (next-ip file))
 	(lxc-path (merge-pathnames (concatenate 'string name "/")
 				   *lxc-default-folder*)))
     (assign-static-ip name ip *lxc-gateway* *default-dns-nameserver*)
     (add-ip *hosts-file* ip (concatenate 'string name *lxc-host-extension*))
     (make-lxc-symlink (merge-pathnames *lxc-rootfs* lxc-path)
 		      (merge-pathnames name *lxc-folder*))
-    (fix-permissions lxc-path)))
+    (fix-permissions lxc-path))
+  (format t " done.~%"))
 
 (defun fix-permissions (path)
   "Makes the folder readable by all"
@@ -36,3 +38,22 @@
   "Deletes a file if it exists"
   (when (probe-file file)
     (delete-file file)))
+
+(defun fix-lxc-config (name lxc-path config)
+  "Fixes the config of a newly deployed container"
+  (let* ((config-path (merge-pathnames config lxc-path))
+	 (config-string (alexandria:read-file-into-string config-path))
+	 (base-name (get-base-lxc-name config-string)))
+    (alexandria:write-string-into-file
+     (cl-ppcre:regex-replace-all base-name
+				 config-string
+				 name)
+     config-path
+     :if-exists :overwrite)))
+
+(defun get-base-lxc-name (config)
+  "Gets the name of the base lxc"
+  (multiple-value-bind (match name)
+      (cl-ppcre:scan-to-strings "\\n\\s*lxc\\.utsname\\s*=\\s*(\\w+)" config)
+    (declare (ignore match))
+    (elt name 0)))