4 files changed, 200 insertions(+), 0 deletions(-)

A .gitignore
A README.org
A main.scm
A make-vm.scm

@@ 1,2 @@
+output/
+vm/<
\ No newline at end of file

@@ 1,12 @@
+* guix-images
+
+Quick and dirty script to generate lots of guix qcow2 images.
+
+The examples are in main.scm you can feed it a os.scm definition or utilize
+make-vm routine to create vms dynamically.
+
+* Usage
+
+#+begin_src sh
+  guile -L . main.scm
+#+end_src

@@ 1,12 @@
+(use-modules (make-vm))
+
+(define mail
+  (make-vm #:config-path "vm/mail.scm" #:no-os #t #:host-name "mail"))
+
+(define web
+  (let ((host-name "web")
+	(service-modules '(web))
+	(services '((service nginx-service-type))))
+  (make-vm #:host-name host-name
+	   #:services (base-services services)
+	   #:service-modules (base-service-modules service-modules))))

@@ 1,174 @@
+(define-module (make-vm)
+  #:use-module (srfi srfi-1)
+  #:use-module (guix build utils)
+  #:use-module (ice-9 popen)
+  #:use-module (ice-9 rdelim)
+  #:export (base-modules
+	    base-service-modules
+	    base-packages-modules
+	    base-bootloader
+	    base-host-name
+	    base-file-systems
+	    base-users
+	    base-packages
+	    base-services
+
+	    make-os
+	    make-tmp-config
+	    make-vm))
+
+(define* (base-modules #:optional extra-modules)
+  `(use-modules (gnu) ,@(if extra-modules extra-modules '())))
+
+(define* (base-service-modules #:optional extra-services)
+  `(use-service-modules networking ssh admin virtualization sysctl ,@(if extra-services extra-services '())))
+
+(define* (base-packages-modules #:optional extra-packages)
+  `(use-package-modules bootloaders ssh certs tls python ,@(if extra-packages extra-packages '())))
+
+(define* (base-bootloader #:optional extra-targets)
+  `(bootloader-configuration
+    (bootloader grub-bootloader)
+    (targets (list "/dev/vda" ,@(if extra-targets extra-targets '())))
+    (terminal-outputs '(console))))
+
+(define* (base-users #:optional extra-users)
+  `(cons* (user-account
+	   (name "user")
+	   (comment "user")
+	   (group "users")
+	   (supplementary-groups '("wheel"))
+	   (home-directory "/home/user"))
+	  ,@(if extra-users extra-users '())
+	  %base-user-accounts))
+
+(define* (base-file-systems #:optional extra-file-systems)
+  `(cons* (file-system
+	   (mount-point "/")
+	   (device "/dev/vda2")
+	   (type "ext4"))
+	  ,@(if extra-file-systems extra-file-systems '())
+	  %base-file-systems))
+
+(define* (base-sudoers #:optional extra-sudoers)
+  `(plain-file "sudoers" "\\
+root ALL=(ALL) ALL
+%wheel ALL=(ALL) NOPASSWD: ALL
+"))
+
+(define* (base-services #:optional extra-services)
+  `(append (list (service dhcp-client-service-type)
+		 (service unattended-upgrade-service-type)
+		 (service qemu-guest-agent-service-type)
+		 (service openssh-service-type
+			  (openssh-configuration
+			   (openssh openssh-sans-x)
+			   (permit-root-login #f)
+			   (authorized-keys
+			    `(("user" ,(plain-file "" ""))))))
+		 ,@(if extra-services extra-services '()))
+	   (modify-services %base-services
+			    (sysctl-service-type config =>
+						 (sysctl-configuration
+						  (settings (append '(("net.ipv6.conf.all.autoconf" . "0")
+								      ("net.ipv6.conf.all.accept_ra" . "0")
+								      ("net.ipv6.conf.all.disable_ipv6" . "1")
+								      ("net.ipv6.conf.default.disable_ipv6" . "1")
+								      ("net.ipv6.conf.lo.disable_ipv6" . "1"))
+								    %default-sysctl-settings)))))))
+
+(define* (base-packages #:optional extra-packages)
+  `(cons* nss-certs gnutls python ,@(if extra-packages extra-packages '()) %base-packages))
+
+(define* (make-os modules
+		  service-modules
+		  packages-modules
+		  extra-content
+		  bootloader
+		  host-name
+		  sudoers
+		  file-systems
+		  users
+		  packages
+		  services)
+  `(,modules
+    ,service-modules
+    ,packages-modules
+    ,@extra-content
+    (operating-system
+     (bootloader ,bootloader)
+     (host-name ,host-name)
+     (sudoers-file ,sudoers)
+     (timezone "Etc/UTC")
+     (kernel-arguments (list "console=ttyS0,115200"))
+     (file-systems ,file-systems)
+     (users ,users)
+     (packages ,packages)
+     (services ,services))))
+
+(define (make-tmp-config tmp-file config)
+  (let ((config-str (fold
+		     (lambda (sexp acc)
+		       (string-append acc (format #f "~a" sexp) "\n\n")) "" config)))
+    (call-with-output-file tmp-file
+      (lambda (p)
+	(set-port-encoding! p "UTF-8")
+	(display config-str p)))))
+
+(define (escape-strings obj)
+  (cond
+   ((pair? obj) (cons (escape-strings (car obj)) (escape-strings (cdr obj))))
+   ((and (list? obj) (not (null? obj))) (map (lambda (obj)
+					       (escape-strings obj))
+					     obj))
+   ((string? obj) (string-append "\"" obj "\""))
+   (else obj)))
+
+(define* (make-vm #:key
+		  (config-path #f)
+		  (no-os #f)
+		  (modules (base-modules))
+		  (service-modules (base-service-modules))
+		  (packages-modules (base-packages-modules))
+		  (extra-content '())
+		  (bootloader (base-bootloader))
+		  host-name
+		  (sudoers (base-sudoers))
+		  (file-systems (base-file-systems))
+		  (users (base-users))
+		  (packages (base-packages))
+		  (services (base-services)))
+
+  (let* ((os (if no-os
+		 #f
+		 (make-os modules
+			  service-modules
+			  packages-modules
+			  extra-content
+			  bootloader
+			  host-name
+			  sudoers
+			  file-systems
+			  users
+			  packages
+			  services)))
+	 (tmp-file (string-append "/tmp/" (if no-os "" host-name))))
+
+    (unless no-os
+      (make-tmp-config tmp-file (map escape-strings os)))
+
+    (let* ((port (open-input-pipe (string-join `("guix"
+						 "system"
+						 "image"
+						 "--image-type=qcow2"
+						 "--save-provenance"
+						 "--image-size=10737418240" ;; 10gb
+						 "--"
+						 ,(if no-os config-path tmp-file))
+					       " ")))
+	   (image-path (read-line port))
+	   (output-img (string-append "output/" host-name ".qcow2")))
+      (close-pipe port)
+      (if (file-exists? "output") #f (mkdir "output"))
+      (copy-file image-path output-img)
+      (chmod output-img #o644))))