From 7d38d7a8c15f9e8d61834b5fd05182addaf6c56e Mon Sep 17 00:00:00 2001 From: Ben Sima 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 - kit state (serialized s-expr) +;; /var/lib/serval// - root directory for the kit +;; /nix/var/nix/profiles/per-kit/ - symlink to cfg in /nix/store +;; +;; TODO +;; - save-kit function (write kit to /var/lib/serval/.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 --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