~tieong/guix-images

bfeed5071a3611944a8c95a7094d39172c608fc8 — Thomas Ieong 11 months ago
Init
4 files changed, 200 insertions(+), 0 deletions(-)

A .gitignore
A README.org
A main.scm
A make-vm.scm
A  => .gitignore +2 -0
@@ 1,2 @@
output/
vm/
\ No newline at end of file

A  => README.org +12 -0
@@ 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

A  => main.scm +12 -0
@@ 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))))

A  => make-vm.scm +174 -0
@@ 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))))