path: root/Biz/Serval.scm

;;
;; 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 (Biz 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 ((Alpha Core)
                #:select (second rest fmt prn first comment))
  #:use-module ((Alpha Test)
                #:select (testing))
  #:use-module ((Alpha 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) "Biz/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))))