From 7d38d7a8c15f9e8d61834b5fd05182addaf6c56e Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Sat, 23 Nov 2019 15:05:55 -0800
Subject: Add serval
---
Com/Simatime/Serval.scm | 194 +++++++++++++++++++++++++++++++++++++
Com/Simatime/Serval/Test.scm | 11 +++
Com/Simatime/Serval/hardware.nix | 0
Com/Simatime/Serval/networking.nix | 0
Com/Simatime/Test.scm | 16 +++
serval | 5 +
6 files changed, 226 insertions(+)
create mode 100644 Com/Simatime/Serval.scm
create mode 100644 Com/Simatime/Serval/Test.scm
mode change 100644 => 100755 Com/Simatime/Serval/hardware.nix
mode change 100644 => 100755 Com/Simatime/Serval/networking.nix
create mode 100644 Com/Simatime/Test.scm
create mode 100755 serval
diff --git a/Com/Simatime/Serval.scm b/Com/Simatime/Serval.scm
new file mode 100644
index 0000000..81f5e13
--- /dev/null
+++ b/Com/Simatime/Serval.scm
@@ -0,0 +1,194 @@
+;;
+;; Serval - fast container management
+;;
+;; `Container management' simply refers to tracking the configuration
+;; for individual containers and their running state.
+;;
+;; Serval stores container configuration in a directory, which forms the
+;; database. Each container is associated with a `.kit' file, which is a
+;; serialized s-expr of a `@Kit' record type.
+;;
+;; Runtime state is offloaded to systemd, and certain commands simply
+;; reach out to `systemctl' and `machinectl' for this functionality.
+;;
+;; Serval does not concern itself with deployment. For that, use `nix copy'.
+;;
+;; Currently Serval only supports a single physical machine: if we want
+;; to cluster containers across machines, we must find a way to store
+;; and reason about the host in addition to the container. This might
+;; mean absorbing some functionality that systemd currently performs for
+;; us.
+;;
+;; FILES
+;;
+;; /var/lib/serval/<kit-name>.kit - kit state (serialized s-expr)
+;; /var/lib/serval/<kit-name>/ - root directory for the kit
+;; /nix/var/nix/profiles/per-kit/<kit-name> - symlink to cfg in /nix/store
+;;
+;; TODO
+;; - save-kit function (write kit to /var/lib/serval/<name>.kit)
+;; - profiles in /nix/var/nix/profiles/per-kit
+;; - each of the below commented functions for state manipulation
+;;
+(define-module (Com Simatime Serval)
+ #:use-module ((ice-9 getopt-long))
+ #:use-module ((ice-9 match)
+ #:select (match))
+ #:use-module ((srfi srfi-9)
+ #:select (define-record-type))
+ #:use-module ((Com Simatime Core)
+ #:select (second rest fmt prn first comment nil))
+ #:use-module ((Com Simatime Test)
+ #:select (testing))
+ #:use-module ((Com Simatime Shell) #:prefix Shell.)
+ #:export (main))
+
+(define *data-dir* "/var/lib/serval")
+(define *nix-profiles-dir* "/nix/var/nix/profiles")
+
+;; TODO: I would really like a better command line parser...
+;; getopt-long sucks
+(define (main args)
+ ;; pop first arg if its the executable
+ (let* ([args (if (equal? (first args) "Com/Simatime/Serval.scm")
+ (rest args)
+ args)]
+ [cmd (first args)])
+ (match cmd
+ ["new" (new-kit! args)]
+ ["del" (del-kit! args)]
+ ["start" (start-kit! args)]
+ ["stop" (stop-kit! args)]
+ ["scale" (prn "TODO: scale running kits")]
+ ["ssh" (run-in-kit! args)]
+ ["info" (prn "TODO: show kit")]
+ ["ls" ("TODO: list available kits")]
+ [else (prn "help")])))
+
+(define-record-type @Kit
+ (Kit name nix-path system-path host-address
+ host-port local-address auto-start)
+ kit?
+ ;; a unique name for this kit
+ (name kit-name)
+ ;; location in the nix store
+ (nix-path get-nix-path set-nix-path!)
+ ;; this is like /etc/nixos/conf.nix in NixOS proper. At
+ ;; initialization, this is just `/var/lib/serval/$kit'. Afterwards,
+ ;; it's `/nix/var/nix/profiles/per-kit/$kit'.
+ (system-path get-system-path set-system-path!)
+ ;; host IP
+ (host-address get-host-address set-host-address!)
+ ;; host port
+ (host-port get-host-port set-host-port!)
+ ;; the private IP
+ (local-address get-local-address set-local-address!)
+ ;; should this kit start when the host starts?
+ (auto-start get-auto-start set-auto-start!))
+
+(define-syntax for
+ (syntax-rules ()
+ ((_ a b) (map b a))
+ ((_ a ... b) (map b a ...))))
+
+(define (zip a b)
+ "Combine a and b into a single list of pairs."
+ ;; TODO: zip-list, zip-with, in Core
+ (apply map cons (list a b)))
+
+(define (serialize kit)
+ "Turns a kit into an association list."
+ (let* ((fields (record-type-fields @Kit))
+ (values (for fields
+ (lambda (field) ((record-accessor @Kit field) kit)))))
+ (zip fields values)))
+
+(define (deserialize alist)
+ "Creates a @Kit from an association list."
+ (apply Kit (map rest alist)))
+
+(define (save-kit! kit)
+ (call-with-output-file (fmt "~a/~a.kit" *data-dir* (kit-name kit))
+ (lambda (a) (write (serialize kit) a))))
+
+(define (load-kit! kit-name)
+ (call-with-input-file (fmt "~a/~a.kit" *data-dir* kit-name)
+ (lambda (a) (deserialize (read a)))))
+
+;; TODO
+(define (find-available-address)
+ "10.233.0.1")
+
+;; top-level commands, each take an argstr
+
+(define (setup!)
+ "Initial setup, only need to run once."
+ (Shell.exec (fmt "mkdir -p ~a" *nix-profiles-dir*))
+ (Shell.exec (fmt "mkdir -p ~a" *data-dir*)))
+
+(define (new-kit! args)
+ "Creates a new kit:
+1. first arg is name
+2. second arg is nix-path
+3. rest args parsed by getopt-long
+
+TODO: ensure kit-name is unique
+"
+ (let* ([name (first args)]
+ [nix-path (second args)]
+ [option-spec '((auto-start (single-char #\a) (value #f)))]
+ [options (getopt-long args option-spec)]
+ [auto-start (option-ref options 'auto-start #f)]
+ [local-address (find-available-address)]
+ [kit (Kit name nix-path "fixme-system-path" "fixme-host-address"
+ "fixme-host-port" local-address auto-start)])
+ (save-kit! kit)
+ (prn ;; Shell.exec
+ (fmt "nix-env -p ~a/per-kit/system --set ~a"
+ *nix-profiles-dir* (get-system-path kit)))
+ kit))
+
+(define (del-kit! args)
+ (let ([name (first args)])
+ (Shell.exec (fmt "rm ~a/~a" *data-dir* name))))
+
+(define (list-kits)
+ (Shell.exec (fmt "ls ~a" *data-dir*)))
+
+(define (update-kit! args)
+ ;; TODO: load kit and update with new config file
+ (let ([kit nil])
+ (Shell.exec
+ (fmt "nix-env -p ~a/system -I nixos-config=~a -f <nixpkgs/nixos> --set -A system"
+ *nix-profiles-dir*
+ (get-system-path nil)))))
+
+(define (run-in-kit! args)
+ (let ([kit nil])
+ (Shell.exec
+ (fmt "systemd-run --machine ~a --pty --quiet -- ~{~a~}"
+ (kit-name kit) args))))
+
+(define (is-kit-running? kit)
+ (Shell.exec
+ (fmt "systemctl show kit@~a" (kit-name kit))))
+
+(define (start-kit! kit)
+ (Shell.exec
+ (fmt "systemctl start kit@~a" (kit-name kit))))
+
+(define (stop-kit! kit)
+ (let* ([force-stop #f]
+ [cmd (if force-stop
+ (fmt "machinectl terminate ~a" (kit-name kit))
+ (fmt "systemctl stop kit@~a" (kit-name kit)))])
+ (Shell.exec cmd)))
+
+(define (restart-kit! kit)
+ (stop-kit! kit)
+ (start-kit! kit))
+
+(define (get-leader kit)
+ "Return the PID of the init process of the kit."
+ (Shell.exec
+ (fmt "machinectl show ~a -p Leader" (kit-name kit))))
diff --git a/Com/Simatime/Serval/Test.scm b/Com/Simatime/Serval/Test.scm
new file mode 100644
index 0000000..44e88c0
--- /dev/null
+++ b/Com/Simatime/Serval/Test.scm
@@ -0,0 +1,11 @@
+(define-module (Com Simatime Serval Test)
+ #:use-module (Com Simatime Serval)
+ #:use-module (Com Simatime core)
+ #:use-module (Com Simatime Test))
+
+(comment
+ ;; TODO: make this a real test
+ (let ((kit (Kit "test-kit" "/nix/path" "/nix/config"
+ "123.456.0.0" 80 "127.0.0.1" #t)))
+ (testing "ser-deser are opposite functions"
+ (equal? kit (deserialize (serialize kit))))))
diff --git a/Com/Simatime/Serval/hardware.nix b/Com/Simatime/Serval/hardware.nix
old mode 100644
new mode 100755
diff --git a/Com/Simatime/Serval/networking.nix b/Com/Simatime/Serval/networking.nix
old mode 100644
new mode 100755
diff --git a/Com/Simatime/Test.scm b/Com/Simatime/Test.scm
new file mode 100644
index 0000000..638940f
--- /dev/null
+++ b/Com/Simatime/Test.scm
@@ -0,0 +1,16 @@
+;; a testing framework for scheme
+;; inspired by clojure.test and srfi-64
+
+(define-module (Com Simatime Test)
+ #:use-module ((Com Simatime core)
+ #:select (prn))
+ #:export (testing))
+
+;; TODO: learn srfi-64
+;; TODO: port over `deftest' et al from clojure
+;; TODO: someday a quickcheck-like would be best
+
+;; simple analog to clojure's `testing'
+(define-syntax testing
+ ((_ description ...)
+ ((begin (prn description) ...))))
diff --git a/serval b/serval
new file mode 100755
index 0000000..74d655e
--- /dev/null
+++ b/serval
@@ -0,0 +1,5 @@
+#!/usr/bin/env bash
+#
+# serval wrapper script
+#
+exec guile -e '(@ (Com Simatime Serval) main)' -s Com/Simatime/Serval.scm "$@"
--
cgit v1.2.3