diff --git a/.gitignore b/.gitignore index 6ee0974..e16f7ad 100644 --- a/.gitignore +++ b/.gitignore @@ -1,5 +1,66 @@ -scratch/ -/.dir-locals.el -/gnu -*-tarball-pack.tar.gz -/mybin +*.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/ diff --git a/bin/play.scm b/bin/play.scm deleted file mode 100755 index 103e6c7..0000000 --- a/bin/play.scm +++ /dev/null @@ -1,43 +0,0 @@ -#!/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 new file mode 100644 index 0000000..bada9dd --- /dev/null +++ b/examples/forgejo.scm @@ -0,0 +1,60 @@ +(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 new file mode 100644 index 0000000..30a2a78 --- /dev/null +++ b/examples/inventory.scm @@ -0,0 +1,23 @@ +(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 new file mode 100644 index 0000000..631b2a6 --- /dev/null +++ b/examples/playbook.scm @@ -0,0 +1,17 @@ +(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 new file mode 100644 index 0000000..fe59576 --- /dev/null +++ b/guix.scm @@ -0,0 +1,79 @@ +(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 deleted file mode 100644 index f8f834c..0000000 --- a/manifest.scm +++ /dev/null @@ -1,26 +0,0 @@ -(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 deleted file mode 100644 index c4b48ae..0000000 --- a/modules/ordo/connection.scm +++ /dev/null @@ -1,191 +0,0 @@ -(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 - 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-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 (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 (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 deleted file mode 100644 index 6a8d5f4..0000000 --- a/modules/ordo/prerequisite-data.scm +++ /dev/null @@ -1,17 +0,0 @@ -(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 deleted file mode 100644 index f41af1e..0000000 --- a/modules/ordo/task.scm +++ /dev/null @@ -1,60 +0,0 @@ -(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 deleted file mode 100644 index 52a68bf..0000000 --- a/modules/ordo/task/command.scm +++ /dev/null @@ -1,17 +0,0 @@ -(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 deleted file mode 100644 index c766485..0000000 --- a/modules/ordo/task/file.scm +++ /dev/null @@ -1,4 +0,0 @@ -(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 deleted file mode 100644 index 3b70ffb..0000000 --- a/modules/ordo/util/filesystem.scm +++ /dev/null @@ -1,63 +0,0 @@ -(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 deleted file mode 100644 index 810a42f..0000000 --- a/modules/ordo/util/process.scm +++ /dev/null @@ -1,62 +0,0 @@ -(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 new file mode 100755 index 0000000..ddc878a --- /dev/null +++ b/ordo.scm @@ -0,0 +1,48 @@ +#!/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 new file mode 100644 index 0000000..bb87ae3 --- /dev/null +++ b/ordo/action/filesystem.scm @@ -0,0 +1,153 @@ +#| +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 new file mode 100644 index 0000000..883baf0 --- /dev/null +++ b/ordo/action/quadlet.scm @@ -0,0 +1,75 @@ +#| +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 new file mode 100644 index 0000000..d8b5eeb --- /dev/null +++ b/ordo/action/systemctl.scm @@ -0,0 +1,40 @@ +#| +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 new file mode 100644 index 0000000..1b46d6b --- /dev/null +++ b/ordo/cli/run.scm @@ -0,0 +1,68 @@ +#| +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 new file mode 100644 index 0000000..4c31470 --- /dev/null +++ b/ordo/connection.scm @@ -0,0 +1,80 @@ +#| +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 new file mode 100644 index 0000000..d853fdb --- /dev/null +++ b/ordo/connection/base.scm @@ -0,0 +1,57 @@ +#| +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 new file mode 100644 index 0000000..c4d39ae --- /dev/null +++ b/ordo/connection/local.scm @@ -0,0 +1,38 @@ +#| +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 new file mode 100644 index 0000000..2b2d2e6 --- /dev/null +++ b/ordo/connection/ssh.scm @@ -0,0 +1,80 @@ +#| +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 new file mode 100644 index 0000000..8271c22 --- /dev/null +++ b/ordo/connection/sudo.scm @@ -0,0 +1,66 @@ +#| +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 new file mode 100644 index 0000000..94c6290 --- /dev/null +++ b/ordo/context.scm @@ -0,0 +1,24 @@ +#| +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 new file mode 100644 index 0000000..d12c7c1 --- /dev/null +++ b/ordo/core.scm @@ -0,0 +1,69 @@ +#| +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 new file mode 100644 index 0000000..883f734 --- /dev/null +++ b/ordo/handler.scm @@ -0,0 +1,39 @@ +#| +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 new file mode 100644 index 0000000..354e8e4 --- /dev/null +++ b/ordo/inventory.scm @@ -0,0 +1,78 @@ +#| +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 new file mode 100644 index 0000000..b2aed69 --- /dev/null +++ b/ordo/logger.scm @@ -0,0 +1,46 @@ +#| +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 new file mode 100644 index 0000000..326d5c6 --- /dev/null +++ b/ordo/play.scm @@ -0,0 +1,92 @@ +#| +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 new file mode 100644 index 0000000..b22fc3c --- /dev/null +++ b/ordo/playbook.scm @@ -0,0 +1,61 @@ +#| +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 new file mode 100644 index 0000000..9399317 --- /dev/null +++ b/ordo/task.scm @@ -0,0 +1,43 @@ +#| +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 new file mode 100644 index 0000000..944c070 --- /dev/null +++ b/ordo/util/flatten.scm @@ -0,0 +1,27 @@ +#| +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 new file mode 100644 index 0000000..95de5eb --- /dev/null +++ b/ordo/util/keyword-args.scm @@ -0,0 +1,23 @@ +#| +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 new file mode 100644 index 0000000..1979ec3 --- /dev/null +++ b/ordo/util/read-lines.scm @@ -0,0 +1,28 @@ +#| +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 new file mode 100644 index 0000000..dcfbcf4 --- /dev/null +++ b/ordo/util/shell-quote.scm @@ -0,0 +1,59 @@ +#| +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 deleted file mode 100644 index 72fd903..0000000 --- a/playbooks/tryme.scm +++ /dev/null @@ -1,3 +0,0 @@ -(define x 7) - -(lambda () (* x x))