Add serval

5 files changed, 221 insertions, 0 deletions

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
index 8c88cb7..8c88cb7 100644..100755
--- a/Com/Simatime/Serval/hardware.nix
+++ b/Com/Simatime/Serval/hardware.nix
diff --git a/Com/Simatime/Serval/networking.nix b/Com/Simatime/Serval/networking.nix
index e13a6f5..e13a6f5 100644..100755
--- a/Com/Simatime/Serval/networking.nix
+++ b/Com/Simatime/Serval/networking.nix
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) ...))))