;; SPDX-License-Identifier: BSD-2-Clause
(macro while
    (lambda (args)
      `(label ((loop (lambda ()
                       ,@(cdr args)
                       (cond (,(car args) (loop))))))
              (cond (,(car args) (loop))))))
(macro if (lambda (args)
            `(cond (,(car args) ,(cadr args))
                   (true ,@(cddr args)))))
(macro when (lambda (args)
              `(cond (,(car args)
                      ,@(cdr args)))))
(defun dolines-until (pred op)
  (let* ((result (getline))
         (line (car result))
         (rv (cadr result)))
    (cond
      ((pred line) true)
      ((> rv 0) (op line)
       (dolines-until pred op))
      ((= rv 0) nil)
      ((< rv 0) nil))))
(defun any (pred lis)
  (cond ((null lis) false)
        ((pred (car lis)) true)
        (true (any pred (cdr lis)))))
(defun mapcars args
  (let ((f (car args))
        (as (cdr args)))
    (label ((map
             (lambda (f as res)
               (cond
                ((any null as) (nreverse res))
                (true (map f (mapcar cdr as)
                           (cons (apply f (mapcar car as)) res)))))))
           (map f as nil))))
(defun zip args (apply mapcars list args))
                 
(defun dolines (fn)
  (dolines-until (lambda (line) false) fn))
(defun getlines ()
  (let ((lines '()))
    (dolines (lambda (line)
               (setq lines (cons line lines))))
    (nreverse lines)))
(defun output-lines-of argv
  (let ((command (apply make-safe-shell-command argv)))
    (with-input-from "|" command
      (prog1
          (getlines)
        (close command)))))
(defun output-of argv
  (apply string-join "\n" (apply output-lines-of argv)))
(defun split-at-first (pred lis)
  (label ((spla (lambda (pred lis first-lis)
                  (cond
                    ((pred (car lis))
                     (list (nreverse first-lis) lis))
                    (true (spla pred
                                (cdr lis)
                                (cons (car lis) first-lis)))))))
         (spla pred lis nil)))
(defun *rooted* (file-path) (if file-path file-path nil))
(defun trim (s) (sub "[[:space:]]*$" "" (sub "^[[:space:]]*" "" s)))
(defun path-join argv
  (gsub "/+" "/" (apply string-join "/" argv)))

;; SPDX-License-Identifier: BSD-2-Clause
;; Probes are pieces of code that find things out about the system
;; under configuration, informing what changes we need.
;; for use by probes, to avoid log confusion
(defun subprobe-output argv
  (apply output-of argv))
(defun probe-output argv
  (with-indent
   (log-probe "output of %s" (repr argv))
   (apply subprobe-output argv)))
;; returns true or false, not an exitcode
(defun subprobe-success argv
  (let ((exitcode (apply system argv)))
    (eq exitcode 0)))
(defun probe-success argv
  (with-indent
   (log-probe "exitcode of %s" (repr argv))
   (apply subprobe-success argv)))
(defun subprobe-sed-crypto-digest (script fp)
  (let* ((command (append (list "sed" "-e" script fp)
                          (pipe-crypto-digest))))
    (apply output-of command)))
;; note: this one roots its file-path!
(defun probe-sed-would-change (script file-path)
  (with-indent
   (log-probe "would %s be changed by sed %s ?" file-path script)
   (let ((fp (*rooted* file-path)))
     (not (equal (crypto-digest fp)
                 (subprobe-sed-crypto-digest script fp))))))
(defun -f (fn)
  (let* ((rv (subprobe-success "/bin/test" "-f" fn)))
    (log-probe "is %s a file? %s" fn (if rv "yes" "no"))
    rv))
(defun -e (fn)
  (let* ((rv (subprobe-success "/bin/test" "-e" fn)))
    (log-probe "does %s exist? %s" fn (if rv "yes" "no"))
    rv))
(defun -d (dn)
  (let* ((rv (subprobe-success "/bin/test" "-d" dn)))
    (log-probe "is %s a directory? %s" dn (if rv "yes" "no"))
    rv))

;; SPDX-License-Identifier: BSD-2-Clause
;; Platform-specific code (shall we say - not specified by POSIX).
;; Until otherwise specified, the platform is assumed to be FreeBSD
;; (base, no third-party packages installed).
;; why sha512t256? "On 64-bit hardware, this algorithm is
;; approximately 50% faster than SHA-256 but with the same level of
;; security..." -- md5(1)
(defun crypto-digests filenames
  (let ((command (append '("sha512t256" "-q") filenames)))
    (or (apply output-lines-of command)
        (error "no output from command %s" (repr command)))))
(defun crypto-digest  (filename)
  (some-output-or-error "sha512t256" "-q" filename))
;; see probe-sed-crypto-digest
(defun pipe-crypto-digest () (list :pipe "sha512t256" "-q"))
;; -r: random (version 4) UUID
(defun get-new-uuid () (some-output-or-error "uuidgen" "-r"))
;; %z: size in bytes (st_size). GNU and Busybox use %s for that, but
;; FreeBSD stat says "bad format" about %s.
(defun get-size-of-file (filename)
  (as-number (some-output-or-error "stat" "-f" "%z" filename)))
;; maybe we could do some other checks on this, but nonempty should
;; suffice to begin with
(defun make-temp-filename-from (based-on-path)
  (some-output-or-error "mktemp" (sprintf "%s.XXXXXXXX" based-on-path)))
(defun get-ogm (source-path)
  ;; The jail has its own set of users, so to get the owner and group
  ;; of a file as names, we have to run stat inside the jail, so it
  ;; will query the right passwd file. (The alternative is to use only
  ;; numeric uids and gids everywhere; but some users and groups are
  ;; just created with the next available id, including some created
  ;; by packages; so you can't know their numeric ids ahead of time.)
  (let ((user (apply some-output-or-error
                     (*run-in-chroot* "stat" "-f" "%Su" source-path)))
        (group (apply some-output-or-error
                      (*run-in-chroot* "stat" "-f" "%Sg" source-path)))
        ;; Lp: "low perms." user, group, and other bits from perms,
        ;; but not file type bits. this will be an octal number; let
        ;; us not treat it as a decimal number.
        (mode (some-output-or-error "stat" "-f" "%Lp" source-path)))
    (list user group mode)))
(defun set-ogm (dest-path user group mode)
  ;; Likewise, in order to consume the right mapping of users to
  ;; numeric uids, we have to run the chown and chmod inside the jail
  ;; and pass the unmodified path.
  (apply system-or-error (*run-in-chroot*
                          "chown" (sprintf "%s:%s" user group) dest-path))
  (apply system-or-error (*run-in-chroot*
                          "chmod" mode dest-path)))
;; for GNU, you could chown --reference and chmod --reference
(defun copy-ogm (source-path dest-path)
  (apply set-ogm dest-path (get-ogm source-path)))

;; SPDX-License-Identifier: BSD-2-Clause
(setq *indent* 0)
(setq *log-tags* '( :info :warning :error :probe :rule :change))
(macro with-indent
       (lambda (args)
         `(let ((oldindent *indent*))
            (setq *indent* (+ *indent* 2))
            (prog1
                (progn ,@args)
              (setq *indent* oldindent)))))
(defun indented-printf args
  (let ((fmt (car args))
        (args (cdr args)))
    (apply printf (sprintf "%%-%ds%s" *indent* fmt) "" args)))
(defun err-ind-printf args
  (with-output-to ">>" "/dev/stderr"
                  (apply indented-printf args)
                  (printf "\n")
                  (fflush)))
(defun log-debug args
  (when (memq :debug *log-tags*)
    (apply err-ind-printf
           (cons (strcat "%s " (car args))
                 (cons "DEBUG " (cdr args))))))
(defun log-info args
  (when (memq :info *log-tags*)
    (apply err-ind-printf
           (cons (strcat "%s " (car args))
                 (cons "INFO  " (cdr args))))))
(defun log-warning args
  (when (memq :warning *log-tags*)
    (apply err-ind-printf
           (cons (strcat "%s " (car args))
                 (cons "WARN  " (cdr args))))))
(defun log-error args
  (when (memq :error *log-tags*)
    (apply err-ind-printf
           (cons (strcat "%s " (car args))
                 (cons "ERROR " (cdr args))))))
(defun log-bucket (file-path meta new-path)
  (err-ind-printf "%s -> %s (meta: %s)\n" file-path new-path meta))
(defun log-probe args
  (when (memq :probe *log-tags*)
    (apply err-ind-printf
           (cons (strcat "%s " (car args))
                 (cons "probe " (cdr args))))))
         
(defun log-rule-start args
  (when (memq :rule *log-tags*)
    (apply err-ind-printf
           (cons (strcat "%s\n%s " (car args))
                 (cons "-----" (cons "rule  " (cdr args)))))))
(defun log-rule-end ()
  (when (memq :rule *log-tags*)
    (err-ind-printf ".....\n")))
(macro with-log-rule
  (lambda (args)
    `(progn
       (log-rule-start ,@(car args))
       (with-indent
        (progn
          ,@(cdr args)))
       (log-rule-end))))
(defun log-change args
  (when (memq :change *log-tags*)
    (apply err-ind-printf
           (cons (strcat "%s " (car args))
                 (cons "CHANGE " (cdr args))))))
;; see the set-x macro
(defun log-command (cmd)
  (err-ind-printf "+ %s" cmd))

(defun use-canned-facts-freebsd-jail (hostname alt-root)
  (setq *fact-short-hostname* hostname)
  (setq *fact-uname-os* "FreeBSD")
  (setq *fact-alt-root* alt-root)
  (setq *rooted* (lambda (pn) (strcat alt-root pn)))
  (setq *run-in-chroot*
        (lambda argv (append (list "chroot" *fact-alt-root*) argv)))
  (log-info "working with alternate root %s" alt-root))
(defun use-this-host ()
  (setq *fact-short-hostname* (output-of "hostname" "-s"))
  (setq *fact-uname-os* (output-of "uname" "-s"))
  (setq *fact-alt-root* nil)
  (setq *rooted* (lambda (pn) pn))
  (setq *run-in-chroot*
        (lambda argv argv))
  (log-info "working on this machine, %s, with the real root"
            *fact-short-hostname*))

;; SPDX-License-Identifier: BSD-2-Clause
(macro set-x (lambda (args)
               `(if (memq :set-x *log-tags*)
                    (let ((ossc *show-system-command*))
                      (setq *show-system-command* log-command)
                      (prog1
                          (progn ,@args)
                        (setq *show-system-command* ossc)))
                  (progn ,@args))))
;;
;; This is something like a distant child of an Either monad and the
;; "set -e" mechanism whereby shells quit when errors happen.
;;
(defun system-or-error args
  (let ((rv (apply system args)))
    (when (not (eq rv 0))
      (error "system with arguments %s returned exitcode %d" (repr args) rv))
    rv))
(defun some-output-or-error args
  (let ((output (apply output-of args)))
    (if (equal "" output)
        (error "command %s returned no output" (repr args))
      output)))

;; SPDX-License-Identifier: BSD-2-Clause
;; Herein, we shall generally use "file-path" to mean a path as
;; written in a rule, e.g. /etc/passwd; and the shorter "fp" to mean
;; that path as accessible during the build process, e.g.
;; /home/jaredj/buildin-ma-jails/jail326/root/etc/passwd.
(defun sed (script file-path)
  (let ((new (make-temp-filename-from file-path))
        (fp (*rooted* file-path))
        (nfp (*rooted* new)))
    (system-or-error "sed" "-e" script fp :gt nfp)
    (copy-ogm file-path new)
    (system-or-error "mv" nfp fp)))
;; e.g.
;; (defun do-a-thing-with-a-file (file-path)
;;   (with-existing-rooted-plain-file-a-rule
;;         (file-path fp)
;;         ("we are doing a thing with file %s" file-path)
;;     (do-thing-with fp))))
;;
;; fp in the above example is *introduced* inside the first argument
;; of w-e-r-p-f-a-r.
(macro with-existing-rooted-plain-file-a-rule
  (lambda (args)
    (let ((file-path-name (caar args))
          (fpname (cadar args))
          (rule-log-args (cadr args))
          (body (cddr args)))
      `(with-log-rule ,rule-log-args
         (let ((,fpname (*rooted* ,file-path-name)))
           (if (-f ,fpname)
               (progn ,@body)
             (log-warning "plain file %s not found. no changes made" ,fpname)))))))
(defun replace-line-in-file (file-path detect-regex replace-line)
  (with-existing-rooted-plain-file-a-rule (file-path fp)
      ("replace-line-in-file: in %s, regex %s -> line %s" file-path detect-regex replace-line)
    (let ((script (sprintf "/%s/c \\\n%s\n" detect-regex replace-line)))
      (if (probe-sed-would-change script file-path)
          (log-info "no change necessary")
        (sed script file-path)))))
;; this only adds to the _end_ of the file, at present
(defun add-line-to-file (file-path line detect-regex)
  (with-existing-rooted-plain-file-a-rule (file-path fp)
      ("add-line-to-file: in %s, add %s" file-path line)
    (let* ((grep-command (if detect-regex
                             (list "grep" detect-regex fp)
                           (list "grep" "-xF" line fp)))
           (output (apply probe-output grep-command))
           (script (sprintf "$a\\\n%s\n" line)))
      (if (null output)
          (sed script file-path)
        (log-info "no change necessary")))))
(defun delete-lines-matching (file-path regex)
  (with-existing-rooted-plain-file-a-rule (file-path fp)
      ("delete-lines-matching: in %s, regex %s" file-path regex)
    (let* ((script (sprintf "/%s/d" regex)))
      (if (probe-sed-would-change script file-path)
          (sed script file-path)
        (log-info "no change necessary")))))
(defun file-exists (file-path owner group mode)
  (with-log-rule ("file-exists: %s, owned by %d:%d, mode %s"
                  file-path owner group mode)
    (let ((fp (*rooted* file-path)))
      (cond
       ((-f fp)
        (if (equal (get-ogm file-path) (list owner group mode))
              (log-info "no change necessary")
            (set-ogm file-path owner group mode)))
       ((-e fp)
        (error "%s exists but is not a plain file" fp))
       (true 
        (system-or-error "touch" fp)
        (set-ogm file-path owner group mode))))))
(defun file-does-not-exist (file-path)
  (with-log-rule ("file-does-not-exist: %s" file-path)
    (let ((fp (*rooted* file-path)))
      (cond
       ((-f fp)
        (system-or-error "rm" fp))
       (true
        (log-info "no change necessary"))))))
(defun dir-exists (dir-path owner group mode)
  (with-log-rule ("dir-exists: %s" dir-path)
    (let ((dp (*rooted* dir-path)))
      (cond
       ((-d dp)
        (if (equal (get-ogm dp) (list owner group mode))
            (log-info "no change necessary")
          (set-ogm dp owner group mode)))
       ((-e dp)
        (error "%s exists but is not a directory" dp))
       (true
        (system-or-error "mkdir" dp)
        (set-ogm dp owner n-group mode))))))
(defun editing-nonexistent-file-error (file-path)
  (error "editing nonexistent file %s. ensure file-exists first" file-path))
(defun file-has-immediate-contents (file-path contents)
  (with-log-rule ("file-has-immediate-contents: %s (contents not shown)"
                  file-path)
    (let ((new (make-temp-filename-from file-path))
          (fp (*rooted* file-path))
          (new-fp (*rooted* new)))
      (if (-f fp)
          (progn
            (with-output-to ">" new-fp (printf "%s" contents))
            (if (equal (crypto-digest fp)
                       (crypto-digest new-fp))
                (progn
                  (log-info "no change necessary")
                  (system "rm" "-f" new-fp))
              (copy-ogm file-path new)
              (system-or-error "mv" new-fp fp)))
        (editing-nonexistent-file-error file-path)))))
(defun file-text-copied-from (dest-file-path src-file-path)
  ;; We're not going to assume the src-file-path has the right perms.
  ;; Also the src-file-path is expected to be outside any chroot.
  (when (not (-f src-file-path))
    (error "source file %s does not exist" src-file-path))
  (with-existing-rooted-plain-file-a-rule (dest-file-path dfp)
      ("file-contents-copied-from: %s <- %s" dest-file-path src-file-path)
    (if (equal (crypto-digest dfp) (crypto-digest src-file-path))
        (log-info "no change necessary")
      (let ((tmp  (make-temp-filename-from dest-file-path))
            (dfp-tmp (*rooted* tmp)))
        (with-input-from "<" src-file-path
          (with-output-to ">" dfp-tmp
            (dolines (lambda (l) (printf "%s\n" l)))))
        (copy-ogm dest-file-path tmp)
        (system-or-error "mv" dfp-tmp dfp)))))
(defun file-contents-from-m4-template (dest tmpl vars)
  (when (not (-f tmpl))
    (error "nonexistent template %s" tmpl))
  (with-existing-rooted-plain-file-a-rule (dest dfp)
      (label
       ((make-dash-D
               (lambda (kv)
                 (let ((k (car kv)) (v (cadr kv)))
                   (sprintf "-D%s:%s" k v)))))
       (let ((ft (make-temp-filename-from "fcfm4t-XXXXXXXX"))
             (rft (*rooted* ft))
             (dash-Ds (mapcar make-dash-D vars)))
         (apply system-or-error `("m4" ,@dash-Ds :gt ,rft))
         (if (equal (crypto-digest rft)
                    (crypto-digest dfp))
             (log-info "no change necessary")
           (copy-ogm dest ft)
           (system-or-error "mv" rft dfp))))))
(defun file-exists-with-entire-contents (file-path o g m desc contents)
  (file-exists file-path o g m)
  (file-has-immediate-contents file-path contents))
(defun local-user-exists (user-name additional-groups)
  (let ((alt-root-addendum
         (if *fact-alt-root* (list "-R" *fact-alt-root*) nil))
        (groups-addendum
         (if additional-groups
             (list "-G" (apply string-join "," additional-groups))
           nil)))
    (if (probe-success "grep" "-q" (sprintf "^%s:" user-name)
                       (*rooted* "/etc/passwd"))
        (log-info "no change necessary")
      (apply system-or-error `("pw" ,@alt-root-addendum
                               "useradd" "-n" ,user-name "-m"
                               ,@group-addendum)))))
(defun package-installed (name pkg-opts)
  (let* ((pkg-opts (if *fact-alt-root*
                       (append (list "-r" *fact-alt-root*) pkg-opts)
                     pkg-opts))
         (installed (apply probe-success `("pkg" ,@pkg-opts
                                           "info" "-e" name))))
    (if installed
        (log-info "no change necessary")
      ;; "If pkg is already installed, nothing is done."
      (apply system-or-error `("pkg" ,@pkg-opts "bootstrap"))
      (apply system-or-error `("pkg" ,@pkg-opts "install" "-y" ,name)))))
;; if we have a sysrc variable whose name is "varname", whose existing
;; value is "value1 value2", and we run "sysrc varname+=value3", then
;; sysrc says "varname: value1 value2 -> value1 value2 value3".
;; between the colon and the arrow is the old value; between the arrow
;; and the end of the line is the new value.
(defun parse-sysrc-output (output)
  (let* ((just-old-and-new (trim (sub "^[^:]+:" "" res)))
         (oan (split just-old-and-new " -> "))
         (o (car oan))
         (n (cadr oan)))
    (list o n)))
    
;; op is :set, :add, or :remove
(defun sysrc (op name value)
  (let ((alt-root
         (if *fact-alt-root* (list "-R" *fact-alt-root*) nil)))
    (cond
     ((eq op :set)
      (let ((setting (sprintf "%s=%s" name value)))
        (if (apply probe-success `("sysrc" "-c" ,@alt-root ,setting))
            (log-info "no change necessary")
          (apply system-or-error `("sysrc" ,@alt-root ,setting)))))
     ((eq op :add)
      ;; You can't sysrc -c ...+=... But if you try to add a value
      ;; onto a variable when it's already in there, nothing happens:
      ;; the += operation is idempotent. But we don't want to just
      ;; always say we changed it: that'll drown real changes in
      ;; chaff.
      ;;
      ;;
      ;; If we are trying to add value3 and it wasn't there to begin
      ;; with, the old value will be different from the new value. but
      ;; if it was already in there, the two complete values will be
      ;; the same.
      (let* ((add-s (sprintf "%s+=$s" name value))
             (sub-s (sprintf "%s-=%s" name value))
             (res (apply output-of `("sysrc" ,@alt-root ,add-s)))
             (old-and-new (parse-sysrc-output res))
             (o (car old-and-new))
             (n (cadr old-and-new)))
        (if (equal o n)
            ;; The value was unchanged by our snooping. That means the
            ;; thing we were trying to add is already in there, so our
            ;; check succeeds and our change will not be done (nor
            ;; superfluously reported).
            (log-info "no change necessary")
          ;; We changed it while trying to check. The added value will
          ;; be on the end, so if we remove it, everything will be
          ;; back how we found it, so we can then change it. :)
          ;;
          ;; -- except here in lacrum, we aren't separating checks and
          ;; changes yet, nor worrying about how to undo a change, so
          ;; we shall just be happy. we did the change!
          true)))
     ((eq op :remove)
      ;; Same as above: you can't check (-c) with -=.
      (let* ((sub-s (sprintf "%s-=%s" name value))
             (res (apply output-of `("sysrc" ,@alt-root ,sub-s)))
             (old-and-new (parse-sysrc-output res))
             (o (car old-and-new))
             (n (cadr old-and-new)))
        (if (equal o n)
            (log-info "no change necessary")
          ;; while checking it we removed it. be happy
          true)))
     (true
      (error "unknown sysrc op %s; use :set, :add, or :remove" op)))))

BUILD_AWK = awk
GLOTAWK = ../glotawk
SOURCES = \
	util.glotawk \
	logging.glotawk \
	exitcodes.glotawk \
	platform.glotawk \
	probes.glotawk \
	facts.glotawk \
	changes.glotawk
lacrum: $(SOURCES)
	(for s in $(SOURCES); do echo "(load \"$$s\")"; done; echo "(save-lisp-and-die \"$(GLOTAWK)\" \"$@\" 'repl)") | $(BUILD_AWK) -v LOG_LEVEL=3 -f $(GLOTAWK)
clean:
	rm -f lacrum