diff --git a/.gitignore b/.gitignore index e16f7ad..6ee0974 100644 --- a/.gitignore +++ b/.gitignore @@ -1,66 +1,5 @@ -*.eps -*.go -*.log -*.pdf -*.png -*.tar.xz -*.tar.gz -*.tmp -*~ -.#* -\#*\# -,* -/ABOUT-NLS -/INSTALL -/aclocal.m4 -/autom4te.cache -/build-aux/ar-lib -/build-aux/compile -/build-aux/config.guess -/build-aux/config.rpath -/build-aux/config.sub -/build-aux/depcomp -/build-aux/install-sh -/build-aux/mdate-sh -/build-aux/missing -/build-aux/test-driver -/build-aux/texinfo.tex -/config.status -/configure -/doc/*.1 -/doc/.dirstamp -/doc/contributing.*.texi -/doc/*.aux -/doc/*.cp -/doc/*.cps -/doc/*.fn -/doc/*.fns -/doc/*.html -/doc/*.info -/doc/*.info-[0-9] -/doc/*.ky -/doc/*.pg -/doc/*.toc -/doc/*.t2p -/doc/*.tp -/doc/*.vr -/doc/*.vrs -/doc/stamp-vti -/doc/version.texi -/doc/version-*.texi -/m4/* -/pre-inst-env -/test-env -/test-tmp -/tests/*.trs -GPATH -GRTAGS -GTAGS -Makefile -Makefile.in -config.cache -stamp-h[0-9] -tmp -/.version -/doc/stamp-[0-9] -/.config/ +scratch/ +/.dir-locals.el +/gnu +*-tarball-pack.tar.gz +/mybin diff --git a/bin/play.scm b/bin/play.scm new file mode 100755 index 0000000..103e6c7 --- /dev/null +++ b/bin/play.scm @@ -0,0 +1,43 @@ +#!/usr/bin/env -S guile --no-auto-compile -e main -s +!# +(use-modules (srfi srfi-11) + (ice-9 getopt-long) + (ice-9 format) + (ordo util filesystem)) + +(define (tar . args) + (unless (zero? (apply system* "tar" args)) + (error (format #f "Non-zero exit from tar ~a" args)))) + +(define* (usage #:optional errmsg) + (with-output-to-port (current-error-port) + (lambda () + (when errmsg + (format #t "Error: ~a~%~%" errmsg)) + (display "Usage: play -t TARGET PLAYBOOK") + (newline))) + (exit (if errmsg EXIT_FAILURE EXIT_SUCCESS))) + +(define (process-options args) + (let* ((option-spec '((help (single-char #\h) (value #f)) + (target (single-char #\t) (value #t) (required? #t)))) + (options (getopt-long args option-spec)) + (help-wanted (option-ref options 'help #f)) + (target (option-ref options 'target #f)) + (args (option-ref options '() '()))) + (cond + (help-wanted (usage)) + ((not (= 1 (length args))) + (usage "Expected exactly one playbook"))) + (values (canonicalize-path (car args)) target))) + +(define (main args) + (let-values (((playbook-path target) (process-options args))) + (define playbook (load playbook-path)) + (define top-dir (dirname (dirname (current-filename)))) + (call-with-temporary-directory + (lambda (tmp-dir) + (define tarball (string-append tmp-dir "/payload.tar")) + (tar "--create" "--file" tarball "--directory" top-dir "modules" "bin") + (tar "--append" "--file" tarball "--transform" "s/.*/playbook.scm/" playbook-path) + (tar "tf" tarball))))) diff --git a/examples/forgejo.scm b/examples/forgejo.scm deleted file mode 100644 index bada9dd..0000000 --- a/examples/forgejo.scm +++ /dev/null @@ -1,60 +0,0 @@ -(use-modules - ((ordo action filesystem) #:prefix fs:) - ((ordo action quadlet) #:prefix quadlet:) - ((ordo action systemctl) #:prefix systemctl:)) - -(define* (install-forgejo #:key (version "11")) - (list - (task "Install configuration directory" - #:action fs:install-dir - #:args '(#:path "/etc/forgejo") - #:trigger '("Restart pod")) - (task "Install timezone configuration" - #:action fs:install-file - #:args '(#:path "/etc/forgejo/timezone" #:local-src "files/timezone") - #:trigger '("Restart pod")) - (task "Install localtime configuration" - #:action fs:install-file - #:args '(#:path "/etc/forgejo/localtime" #:local-src "files/localtime") - #:trigger '("Restart pod")) - (task "Create data volume quadlet" - #:action quadlet:create-volume - #:args '(#:name "forgejo" #:description "Forgejo data volume") - #:trigger '("Reload systemd" "Restart pod")) - (task "Create pod quadlet" - #:action quadlet:create-pod - #:args '(#:name "forgejo" - #:pod ((PodName . "forge") - (Volume . "forgejo.volume:U,Z") - (PodmanArgs . "--userns auto"))) - #:trigger '("Reload systemd" "Restart pod")) - (task "Create image quadlet" - #:action quadlet:create-image - #:args `(#:name "forgejo" - #:image (Image . ,(format #f "codeberg.org/forgejo/forgejo:~a" version))) - #:trigger '("Reload systemd" "Restart pod")) - (task "Create container quadlet" - #:action quadlet:create-container - #:args '(#:name "forgejo" - #:container ((Pod . "forgejo.pod") - (Image . "forgejo.image") - (Network . "services.network") - (Volume . "/etc/forgejo/timezone:/etc/timezone:ro,U,Z") - (Volume . "/etc/forgejo/localtime:/etc/localtime:ro,U,Z") - (Environment . "USER_UID=1000") - (Environment . "USER_GID=1000") - (Environment . "FORGEJO__service__DISABLE_REGISTRATION=true") - (Environment . "FORGEJO__webhook__ALLOWED_HOST_LIST=private"))) - #:trigger '("Reload systemd" "Restart pod")) - (handler "Reload systemd" - #:action systemctl:daemon-reload) - (handler "Restart pod" - #:action systemctl:restart-unit - #:args '((#:unit . "forgejo-pod.service"))))) - -(playbook "Install Forgejo on limiting-factor" - ;; #:vars '((forgejo-version . "11.0.2")) - (play - #:host "limiting-factor" - #:become? #t - (install-forgejo #:version "11"))) diff --git a/examples/inventory.scm b/examples/inventory.scm deleted file mode 100644 index 30a2a78..0000000 --- a/examples/inventory.scm +++ /dev/null @@ -1,23 +0,0 @@ -(use-modules (ordo connection) - (ordo inventory)) - -(list - (host #:name "little-rascal" - #:connection (local-connection) - #:tags '(#:linux #:guix)) - - (host #:name "limiting-factor" - #:connection (ssh-connection "limiting-factor" #:user "core") - #:tags '(#:linux #:coreos)) - - (host #:name "screw-loose" - #:connection (ssh-connection "screw-loose" #:user "core") - #:tags '(#:linux #:coreos)) - - (host #:name "control-surface" - #:connection (ssh-connection "control-surface" #:user "ray") - #:tags '(#:linux #:debian)) - - (host #:name "cargo-cult" - #:connection (ssh-connection "cargo-cult" #:user "ray") - #:tags '(#:linux #:synology))) diff --git a/examples/playbook.scm b/examples/playbook.scm deleted file mode 100644 index 631b2a6..0000000 --- a/examples/playbook.scm +++ /dev/null @@ -1,17 +0,0 @@ -(use-modules (ordo playbook)) - -(playbook - #:name "Example playbook" - #:vars '((foo . 1) (bar . "baz")) - #:plays (list - (play #:name "Example play" - #:host "localhost" - #:tasks (list - (task #:name "First task" - #:action (const #t)) - (task #:name "Second task" - #:action (lambda (conn) - (trigger-handler! 'foo)))) - #:handlers (list - (handler #:name 'foo - #:action (const #f)))))) diff --git a/guix.scm b/guix.scm deleted file mode 100644 index fe59576..0000000 --- a/guix.scm +++ /dev/null @@ -1,79 +0,0 @@ -(use-modules - (gnu packages) - (gnu packages bash) - (gnu packages golang-crypto) - (gnu packages guile) - (gnu packages guile-xyz) - (gnu packages ssh) - (gnu packages version-control) - (guix build-system guile) - (guix download) - (guix gexp) - ((guix licenses) #:prefix license:) - (guix packages) - (srfi srfi-1)) - -(package - (name "guile-ordo") - (version "0.1.0") - (source - (local-file - (dirname (current-filename)) - #:recursive? #t - #:select? (lambda (file stat) - (not (any (lambda (my-string) - (string-contains file my-string)) - (list ".git" ".dir-locals.el" "guix.scm")))))) - (build-system guile-build-system) - (arguments - (list - #:phases #~(modify-phases %standard-phases - (add-after 'build 'link-and-wrap-executable - (lambda* (#:key inputs outputs #:allow-other-keys) - (let* ((bin (string-append #$output "/bin")) ; bin directory for PATH. - (site-version (target-guile-effective-version)) - (scm (lambda (p) (string-append p "/share/guile/site/" site-version))) - (go (lambda (p) (string-append p "/lib/guile/" site-version "/site-ccache"))) - (runtime-deps (cons #$output (map (lambda (p) (assoc-ref inputs p)) (list "guile-config" - "guile-dsv" - "guile-filesystem" - "guile-ini" - "guile-irregex" - "guile-libyaml" - "guile-json" - "guile-lib" - "guile-semver" - "guile-srfi-145" - "guile-srfi-158" - "guile-srfi-197" - "guile-srfi-235" - "guile-ssh"))))) - (mkdir-p bin) - (let ((source-script (string-append #$output - "/share/guile/site/" site-version "/" - "ordo.scm")) - (target-command (string-append bin "/ordo"))) - (symlink source-script target-command) - (wrap-program target-command - #:sh (which "bash") - `("GUILE_LOAD_PATH" prefix ,(map scm runtime-deps)) - `("GUILE_LOAD_COMPILED_PATH" prefix ,(map go runtime-deps)))))))))) - (inputs (list guile-3.0 bash-minimal git git-lfs age)) - (propagated-inputs (list guile-config - guile-dsv - guile-filesystem - guile-ini - guile-irregex - guile-libyaml - guile-json-4 - guile-lib - guile-semver - guile-srfi-145 - guile-srfi-158 - guile-srfi-197 - guile-srfi-235 - guile-ssh)) - (synopsis "Ordo configuration management") - (description "") - (home-page "") - (license license:gpl3+)) diff --git a/manifest.scm b/manifest.scm new file mode 100644 index 0000000..f8f834c --- /dev/null +++ b/manifest.scm @@ -0,0 +1,26 @@ +(specifications->manifest '("git" + "git-crypt" + "git-lfs" + "gnupg" + "guile" + "guile-config" + "guile-dsv" + "guile-file-names" + "guile-filesystem" + "guile-gcrypt" + "guile-gnutls" + "guile-ini" + "guile-irregex" + "guile-json" + "guile-lib" + "guile-libyaml" + "guile-quickcheck" + "guile-readline" + "guile-semver" + "guile-sqlite3" + "guile-srfi-145" + "guile-srfi-158" + "guile-srfi-197" + "guile-srfi-235" + "guile-ssh" + "password-store")) diff --git a/modules/ordo/connection.scm b/modules/ordo/connection.scm new file mode 100644 index 0000000..4deddb2 --- /dev/null +++ b/modules/ordo/connection.scm @@ -0,0 +1,225 @@ +(define-module (ordo connection) + #:use-module (oop goops) + #:use-module (ice-9 format) + #:use-module (ice-9 popen) + #:use-module (ice-9 rdelim) + #:use-module (ice-9 string-fun) + #:use-module (ice-9 binary-ports) + #:use-module (ice-9 textual-ports) + #:use-module (ssh session) + #:use-module (ssh channel) + #:use-module (ssh auth) + #:use-module (ssh popen) + #:use-module (srfi srfi-1) ;; list operations + #:use-module (srfi srfi-71) ;; extended let (multiple values) + #:use-module (srfi srfi-197) ;; chain + #:export (local-connection + ssh-connection + ;;podman-connection + init! + close! + run + command-available? + read-binary-file + read-text-file + write-binary-file + write-text-file + copy-port)) + +(define-class () + (sudo? #:init-value #f #:getter sudo? #:init-keyword #:sudo?)) + +(define-class ()) + +(define* (local-connection #:key (sudo? #f)) + (make #:sudo? sudo?)) + +(define-class () + (user #:getter get-user #:init-keyword #:user) + (host #:getter get-host #:init-keyword #:host) + (session #:getter get-session #:setter set-session!)) + +(define* (ssh-connection user host #:key (sudo? #f)) + (make #:user user #:host host #:sudo? sudo?)) + +;; (define-class () +;; (container-name #:getter get-container-name #:init-keyword #:container) +;; (user #:getter get-user #:init-keyword #:user #:init-value #f)) + +;; (define* (podman-connection #:key (sudo? #f)) +;; (make #:sudo? sudo?)) + +(define-method (init! c) #t) + +(define-method (close! c) #t) + +(define-method (init! (c )) + (unless (slot-bound? c 'session) + (set-session! c (make-session #:user (get-user c) #:host (get-host c)))) + (let ((s (get-session c))) + (unless (connected? s) + (connect! s) + (userauth-public-key/auto! s))) + #t) + +(define-method (close! (c )) + (when (slot-bound? c 'session) + (let ((s (get-session c))) + (when (connected? s) + (disconnect! s))))) + +(define (build-command pwd env prog args sudo?) + (let ((cmd (list (if sudo? "sudo" "env")))) + (chain-when cmd + (pwd (append _ (list "--chdir" pwd))) + (env (append _ (map (lambda (x) (format #f "~a=~a" (car x) (cdr x))) env))) + (#t (append _ (list prog))) + (args (append _ args))))) + +(define (read-lines port) + (define (loop line result) + (if (eof-object? line) (reverse result) (loop (read-line port) (cons line result)))) + (loop (read-line port) '())) + +(define-method (%run (c ) pwd env prog args) + (let* ((cmd (build-command pwd env prog args (sudo? c))) + (port (apply open-pipe* OPEN_READ cmd)) + (output (read-lines port)) + (exit-status (status:exit-val (close-pipe port)))) + (values output exit-status))) + +(define-method (%run (c ) pwd env prog args) + (let* ((cmd (build-command pwd env prog args (sudo? c))) + (channel (apply open-remote-input-pipe* (get-session c) cmd)) + (output (read-lines channel)) + (exit-status (channel-get-exit-status channel))) + (close channel) + (values output exit-status))) + +;; (define-method (build-podman-exec (c pwd env prog args) +;; (chain-when '() +;; ((sudo? c) (append _ "sudo")) +;; (#t (append _ '("podman" "exec"))) +;; ((get-user c) (append (list "-u" (get-user c)))) +;; (pwd (append _ '( "-w" pwd))) +;; (env (append _ (concatenate (map (lambda (x) (list "-e" (format #f "~a=~a" (car x) (cdr x)))) env)))) +;; (#t (append (list container-name))) +;; (#t (append _ (cons prog args)))))) + +;; (define-method (%run (c ) pwd env prog args) +;; (let* ((cmd (build-podman-exec c pwd env prog args))) +;; (port (apply open-pipe* OPEN_READ cmd)) +;; (output (read-lines port)) +;; (exit-status (status:exit-val (close-pipe port)))) +;; (values output exit-status)) + +(define (find-kw-arg kw kwargs) + (let loop ((kwargs kwargs)) + (cond + ((null? kwargs) #f) + ((equal? (car kwargs) kw) (cadr kwargs)) + (else (loop (cddr kwargs)))))) + +(define (run c prog . rest) + (let ((args (take-while (negate keyword?) rest)) + (kwargs (drop-while (negate keyword?) rest))) + (unless (even? (length kwargs)) + (error "keyword arguments require a value")) + (let ((pwd (find-kw-arg #:pwd kwargs)) + (env (find-kw-arg #:env kwargs))) + (%run c pwd env prog args)))) + +(define (command-available? c command) + (let ((_ rc (run c "which" command))) + (zero? rc))) + +;; These functions for reading and writing files are using cat (with output +;; redirection for writing) rather than opening the files directly so that the +;; command can be invoked under sudo when necessary. + +(define-method (read-file (c ) (path ) (reader )) + (let* ((cmd (build-command #f #f "cat" (list path) (sudo? c))) + (port (apply open-pipe* OPEN_READ cmd)) + (output (reader port)) + (exit-status (status:exit-val (close-pipe port)))) + (unless (zero? exit-status) + (error (format #f "error reading local text file ~a" path))) + output)) + +(define-method (read-file (c ) (path ) (reader )) + (let* ((cmd (build-command #f #f "cat" (list path) (sudo? c))) + (channel (apply open-remote-input-pipe* (get-session c) cmd)) + (output (reader channel)) + (exit-status (channel-get-exit-status channel))) + (close channel) + (unless (zero? exit-status) + (error (format #f "error reading text file ~a@~a:~a" (get-user c) (get-host c) path))) + output)) + +;; (define-method (read-file (c ) (path ) (reader )) +;; (let* ((cmd (build-podman-exec c #f #f "cat" (list path))) +;; (port (apply open-pipe* OPEN_READ cmd)) +;; (output (reader port)) +;; (exit-status (status:exit-val (close-pipe port)))) +;; (unless (zero? exit-status) +;; (error (format #f "error reading file ~a:~a" (get-container-name c) path))) +;; output)) + +(define (read-text-file c path) + (read-file c path get-string-all)) + +(define (read-binary-file c path) + (read-file c path get-bytevector-all)) + +(define (shell-quote s) + "Quote string S for sh-compatible shells." + (string-append "'" (string-replace-substring s "'" "'\\''") "'")) + +;; These methods for writing files require the file content to be read into memory. They +;; are useful for small files, but prefer COPY-FILE for larger ones. + +(define-method (write-file (c ) (path ) (writer ) content) + (let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote path))) (sudo? c))) + (port (apply open-pipe* OPEN_WRITE cmd))) + (writer port content) + (unless (zero? (status:exit-val (close-pipe port))) + (error (format #f "error writing local text file ~a" path))))) + +(define-method (write-file (c ) (path ) (writer ) content) + (let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote path))) (sudo? c))) + (channel (apply open-remote-output-pipe* (get-session c) cmd))) + (writer channel content) + (channel-send-eof channel) + (let ((exit-status (channel-get-exit-status channel))) + (close channel) + (unless (zero? exit-status) + (error (format #f "error writing text file ~a@~a:~a" (get-user c) (get-host c) path)))))) + +(define (write-text-file c path content) + (write-file c path put-string content)) + +(define (write-binary-file c path content) + (write-file c path put-bytevector content)) + +(define-method (copy-port (c ) (src ) (dest-path )) + (let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote dest-path))) (sudo? c))) + (dport (apply open-pipe* OPEN_WRITE cmd))) + (let loop ((data (get-bytevector-some src))) + (unless (eof-object? data) + (put-bytevector dport data) + (loop (get-bytevector-some src)))) + (unless (zero? (status:exit-val (close-pipe dport))) + (error (format #f "error copying file to ~a" dest-path))))) + +(define-method (copy-port (c ) (src ) (dest-path )) + (let* ((cmd (build-command #f #f "sh" (list "-c" (format #f "cat > ~a" (shell-quote dest-path))) (sudo? c))) + (channel (apply open-remote-output-pipe* (get-session c) cmd))) + (let loop ((data (get-bytevector-some src))) + (unless (eof-object? data) + (put-bytevector channel data) + (loop (get-bytevector-some src)))) + (channel-send-eof channel) + (let ((exit-status (channel-get-exit-status channel))) + (close channel) + (unless (zero? exit-status) + (error (format #f "error copying file to ~a@~a:~a" (get-user c) (get-host c) dest-path)))))) diff --git a/modules/ordo/prerequisite-data.scm b/modules/ordo/prerequisite-data.scm new file mode 100644 index 0000000..6a8d5f4 --- /dev/null +++ b/modules/ordo/prerequisite-data.scm @@ -0,0 +1,17 @@ +(define-module (ordo prerequisite-data) + #:use-module (oop goops)) + +(define-class ()) + +(define-class () + (path #:init-keyword #:path #:getter get-path)) + +(define-method (equal? (x ) (y )) + (equal? (get-path x) (get-path y))) + +(define (local-file path) + (make #:path path)) + +(define-class () + (handler #:init-keyword #:handler #:getter get-handler) + (args #:init-keyword #:args :getter get-args)) diff --git a/modules/ordo/task.scm b/modules/ordo/task.scm new file mode 100644 index 0000000..f41af1e --- /dev/null +++ b/modules/ordo/task.scm @@ -0,0 +1,60 @@ +(define-module (ordo task) + #:use-module (srfi srfi-1) + #:use-module (srfi srfi-9) + #:export (make-task task? task-name task-prerequisite-data task-want-skip task-action task-seq)) + +;; Task +;; name - a descriptive name for the task +;; prerequisite-data - list of prerequisite data (local data +;; that must be copied to the remote host +;; in order for the task to run) +;; want-skip - function of no args that should return #t if the +;; the task should be skipped +;; action - function of no args that runs the task +(define-record-type + (make-task name prerequisite-data want-skip action) + task? + (want-skip task-want-skip) + (name task-name) + (prerequisite-data task-prerequisite-data) + (action task-action)) + +(define (combine-prerequisite-data tasks) + ;; TODO: work out what the equality operator should be, which + ;; will depend on how we represent prerequisite data + (apply lset-union = (map task-prerequisite-data tasks))) + +;; Combine the want-skips functions from a sequence of tasks. +;; If any task has no want-skip function, the combined task cannot +;; be skipped, so simply return #f. Otherwise, return a function that +;; will only return #t if every task's want-skip function returns true. +;; TODO: With this approach, if the top-level want-skip funciton returns +;; #f (so the task action sequence runs), some of the tests will be repeated. +;; Is it preferable always to have the top-level return #f and simply run +;; the subtasks? +(define (combine-want-skips tasks) + (let ((skips (map task-want-skip tasks))) + (if (every identity skips) + (lambda () (every identity (map (lambda (f) (f)) skips))) + #f))) + +;; Return a function that will apply each of the task actions +;; in order. +;; TODO: would it be better to store the list of actions and +;; implement a task runner that would run either a single task +;; or a sequence of tasks with appropriate logging? +;; TODO: the implementation below does not handle skipping +;; tasks in the sequence, this would be handled by a task runner. +(define (combine-actions tasks) + (let ((actions (map task-action tasks))) + (lambda () + (for-each (lambda (f) (f)) actions)))) + +;; Return a task consists of a sequence of other tasks. +(define (task-seq name task . task*) + (let ((tasks (cons task task*))) + (make-task + name + (combine-prerequisite-data tasks) + (combine-want-skips tasks) + (combine-actions tasks)))) diff --git a/modules/ordo/task/command.scm b/modules/ordo/task/command.scm new file mode 100644 index 0000000..52a68bf --- /dev/null +++ b/modules/ordo/task/command.scm @@ -0,0 +1,17 @@ +(define-module (ordo task command) + #:use-module (ice-9 format) + #:use-module (srfi srfi-11) + #:use-module (ordo task) + #:use-module (ordo util process) + #:export (command)) + +(define* (command name cmd #:optional (args '()) + #:key (fail-ok? #f) (stdin #f) (cwd #f) (env #f) (skip? #f)) + (make-task name + '() + skip? + (lambda () + (let-values (((exit-code output) (run cmd args #:stdin stdin #:cwd cwd #:env env #:combine-output #t))) + (if (or fail-ok? (zero? exit-code)) + (values exit-code output) + (error (format #f "Error running ~a (exit ~d): ~a" cmd exit-code output))))))) diff --git a/modules/ordo/task/file.scm b/modules/ordo/task/file.scm new file mode 100644 index 0000000..c766485 --- /dev/null +++ b/modules/ordo/task/file.scm @@ -0,0 +1,4 @@ +(define-module (ordo task file) + #:use-module (ordo task)) + +(define (file )) diff --git a/modules/ordo/util/filesystem.scm b/modules/ordo/util/filesystem.scm new file mode 100644 index 0000000..3b70ffb --- /dev/null +++ b/modules/ordo/util/filesystem.scm @@ -0,0 +1,63 @@ +(define-module (ordo util filesystem) + #:use-module (system foreign) + #:use-module (srfi srfi-11) + #:use-module (ice-9 format) + #:use-module (ice-9 ftw) + #:export (delete-file-recursively + create-temporary-directory + call-with-temporary-directory)) + +(define* (delete-file-recursively filename #:key (verbose #f)) + (define dev (stat:dev (stat filename))) + (define (enter? name stat result) + (= (stat:dev stat) dev)) + (define (leaf name stat result) + (if (false-if-exception (delete-file name)) + (and verbose (format #t "delete-file ~a OK~%" name)) + (format (current-error-port) "warning: delete-file ~a failed~%" name)) + result) + (define (down name stat result) + result) + (define (up name stat result) + (if (false-if-exception (rmdir name)) + (and verbose (format #t "rmdir ~a OK~%" name)) + (format (current-error-port) "warning: rmdir ~a failed~%" name)) + result) + (define (skip name state result) + result) + (define (error name stat errno result) + (format (current-error-port) "warning: ~a: ~a~%" + name (strerror errno)) + result) + (file-system-fold enter? leaf down up skip error #f filename)) + + +;; This is based on reading guix/build/syscalls.scm but less general +;; than their implementation. +;; TODO: why is this needed? The guile standard library has mkdtemp +;; that seems to do the same thing. +(define mkdtemp! + (let* ((ptr (dynamic-func "mkdtemp" (dynamic-link))) + (proc (pointer->procedure '* ptr '(*) #:return-errno? #t))) + (lambda (tmpl) + (let-values (((result err) (proc (string->pointer tmpl)))) + (when (null-pointer? result) + (error (format #f "mkdtemp! ~a: ~a" tmpl (strerror err)))) + (pointer->string result))))) + +(define (create-temporary-directory) + (let* ((directory (or (getenv "TMPDIR") "/tmp")) + (template (string-append directory "/ordo.XXXXXX"))) + (mkdtemp! template))) + +;; This is borrowed from guix/util.scm +(define (call-with-temporary-directory proc) + "Call PROC with a name of a temporary directory; close the directory and +delete it when leaving the dynamic extent of this call." + (let ((tmp-dir (create-temporary-directory))) + (dynamic-wind + (const #t) + (lambda () + (proc tmp-dir)) + (lambda () + (false-if-exception (delete-file-recursively tmp-dir)))))) diff --git a/modules/ordo/util/process.scm b/modules/ordo/util/process.scm new file mode 100644 index 0000000..810a42f --- /dev/null +++ b/modules/ordo/util/process.scm @@ -0,0 +1,62 @@ +(define-module (ordo util process) + #:use-module (ice-9 textual-ports) + #:export (with-cwd with-env capture)) + +(define-syntax with-cwd + (syntax-rules () + ((_ new-dir body ...) + (let ((original-dir (getcwd))) + (dynamic-wind + (lambda () (chdir new-dir)) + (lambda () body ...) + (lambda () (chdir original-dir))))))) + +;; Not needed for CAPTURE, which supports an environment override, +;; but might be useful for SYSTEM and SYSTEM* +(define-syntax with-env + (syntax-rules () + ((_ new-env body ...) + (let ((original-env (environ))) + (dynamic-wind + (lambda () (environ new-env)) + (lambda () body ...) + (lambda () (environ original-env))))))) + +;; Run a command and capture the output. Currently this only supports +;; text input and output. If necessary, we could use the (rnrs io ports) +;; module and use PUT-BYTEVECTOR / GET-BYTEVECTOR-ALL and examine the type +;; of STDIN to determine whether to call PUT-STRING or PUT-BYTEVECTOR. For +;; STDOUT, we'd need to add a #:binary argument so the caller could indicate +;; they are expecting binary output. Not implemented yet incase YAGNI. +(define* (capture cmd + #:optional (args '()) + #:key (combine-output #f) (env #f) (stdin #f) (cwd #f)) + (if cwd + (with-cwd cwd (run cmd args #:combine-output combine-output #:env env #:stdin stdin)) + (let* ((input-pipe (pipe)) + (output-pipe (pipe)) + (pid (spawn cmd (cons cmd args) + #:input (car input-pipe) + #:output (cdr output-pipe) + #:error (if combine-output (cdr output-pipe) (current-error-port)) + #:environment (or env (environ))))) + (close-port (cdr output-pipe)) + (close-port (car input-pipe)) + (when stdin (put-string (cdr input-pipe) stdin)) + (close-port (cdr input-pipe)) + (let ((output (get-string-all (car output-pipe)))) + (close-port (car output-pipe)) + (values (cdr (waitpid pid)) output))))) + +;; Possibly nicer way to do this, suggested by dsmith on IRC: https://bpa.st/3JYTA +;; (use-modules (ice-9 popen) +;; (ice-9 rdelim) +;; (ice-9 receive)) + +;; (define (filter text) +;; (receive (from to pids) (pipeline '(("the-command"))) +;; (write text to) +;; (close to) +;; (read-line from))) + +;; See also https://github.com/ray1729/ordo/blob/main/modules/ordo/util/process.scm diff --git a/ordo.scm b/ordo.scm deleted file mode 100755 index ddc878a..0000000 --- a/ordo.scm +++ /dev/null @@ -1,48 +0,0 @@ -#!/usr/bin/guile \ ---no-auto-compile -e main -s -!# - -(use-modules (config) - (config api) - (config parser sexp) - (ice-9 format) - (ice-9 match) - ((ordo cli run) #:prefix run:) - (ordo logger)) - -(define config - (configuration - (name 'ordo) - (synopsis "From chaos, comes order") - (description "Ordo configuration management.") - (keywords - (list - (setting - (name 'log-level) - (handler string->symbol) - (test valid-log-level?) - (default 'NOTICE) - (example "DEBUG|INFO|NOTICE|WARN|ERROR") - (synopsis "Log level")))) - (parser sexp-parser) - (directory (in-cwd ".config/" #t)) - (version "0.1.0") - (author "Ray Miller") - (license gpl3+) - (copyright (list 2025)) - (subcommands - (list - run:config)))) - -(define (main cmd-line) - (let ((options (getopt-config-auto cmd-line config))) - (dynamic-wind - (lambda () - (setup-logging! #:level (option-ref options 'log-level))) - (lambda () - (match (full-command options) - (("ordo" "run") - (run:handler options)) - (_ (emit-help options)))) - (lambda () - (shutdown-logging!))))) diff --git a/ordo/action/filesystem.scm b/ordo/action/filesystem.scm deleted file mode 100644 index bb87ae3..0000000 --- a/ordo/action/filesystem.scm +++ /dev/null @@ -1,153 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo action filesystem) - #:use-module (ice-9 binary-ports) - #:use-module (ice-9 match) - #:use-module (logging logger) - #:use-module (rnrs bytevectors) - #:use-module (srfi srfi-1) ; list utils - #:use-module (srfi srfi-26) ; cut - #:use-module (srfi srfi-71) ; extended let - #:use-module ((ordo connection) #:select (remote-cmd)) - #:use-module (ordo connection base) - #:export (create-tmp-dir - install-dir - install-file - file-info - remove-file - create-link)) - -(define* (file-info conn #:key path (atime? #t) (ctime? #t)) - (define (parse-stat-result s) - (match-let* (((file-type user group . rest) (string-split s #\:)) - ((uid gid size mode atime mtime ctime) (map string->number rest))) - `((file-type . ,file-type) - (user . ,user) - (group . ,group) - (uid . ,uid) - (gid . ,gid) - (size . ,size) - (mode . ,mode) - ,@(if atime? (list (cons 'atime atime)) '()) - (mtime . ,mtime) - ,@(if ctime? (list (cons 'ctime ctime)) '())))) - (let ((result rc (remote-cmd conn "stat" `("--format=%F:%U:%G:%u:%g:%s:#o%a:%X:%Y:%Z" ,path)))) - (cond - ((zero? rc) (parse-stat-result (first result))) - ((string-contains (first result) "No such file or directory") #f) - (else (error (format #f "stat ~a: ~a" path (first result))))))) - -(define-syntax changed-if-stat-changed - (syntax-rules () - ((changed-if-stat-changed conn path expr ...) - (let ((st-before (file-info conn #:path path #:atime? #f #:ctime? #f))) - expr ... - (let ((st-after (file-info conn #:path path #:atime? #f #:ctime? #f))) - (not (equal? st-before st-after))))))) - -(define* (remove-file conn #:key path (recurse? #f)) - (changed-if-stat-changed - conn path - (remote-cmd conn "rm" "-f" (when recurse? "-r") path - #:check? #t))) - -(define* (create-link conn #:key target link-name (symbolic? #f) (force? #t) (backup? #f)) - "Create a link to @code{target} with the name @code{link-name}." - (changed-if-stat-changed - conn link-name - (remote-cmd conn "ln" - (when symbolic? "--symbolic") - (when force? "--force") - (when backup? "--backup=numbered") - target - link-name - #:check? #t))) - -(define* (create-tmp-dir conn #:key tmpdir suffix template) - (remote-cmd conn "mktemp" "--directory" - (when tmpdir '("--tmpdir" tmpdir)) - (when suffix '("--suffix" suffix)) - (when template template) - #:check? #t - #:return car)) - -(define* (install-dir conn #:key path owner group mode) - (when (integer? mode) - (set! mode (number->string mode 8))) - (changed-if-stat-changed - conn path - (remote-cmd conn "install" "--directory" - (when owner `("--owner" ,owner)) - (when group `("--group" ,group)) - (when mode `("--mode" ,mode)) - path - #:check? #t))) - -(define (upload-tmp-file conn tmp-file) - (lambda (input-port) - (with-remote-output-file conn tmp-file - (lambda (output-port) - (let loop ((data (get-bytevector-some input-port))) - (unless (eof-object? data) - (put-bytevector output-port data) - (loop (get-bytevector-some input-port)))) - (close-port output-port))))) - -(define (install-remote-file conn src dest owner group mode backup?) - ;; If owner/group/mode is unspecified and the destination file already exists, - ;; preserve the current ownership and mode. - (unless (and owner group mode) - (let ((st (file-info conn #:path dest))) - (when st - (set! owner (or owner (assoc-ref st 'owner))) - (set! group (or group (assoc-ref st 'group))) - (set! mode (or mode (assoc-ref st 'mode)))))) - (when (integer? mode) - (set! mode (number->string mode 8))) - (remote-cmd conn "install" - "--compare" - (when owner `("--owner" ,owner)) - (when group `("--group" ,group)) - (when mode `("--mode" ,mode)) - (when backup? "--backup=numbered") - src - dest - #:check? #t)) - -(define* (install-file conn #:key path owner group (mode #o644) content local-src remote-src backup?) - (when (not (= 1 (length (filter identity (list content local-src remote-src))))) - (error "exactly one of #:content, #:local-src, or #:remote-src is required")) - (changed-if-stat-changed - conn path - (if remote-src - (install-remote-file conn remote-src path owner group mode backup?) - ;; Because we might need sudo to install the remote file, we first - ;; upload the source to a temporary file, then call @code{install-remote-file} to - ;; install the temporary file to the target path. - (let ((tmp-file (remote-cmd conn "mktemp" #:check? #t #:return car))) - (dynamic-wind - (const #t) - (lambda () - (cond - (local-src (call-with-input-file local-src (upload-tmp-file conn tmp-file))) - ((string? content) (call-with-input-string content (upload-tmp-file conn tmp-file))) - ((bytevector? content) (call-with-input-bytevector content (upload-tmp-file conn tmp-file))) - (else (error "unsupported type for #:content"))) - (install-remote-file conn tmp-file path owner group mode backup?)) - (lambda () - (remote-cmd conn "rm" "-f" tmp-file))))))) diff --git a/ordo/action/quadlet.scm b/ordo/action/quadlet.scm deleted file mode 100644 index 883baf0..0000000 --- a/ordo/action/quadlet.scm +++ /dev/null @@ -1,75 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo action quadlet) - #:use-module (ice-9 filesystem) - #:use-module (ini) - #:use-module (logging logger) - #:use-module (ordo connection) - #:use-module ((ordo action filesystem) #:prefix fs:) - #:use-module ((srfi srfi-1) #:select (remove)) - #:export (create-network - create-pod - create-container - create-volume - create-image - create-build)) - -(define system-quadlet-dir "/etc/containers/systemd") - -(define default-install-options '(("WantedBy" . "multi-user.target default.target"))) - -(define (scm->ini-string data) - (with-output-to-string (lambda () (scm->ini data)))) - -(define (quadlet quadlet-type name description unit-options quadlet-options service-options install-options) - (let* ((description (or description (string-append "Podman " (string-downcase quadlet-type) " " name))) - (data `(("Unit" ("Description" . ,description) ,@unit-options) - (,(string-titlecase quadlet-type) ,@quadlet-options) - ,@(if (null? service-options) '() (list (cons "Service" service-options))) - ,@(if (null? install-options) '() (list (cons "Install" install-options)))))) - (scm->ini-string data))) - -(define* (create-network conn #:key name description network (unit '()) (service '()) (install default-install-options) (quadlet-dir system-quadlet-dir)) - (fs:install-file conn - #:path (file-name-join* quadlet-dir (string-append name ".network")) - #:content (quadlet "Network" name description unit network service install))) - -(define* (create-pod conn #:key name description pod (unit '()) (service '()) (install default-install-options) (quadlet-dir system-quadlet-dir)) - (fs:install-file conn - #:path (file-name-join* quadlet-dir (string-append name ".pod")) - #:content (quadlet "Pod" name description unit pod service install))) - -(define* (create-container conn #:key name description container (unit '()) (service '()) (install default-install-options) (quadlet-dir system-quadlet-dir)) - (fs:install-file conn - #:path (file-name-join* quadlet-dir (string-append name ".container")) - #:content (quadlet "Container" name description unit container service install))) - -(define* (create-volume conn #:key name description volume (unit '()) (service '()) (install '()) (quadlet-dir system-quadlet-dir)) - (fs:install-file conn - #:path (file-name-join* quadlet-dir (string-append name ".volume")) - #:content (quadlet "Volume" name description unit volume service install))) - -(define* (create-build conn #:key name description build (unit '()) (service '()) (install '()) (quadlet-dir system-quadlet-dir)) - (fs:install-file conn - #:path (file-name-join* quadlet-dir (string-append name ".build")) - #:content (quadlet "Build" name description unit build service install))) - -(define* (create-image conn #:key name description image (unit '()) (service '()) (install '()) (quadlet-dir system-quadlet-dir)) - (fs:install-file conn - #:path (file-name-join* quadlet-dir (string-append name ".image")) - #:content (quadlet "Image" name description unit image service install))) diff --git a/ordo/action/systemctl.scm b/ordo/action/systemctl.scm deleted file mode 100644 index d8b5eeb..0000000 --- a/ordo/action/systemctl.scm +++ /dev/null @@ -1,40 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo action systemctl) - #:use-module (ordo connection) - #:export (daemon-reload stop start restart reload)) - -(define* (daemon-reload conn #:key user?) - (remote-cmd conn "systemctl" (when user? "--user") "daemon-reload" #:check? #t) - #t) - -(define* (stop conn #:key unit user?) - (remote-cmd conn "systemctl" (when user? "--user") "stop" unit #:check? #t) - #t) - -(define* (start conn #:key unit user?) - (remote-cmd conn "systemctl" (when user? "--user") "start" unit #:check? #t) - #t) - -(define* (reload conn #:key unit user?) - (remote-cmd conn "systemctl" (when user? "--user") "reload" unit #:check? #t) - #t) - -(define* (restart conn #:key unit user?) - (remote-cmd conn "systemctl" (when user? "--user") "restart" unit #:check? #t) - #t) diff --git a/ordo/cli/run.scm b/ordo/cli/run.scm deleted file mode 100644 index 1b46d6b..0000000 --- a/ordo/cli/run.scm +++ /dev/null @@ -1,68 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo cli run) - #:use-module (config) - #:use-module (config api) - #:use-module (ice-9 filesystem) - #:use-module (ordo inventory) - #:use-module (ordo logger) - #:use-module (ordo playbook) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-26) - #:export (config handler)) - -(define (valid-tags? x) - (or (null? x) - (and (list? x) (every keyword? x)))) - -(define (parse-tags x) - (map (compose symbol->keyword string->symbol) - (if (list? x) x (list x)))) - -(define config - (configuration - (name 'run) - (wanted '((keywords . (log-level)) directory)) - (keywords - (list - (setting - (name 'inventory) - (default "/dev/null") - (example "examples/inventory.scm") - (handler (cut expand-file-name <> #f #t)) - (test file-exists?) - (synopsis "Inventory file")) - (switch - (name 'tag) - (default (list)) - (test valid-tags?) - (handler parse-tags) - (merge-strategy cons) - (synopsis "Limit operations to specified tag(s)")))) - (arguments - (list - (argument - (name 'playbook) - (handler (cut expand-file-name <> #f #t)) - (test file-exists?)))) - (synopsis "Run a playbook"))) - -(define (handler options) - (let ((inventory (load-inventory (option-ref options 'inventory))) - (playbook (load-playbook (option-ref options '(playbook))))) - (run-playbook playbook inventory))) diff --git a/ordo/connection.scm b/ordo/connection.scm deleted file mode 100644 index 4c31470..0000000 --- a/ordo/connection.scm +++ /dev/null @@ -1,80 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo connection) - #:use-module (ice-9 exceptions) - #:use-module (oop goops) - #:use-module (ordo connection base) - #:use-module (ordo connection local) - #:use-module (ordo connection ssh) - #:use-module (ordo connection sudo) - #:use-module (ordo logger) - #:use-module (ordo util flatten) - #:use-module (ordo util keyword-args) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-71) - #:export (connection? - local-connection - ssh-connection - call-with-connection - remote-cmd) - #:re-export (remote-exec with-remote-input-file with-remote-output-file)) - -(define (connection? c) - (is-a? c )) - -(define (local-connection) - (make )) - -(define* (ssh-connection host #:key (user (getlogin)) (password #f) (identity #f) (authenticate-server? #t) - (sudo? #f) (sudo-user #f) (sudo-password #f)) - (make #:user user #:host host #:password password - #:identity identity #:authenticate-server? authenticate-server? - #:sudo? sudo? #:sudo-user sudo-user #:sudo-password sudo-password)) - -(define* (call-with-connection conn proc #:key sudo? sudo-user sudo-password) - (let ((conn (deep-clone conn))) - (when sudo? - (unless (is-a? conn ) - (raise-exception - (make-exception - (make-programming-error) - (make-exception-with-message (format #f "connection ~a does not support sudo" conn))))) - (set! (become? conn) sudo?) - (set! (become-user conn) sudo-user) - (set! (become-password conn) sudo-password)) - (dynamic-wind - (lambda () (setup conn)) - (lambda () (proc conn)) - (lambda () (teardown conn))))) - -(define (remote-cmd conn prog . args) - (let* ((args options (break keyword? args)) - (args (remove unspecified? (flatten args))) - (return (keyword-arg options #:return identity)) - (check? (keyword-arg options #:check?)) - (command (build-command conn prog args options))) - (log-msg 'INFO "Running command: " command) - (let ((out rc (remote-exec conn command))) - (log-msg 'INFO "Command exit code: " rc) - (if check? - (if (zero? rc) - (return out) - (raise-exception (make-exception - (make-external-error) - (make-exception-with-message (format #f "Non-zero exit (~a) from ~a" rc prog))))) - (values (return out) rc))))) diff --git a/ordo/connection/base.scm b/ordo/connection/base.scm deleted file mode 100644 index d853fdb..0000000 --- a/ordo/connection/base.scm +++ /dev/null @@ -1,57 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo connection base) - #:use-module (ice-9 match) - #:use-module (oop goops) - #:use-module (ordo util flatten) - #:use-module (ordo util keyword-args) - #:use-module (ordo util shell-quote) - #:use-module ((srfi srfi-1) #:select (remove)) - #:export ( - setup - teardown - build-command - remote-exec - with-remote-input-file - with-remote-output-file)) - -(define-generic setup) -(define-generic teardown) -(define-generic build-command) -(define-generic remote-exec) -(define-generic with-remote-input-file) -(define-generic with-remote-output-file) - -(define-class ()) - -(define-method (setup (c )) #t) - -(define-method (teardown (c )) #t) - -(define-method (build-command (c ) (prog-name ) (prog-args ) (options )) - (let* ((pwd (keyword-arg options #:pwd)) - (env (keyword-arg options #:env)) - (redirect-err? (keyword-arg options #:redirect-err? #t)) - (xs (remove unspecified? - (flatten (list "env" - (when pwd (list "--chdir" (string-shell-quote pwd))) - (when env (map (match-lambda ((k . v) (string-append k "=" (string-shell-quote v)))) env)) - prog-name - (map string-shell-quote prog-args) - (when redirect-err? "2>&1")))))) - (string-join xs " "))) diff --git a/ordo/connection/local.scm b/ordo/connection/local.scm deleted file mode 100644 index c4d39ae..0000000 --- a/ordo/connection/local.scm +++ /dev/null @@ -1,38 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo connection local) - #:use-module (ice-9 popen) - #:use-module (oop goops) - #:use-module (ordo connection base) - #:use-module (ordo connection sudo) - #:use-module (ordo util read-lines) - #:export ()) - -(define-class ()) - -(define-method (remote-exec (c ) (command )) - (let* ((port (open-input-pipe command)) - (output (read-lines port)) - (exit-status (status:exit-val (close-pipe port)))) - (values output exit-status))) - -(define-method (with-remote-input-file (c ) (filename ) (proc )) - (call-with-input-file filename proc)) - -(define-method (with-remote-output-file (c ) (filename ) (proc )) - (call-with-output-file filename proc)) diff --git a/ordo/connection/ssh.scm b/ordo/connection/ssh.scm deleted file mode 100644 index 2b2d2e6..0000000 --- a/ordo/connection/ssh.scm +++ /dev/null @@ -1,80 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo connection ssh) - #:use-module (oop goops) - #:use-module (ice-9 exceptions) - #:use-module (ice-9 popen) - #:use-module (ssh session) - #:use-module (ssh channel) - #:use-module (ssh auth) - #:use-module (ssh popen) - #:use-module (ssh sftp) - #:use-module (ordo connection base) - #:use-module (ordo connection sudo) - #:use-module (ordo util read-lines) - #:export ()) - -(define-class () - (user #:getter ssh-connection-user #:init-keyword #:user) - (host #:getter ssh-connection-host #:init-keyword #:host) - (password #:getter ssh-connection-password #:init-keyword #:password #:init-val #f) - (identity #:getter ssh-connection-identity #:init-keyword #:identity #:init-val #f) - (authenticate-server? #:getter ssh-connection-authenticate-server? #:init-keyword #:authenticate-server? #:init-val #t) - (session) - (sftp-session)) - -(define-method (setup (c )) - (unless (slot-bound? c 'session) - (slot-set! c 'session (make-session #:user (ssh-connection-user c) #:host (ssh-connection-host c))) - (when (ssh-connection-identity c) (session-set! (slot-ref c 'session) 'identity (ssh-connection-identity c)))) - (let ((s (slot-ref c 'session))) - (unless (connected? s) - (connect! s) - (when (ssh-connection-authenticate-server? s) - (let ((server-auth (authenticate-server s))) - (unless (equal? 'ok server-auth) - (error (format #f "authenticate-server: ~a" server-auth))))) - (let ((user-auth (if (ssh-connection-password c) - (userauth-password! s (ssh-connection-password c)) - (userauth-public-key/auto! s)))) - (unless (equal? 'success user-auth) - (error (format #f "userauth: ~a" user-auth))))))) - -(define-method (remote-exec (c ) (command )) - (let* ((channel (open-remote-input-pipe (slot-ref c 'session) command)) - (output (read-lines channel)) - (exit-status (channel-get-exit-status channel))) - (close channel) - (values output exit-status))) - -(define-method (sftp-session (c )) - (unless (slot-bound? c 'sftp-session) - (slot-set! c 'sftp-session (make-sftp-session (session c)))) - (slot-ref c 'sftp-session)) - -(define-method (with-remote-input-file (c ) (filename ) (proc )) - (call-with-remote-input-file (sftp-session c) filename proc)) - -(define-method (with-remote-output-file (c ) (filename ) (proc )) - (call-with-remote-output-file (sftp-session c) filename proc)) - -(define-method (teardown (c )) - (when (slot-bound? c 'session) - (let ((s (slot-ref c session))) - (when (connected? s) - (disconnect! s))))) diff --git a/ordo/connection/sudo.scm b/ordo/connection/sudo.scm deleted file mode 100644 index 8271c22..0000000 --- a/ordo/connection/sudo.scm +++ /dev/null @@ -1,66 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo connection sudo) - #:use-module (oop goops) - #:use-module (ice-9 exceptions) - #:use-module (ice-9 rdelim) - #:use-module (srfi srfi-26) - #:use-module (srfi srfi-71) - #:use-module (ordo connection base) - #:use-module (ordo util shell-quote) - #:export ( - become? - become-user - become-password)) - -(define-class () - (become? #:accessor become? #:init-keyword become? #:init-form #f) - (become-user #:accessor become-user #:init-keyword #:become-user #:init-form #f) - (become-password #:accessor become-password #:init-keyword #:become-password #:init-form #f) - (password-tmp-file #:accessor password-tmp-file)) - -(define-method (setup (conn )) - (when (become-password conn) - (let ((out rc (remote-exec conn "mktemp"))) - (unless (zero? rc) - (raise-exception (make-exception - (make-external-error) - (make-exception-with-message (format #f "Failed to create temporary directory: ~a" (car out)))))) - (let ((tmp-file (car out))) - (with-remote-output-file conn tmp-file (cut write-line (become-password conn) <>)) - (set! (password-tmp-file conn) tmp-file))))) - -(define-method (build-command (conn ) (prog-name ) (prog-args ) (options )) - (cond - ((not (become? conn)) - (next-method)) - - ((and (become-user conn) (become-password conn)) - (format #f "cat ~a - | sudo -k -S -H -u ~a -- ~a" (string-shell-quote (password-tmp-file conn)) (string-shell-quote (become-user conn)) (next-method))) - - ((become-password conn) - (format #f "cat ~a - | sudo -k -S -H -- ~a" (string-shell-quote (password-tmp-file conn)) (next-method))) - - ((become-user conn) - (format #f "sudo -k -n -H -u ~a -- ~a" (string-shell-quote (become-user conn)) (next-method))) - - (else (format #f "sudo -k -n -H -- ~a" (next-method))))) - -(define-method (teardown (conn )) - (when (slot-bound? conn 'password-tmp-file) - (remote-exec conn (format #f "rm -f ~a" (string-shell-quote (password-tmp-file conn)))))) diff --git a/ordo/context.scm b/ordo/context.scm deleted file mode 100644 index 94c6290..0000000 --- a/ordo/context.scm +++ /dev/null @@ -1,24 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo context)) - -(define-public *inventory* (make-parameter #f)) -(define-public *playbook* (make-parameter #f)) -(define-public *play* (make-parameter #f)) -(define-public *host* (make-parameter #f)) -(define-public *triggered-handlers* (make-parameter #f)) diff --git a/ordo/core.scm b/ordo/core.scm deleted file mode 100644 index d12c7c1..0000000 --- a/ordo/core.scm +++ /dev/null @@ -1,69 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# -(define-module (ordo core) - #:use-module (ordo connection) - #:use-module (ordo context) - #:use-module (ordo handler) - #:use-module (ordo inventory) - #:use-module (ordo logger) - #:use-module (ordo playbook) - #:use-module (ordo play) - #:use-module (ordo task) - #:use-module ((srfi srfi-26) #:select (cut))) - -(define (run-playbook ctx pb) - (log-msg 'NOTICE "Running playbook: " (playbook-name pb)) - (set-ctx-playbook! ctx pb) - (for-each (cut run-play ctx <>) (playbook-plays pb))) - -(define (run-play ctx p) - (log-msg 'NOTICE "Running play: " (play-name p)) - (set-ctx-play! ctx p) - (let ((hosts (resolve-hosts (ctx-inventory ctx) (play-host p)))) - (if (null? hosts) - (log-msg 'WARN "No hosts matched: " (play-host p)) - (for-each (cut run-host-play ctx p <>) hosts)))) - -(define (run-host-play ctx p h) - (log-msg 'NOTICE "Running play on host: " (host-name h)) - (set-ctx-host! ctx h) - (call-with-connection - (host-connection h) - (lambda (conn) - (dynamic-wind - (lambda () - (set-ctx-connection! ctx conn)) - (lambda () - (for-each (cut run-task ctx <>) (play-tasks p)) - (for-each (cut run-handler ctx <>) (play-handlers p))) - (lambda () - (set-ctx-connection! ctx #f)))) - #:sudo? (play-sudo? p) - #:sudo-user (play-sudo-user p) - #:sudo-password (play-sudo-password p))) - -(define (run-task ctx t) - (if ((task-pre-condition t) ctx) - (begin - (log-msg 'NOTICE "Running task " (task-name t)) - ((task-action t) ctx)) - (log-msg 'NOTICE "Skipping task " (task-name t) ": pre-condition not met"))) - -(define (run-handler ctx h) - (when (member (ctx-triggers ctx) (handler-name h)) - (log-msg 'NOTICE "Running handler: " (handler-name h)) - ((handler-action h) ctx))) diff --git a/ordo/handler.scm b/ordo/handler.scm deleted file mode 100644 index 883f734..0000000 --- a/ordo/handler.scm +++ /dev/null @@ -1,39 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo handler) - #:use-module (srfi srfi-9) - #:use-module (ordo logger) - #:export (make-handler - handler? - handler-name - handler-action - handler - run-handler)) - -(define-record-type - (make-handler name action) - handler? - (name handler-name) - (action handler-action)) - -(define* (handler #:key name action) - (make-handler name action)) - -(define (run-handler h conn) - (log-msg 'NOTICE "Running handler: " (handler-name h)) - ((handler-action h) conn)) diff --git a/ordo/inventory.scm b/ordo/inventory.scm deleted file mode 100644 index 354e8e4..0000000 --- a/ordo/inventory.scm +++ /dev/null @@ -1,78 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo inventory) - #:use-module (ice-9 eval-string) - #:use-module (ice-9 match) - #:use-module (ice-9 textual-ports) - #:use-module (oop goops) - #:use-module ((ordo connection) #:select (local-connection)) - #:use-module (ordo logger) - #:use-module (srfi srfi-1) - #:use-module (srfi srfi-9) - #:use-module (srfi srfi-69) - #:export (host - host? - host-name - host-connection - host-tags - host-vars - resolve-hosts - load-inventory)) - -(define-record-type - (make-host name connection tags vars) - host? - (name host-name) - (connection host-connection) - (tags host-tags) - (vars host-vars)) - -(define* (host #:key name connection (tags '()) (vars '())) - (make-host name connection tags (alist->hash-table vars))) - -(define (tagged-every? wanted-tags) - (lambda (h) - (lset= equal? wanted-tags (lset-intersection equal? (host-tags h) wanted-tags)))) - -(define (tagged-any? wanted-tags) - (lambda (h) - (not (null? (lset-intersection equal? (host-tags h) wanted-tags))))) - -(define (named? hostname) - (lambda (h) - (string=? (host-name h) hostname))) - -(define (resolve-hosts inventory expr) - (match expr - ("localhost" (list (or (find (named? "localhost") inventory) - (host #:name "localhost" #:connection (local-connection))))) - ((? string? hostname) (filter (named? hostname) inventory)) - ('all inventory) - (('tagged tag) (filter (tagged-every? (list tag)) inventory)) - (('tagged/every tag . tags) (filter (tagged-every? (cons tag tags)) inventory)) - (('tagged/any tag . tags) (filter (tagged-any? (cons tag tags)) inventory)) - ((. hostnames) (filter (lambda (h) (member (host-name h) hostnames string=?)) inventory)))) - -(define (load-inventory filename) - (log-msg 'INFO "Loading inventory " filename) - (let* ((inventory (eval-string (call-with-input-file filename get-string-all) - #:file filename)) - (inventory (if (list? inventory) inventory '()))) - (when (null? inventory) - (log-msg 'NOTICE "Inventory is empty, only localhost will be available")) - inventory)) diff --git a/ordo/logger.scm b/ordo/logger.scm deleted file mode 100644 index b2aed69..0000000 --- a/ordo/logger.scm +++ /dev/null @@ -1,46 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo logger) - #:use-module (oop goops) - #:use-module ((srfi srfi-1) #:select (take-while member)) - #:use-module ((srfi srfi-26) #:select (cut)) - #:use-module (logging logger) - #:use-module (logging port-log) - #:export (setup-logging! - shutdown-logging! - valid-log-level?) - #:re-export (log-msg)) - -(define log-levels '(DEBUG INFO NOTICE WARN ERROR)) - -(define (valid-log-level? level) - (member level log-levels eq?)) - -(define* (setup-logging! #:key (level 'INFO)) - (let ((logger (make )) - (handler (make #:port (current-error-port)))) - (for-each (cut disable-log-level! handler <>) - (take-while (negate (cut equal? level <>)) log-levels)) - (add-handler! logger handler) - (set-default-logger! logger) - (open-log! logger))) - -(define (shutdown-logging!) - (flush-log) ; since no args, it uses the default - (close-log!) ; ditto - (set-default-logger! #f)) diff --git a/ordo/play.scm b/ordo/play.scm deleted file mode 100644 index 326d5c6..0000000 --- a/ordo/play.scm +++ /dev/null @@ -1,92 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo play) - #:use-module (ordo connection) - #:use-module (ordo context) - #:use-module (ordo handler) - #:use-module (ordo inventory) - #:use-module (ordo logger) - #:use-module (ordo task) - #:use-module (ordo util flatten) - #:use-module (ordo util keyword-args) - #:use-module (srfi srfi-1) ; lists - #:use-module (srfi srfi-9) ; records - #:use-module (srfi srfi-26) ; cut/cute - #:use-module (srfi srfi-69) ; hash tables - #:use-module (srfi srfi-71) ; extended let - #:export (play - play? - play-host - play-sudo? - play-sudo-user - play-sudo-password - play-vars - play-tasks - play-handlers - run-play - trigger-handler!)) - -(define-record-type - (make-play name host sudo? sudo-user sudo-password vars tasks handlers) - play? - (name play-name) - (host play-host) - (sudo? play-sudo?) - (sudo-user play-sudo-user) - (sudo-password play-sudo-password) - (vars play-vars) - (tasks play-tasks) - (handlers play-handlers)) - -(define (play name . args) - (let* ((tasks args (partition task? args)) - (handlers kwargs (partition handler? args))) - (make-play name - (keyword-arg #:host kwargs) - (keyword-arg #:sudo? kwargs) - (keyword-arg #:sudo-user kwargs) - (keyword-arg #:sudo-password kwargs) - (and=> (keyword-arg #:vars kwargs) alist->hash-table) - tasks - handlers))) - -(define (run-play p) - (log-msg 'NOTICE "Running play: " (play-name p)) - (parameterize ((*play* p)) - (let ((hosts (resolve-hosts (*inventory*) (play-host p)))) - (if (null? hosts) - (log-msg 'WARN "No hosts matched: " (play-host p)) - (for-each (cut run-host-play p <>) hosts))))) - -(define (run-host-play p h) - (log-msg 'NOTICE "Running play on host: " (host-name h)) - (parameterize ((*host* h) - (*triggered-handlers* (make-hash-table))) - (call-with-connection - (host-connection h) - (lambda (conn) - (for-each (cut run-task <> conn) (play-tasks p)) - (for-each (cut run-handler <> conn) - (filter (compose (cut hash-table-ref/default *triggered-handlers* <> #f) handler-name) - (play-handlers p)))) - #:sudo? (play-sudo? p) - #:sudo-user (play-sudo-user p) - #:sudo-password (play-sudo-password p)))) - -(define (trigger-handler! handler-name) - (hash-table-set! *triggered-handlers* handler-name #t)) diff --git a/ordo/playbook.scm b/ordo/playbook.scm deleted file mode 100644 index b22fc3c..0000000 --- a/ordo/playbook.scm +++ /dev/null @@ -1,61 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo playbook) - #:use-module (ice-9 eval-string) - #:use-module (ice-9 textual-ports) - #:use-module (ordo context) - #:use-module (ordo handler) - #:use-module (ordo logger) - #:use-module (ordo play) - #:use-module (ordo task) - #:use-module (ordo util keyword-args) - #:use-module (srfi srfi-1) ; lists - #:use-module (srfi srfi-9) ; records - #:use-module (srfi srfi-26) ; cut/cute - #:use-module (srfi srfi-69) ; hash tables - #:use-module (srfi srfi-71) ; extended let - #:export ( - playbook - playbook? - playbook-name - playbook-vars - playbook-plays - load-playbook - run-playbook)) - -(define-record-type - (make-playbook name vars plays) - playbook? - (name playbook-name) - (vars playbook-vars) - (plays playbook-plays)) - -(define (playbook name . args) - (let ((plays kwargs (partition play? args))) - (make-playbook name (alist->hash-table (keyword-arg #:vars kwargs '())) plays))) - -(define (load-playbook filename) - (log-msg 'INFO "Loading playbook " filename) - (eval-string (call-with-input-file filename get-string-all) - #:file filename)) - -(define (run-playbook pb inventory) - (log-msg 'NOTICE "Running playbook: " (playbook-name pb)) - (parameterize ((*inventory* inventory) - (*playbook* pb)) - (for-each run-play (playbook-plays pb)))) diff --git a/ordo/task.scm b/ordo/task.scm deleted file mode 100644 index 9399317..0000000 --- a/ordo/task.scm +++ /dev/null @@ -1,43 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo task) - #:use-module (ordo logger) - #:use-module (srfi srfi-9) - #:export (task - task? - task-name - task-pre-condition - task-action - run-task)) - -(define-record-type - (make-task name action pre-condition) - task? - (name task-name) - (pre-condition task-pre-condition) - (action task-action)) - -(define* (task #:key name action (pre-condition (const #t))) - (make-task name action pre-condition)) - -(define (run-task t conn) - (if ((task-pre-condition t) conn) - (begin - (log-msg 'NOTICE "Running task " (task-name t)) - ((task-action t) conn)) - (log-msg 'NOTICE "Skipping task " (task-name t) ": pre-condition not met"))) diff --git a/ordo/util/flatten.scm b/ordo/util/flatten.scm deleted file mode 100644 index 944c070..0000000 --- a/ordo/util/flatten.scm +++ /dev/null @@ -1,27 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo util flatten) - #:export (flatten)) - -(define (flatten lst) - (cond - ((null? lst) '()) - ((list? (car lst)) - (append (flatten (car lst)) (flatten (cdr lst)))) - (else - (cons (car lst) (flatten (cdr lst)))))) diff --git a/ordo/util/keyword-args.scm b/ordo/util/keyword-args.scm deleted file mode 100644 index 95de5eb..0000000 --- a/ordo/util/keyword-args.scm +++ /dev/null @@ -1,23 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo util keyword-args) - #:use-module ((srfi srfi-1) #:select (member)) - #:export (keyword-arg)) - -(define* (keyword-arg args kw #:optional (default #f)) - (or (and=> (member kw args) cadr) default)) diff --git a/ordo/util/read-lines.scm b/ordo/util/read-lines.scm deleted file mode 100644 index 1979ec3..0000000 --- a/ordo/util/read-lines.scm +++ /dev/null @@ -1,28 +0,0 @@ -#| -This file is part of Ordo. - -Copyright (C) 2025 Ray Miller - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free Software -Foundation, version 3. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR A -PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo util read-lines) - #:use-module (ice-9 rdelim) - #:export (read-lines)) - -(define (read-lines port) - "Read lines from port until eof is encountered. Return list of all lines read." - (define (loop line result) - (if (eof-object? line) - (reverse result) - (loop (read-line port) (cons line result)))) - (loop (read-line port) '())) diff --git a/ordo/util/shell-quote.scm b/ordo/util/shell-quote.scm deleted file mode 100644 index dcfbcf4..0000000 --- a/ordo/util/shell-quote.scm +++ /dev/null @@ -1,59 +0,0 @@ -#| -This file is part of Ordo. - -Shell quoting implementation is based on Perl's String::ShellQuote -Copyright (c) 1997 Roderick Schertler. - -Guile implementation Copyright (c) 2025 Ray Miller. - -This program is free software: you can redistribute it and/or modify it under -the terms of the GNU General Public License as published by the Free -Software Foundation, either version 3 of the License, or (at your option) -any later version. - -This program is distributed in the hope that it will be useful, but WITHOUT ANY -WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS FOR -A PARTICULAR PURPOSE. See the GNU General Public License for more details. - -You should have received a copy of the GNU General Public License along with -this program. If not, see . -|# - -(define-module (ordo util shell-quote) - #:use-module (rx irregex) - #:use-module ((srfi srfi-197) #:select (chain)) - #:export (string-shell-quote)) - -(define unsafe-characters (irregex '(~ (or alphanumeric ("!%+,\\-./:=@^"))))) - -(define (needs-escape? s) - (irregex-search unsafe-characters s)) - -(define (squash-quotes m) - (let ((n (/ (- (irregex-match-end-index m) - (irregex-match-start-index m)) - 4))) - (list->string (append - '(#\' #\") - (make-list n #\') - '(#\" #\'))))) - -(define (escape s) - (chain s - ;; ' -> '\'' - (irregex-replace/all (irregex "'") _ "'\\''") - ;; make multiple ' in a row look simpler - ;; '\'''\'''\'' -> '"'''"' - (irregex-replace/all (irregex '(>= 2 "'\\''")) _ squash-quotes) - ;; wrap in single quotes - (string-append "'" _ "'") - ;; kill leading/trailing pair of single quotes - (irregex-replace (irregex '(seq bos "''")) _ "") - (irregex-replace (irregex '(seq "''" eos)) _ ""))) - -(define (string-shell-quote s) - "Quote strings for passing through the shell" - (cond - ((zero? (string-length s)) "''") - ((needs-escape? s) (escape s)) - (else s))) diff --git a/playbooks/tryme.scm b/playbooks/tryme.scm new file mode 100644 index 0000000..72fd903 --- /dev/null +++ b/playbooks/tryme.scm @@ -0,0 +1,3 @@ +(define x 7) + +(lambda () (* x x))