diff --git a/README.md b/README.md index 0c867e4..98f0680 100644 --- a/README.md +++ b/README.md @@ -51,7 +51,7 @@ api-key: <> ``` -(Note the parenteses in `API-KEY()`). +(Note the parentheses in `API-KEY()`). ## Limitations @@ -124,7 +124,7 @@ parallel, though I haven't identified yet how to best do this. ### Tangling -Tangling obeys the same target tags. This will create `~/foo.txt` in `server1`: +Tangling obeys the same targets. This will create `~/foo.txt` in `server1`: ``` * Upload a file to server1 :server1: @@ -145,6 +145,50 @@ You can tangle a file to multiple servers. This will create `~/foo.txt` on both #+END_SRC ``` +Given + +`#+TARGET: /ssh:example1.com:/opt/app (server1)`, + +`:tangle` resolves to a path within the host: + +| `:tangle` | resolves to | +|------------------|-------------------------------------------| +| `foo.txt` | `/ssh:example1.com:/opt/app/foo.txt` | +| `conf/foo.txt` | `/ssh:example1.com:/opt/app/conf/foo.txt` | +| `./conf/foo.txt` | same as above — the `./` is dropped | +| `/etc/foo.txt` | `/ssh:example1.com:/etc/foo.txt` | +| `~/foo.txt` | `/ssh:example1.com:~/foo.txt` | + +## Disabling with :target nil + +Sometimes you may want to "turn off" the target for a single block. + +As an example, let's say we have a container `TARGET`: + +``` +#+TARGET: /ssh:server.com|podman:my-container: (container) +``` + +We can filter the results locally by adding `target: nil` to a second block: + +``` +* Service status :container: + +#+NAME: status +#+BEGIN_SRC sh +some-cli status --json +#+END_SRC + +#+BEGIN_SRC sh :stdin status :target nil +jq -r '.services + | to_entries[] + | select(.value.state != "running") + | "\(.key)\t\(.value.state)\t\(.value.health)"' +#+END_SRC +``` + +This will work even if the `jq` command is not installed in the container :) + ## Drift detection Tangling pushes the org file out to its targets. `devops-drift` asks the diff --git a/devops-drift.el b/devops-drift.el index b2f10d4..5692a85 100644 --- a/devops-drift.el +++ b/devops-drift.el @@ -64,8 +64,16 @@ original :tangle value, LOCAL the rewritten local file and REMOTE the file the path denotes at TARGET. A PATH that is already a TRAMP path keeps itself as REMOTE but is still redirected to LOCAL-ROOT: a drift check must never write to a remote. Skips :tangle no and :tangle yes. + +A block that opted out with `:target nil' has no target to be compared +against, so it is left out of the mapping and its header is neutralized +to :tangle no. Neutralizing it matters as much as omitting it: the +block's own path is a real local file, and tangling it here would make a +read-only check write to the user's filesystem. + Modifies buffer text." - (let (mapping) + (let ((opted-out (devops--target-opted-out-regions)) + mapping) (save-excursion (goto-char (point-max)) (while (re-search-backward ":tangle +\\([^ \t\n]+\\)" nil t) @@ -76,18 +84,23 @@ Modifies buffer text." (end (match-end 0)) (path (match-string 1))) (unless (member path '("no" "yes")) - (let ((remote (if (tramp-tramp-file-p path) - path - (devops--join-target target path))) - (local (expand-file-name - (devops--drift-localize-path path) local-root))) - (delete-region beg end) - (goto-char beg) - (insert ":tangle " local) - ;; Step before the rewrite so the backward search keeps - ;; making progress (the rewritten path matches the regexp). - (goto-char beg) - (push (list path local remote) mapping)))))) + (if (devops--in-regions-p beg opted-out) + (progn + (delete-region beg end) + (goto-char beg) + (insert ":tangle no")) + (let ((remote (if (tramp-tramp-file-p path) + path + (devops--join-target target path))) + (local (expand-file-name + (devops--drift-localize-path path) local-root))) + (delete-region beg end) + (goto-char beg) + (insert ":tangle " local) + (push (list path local remote) mapping))) + ;; Step before the rewrite so the backward search keeps + ;; making progress (the rewritten path matches the regexp). + (goto-char beg))))) mapping)) (defun devops--drift-tangle-heading (source-buf heading-pos tag target local-root) diff --git a/devops-test.el b/devops-test.el index e03e117..add3171 100644 --- a/devops-test.el +++ b/devops-test.el @@ -126,7 +126,52 @@ The directory is removed afterwards." (should (equal (devops--join-target "/ssh:host:/etc" "foo.txt") "/ssh:host:/etc/foo.txt")) (should (equal (devops--join-target "/ssh:host:/etc/" "foo.txt") - "/ssh:host:/etc/foo.txt"))) + "/ssh:host:/etc/foo.txt")) + ;; A relative subdirectory keeps its shape, spelled either way. + (should (equal (devops--join-target "/ssh:host:" "dir/foo.txt") + "/ssh:host:dir/foo.txt")) + (should (equal (devops--join-target "/ssh:host:" "./dir/foo.txt") + "/ssh:host:dir/foo.txt")) + (should (equal (devops--join-target "/srv/app" "./dir/foo.txt") + "/srv/app/dir/foo.txt")) + ;; "." as a target and "./" on the path collapse to one "./". + (should (equal (devops--join-target "." "./foo.txt") "./foo.txt"))) + +(ert-deftest devops--split-target-test () + "Split a target into its TRAMP prefix and its directory part." + (should (equal (devops--split-target "/srv/app") '("" . "/srv/app"))) + (should (equal (devops--split-target ".") '("" . "."))) + (should (equal (devops--split-target "/ssh:host:") '("/ssh:host:" . ""))) + (should (equal (devops--split-target "/ssh:host:/etc") '("/ssh:host:" . "/etc"))) + ;; Multi-hop: the whole hop chain is the prefix (`file-remote-p' would + ;; report only "/podman:box:"). + (should (equal (devops--split-target "/ssh:host|podman:box:") + '("/ssh:host|podman:box:" . "")))) + +(ert-deftest devops--join-target-absolute-path-test () + "An absolute :tangle path is absolute on the target's machine." + ;; The TRAMP prefix survives; the target's directory does not. + (should (equal (devops--join-target "/ssh:host:" "/etc/app.conf") + "/ssh:host:/etc/app.conf")) + (should (equal (devops--join-target "/ssh:host:/opt/app" "/etc/app.conf") + "/ssh:host:/etc/app.conf")) + (should (equal (devops--join-target "/ssh:host|podman:box:/opt" "/etc/app.conf") + "/ssh:host|podman:box:/etc/app.conf")) + ;; A local directory target has no prefix to keep, so the path stands alone. + (should (equal (devops--join-target "/srv/app/" "/etc/app.conf") + "/etc/app.conf")) + (should (equal (devops--join-target "." "/etc/app.conf") "/etc/app.conf"))) + +(ert-deftest devops--join-target-home-path-test () + "A \"~\" :tangle path is the home directory on the target's machine." + (should (equal (devops--join-target "/ssh:host:" "~/foo.txt") + "/ssh:host:~/foo.txt")) + ;; Not "/ssh:host:/opt/app/~/foo.txt", which names a directory called "~". + (should (equal (devops--join-target "/ssh:host:/opt/app" "~/foo.txt") + "/ssh:host:~/foo.txt")) + (should (equal (devops--join-target "/ssh:host:/opt/app" "~admin/foo.txt") + "/ssh:host:~admin/foo.txt")) + (should (equal (devops--join-target "/srv/app/" "~/foo.txt") "~/foo.txt"))) ;;; Tangle-path rewriting @@ -189,6 +234,73 @@ The directory is removed afterwards." (goto-char (point-min)) (should-not (search-forward ":tangle .foo.txt" nil t)))) +(ert-deftest devops--rewrite-tangle-paths-subdirectory-test () + "A relative subdirectory is prefixed, spelled with or without \"./\"." + (devops-test--with-org + (concat "* Heading\n\n" + "#+begin_src sh :tangle dir/foo.txt\n" + "echo hi\n#+end_src\n\n" + "#+begin_src sh :tangle ./dir/bar.txt\n" + "echo hi\n#+end_src\n") + (devops--rewrite-tangle-paths "/ssh:host1:") + (goto-char (point-min)) + (should (search-forward ":tangle /ssh:host1:dir/foo.txt" nil t)) + (goto-char (point-min)) + (should (search-forward ":tangle /ssh:host1:dir/bar.txt" nil t)))) + +(ert-deftest devops--rewrite-tangle-paths-absolute-test () + "An absolute path is absolute on the target, not nested under it." + (devops-test--with-org + (concat "* Heading\n\n" + "#+begin_src sh :tangle /etc/app.conf\n" + "key=val\n#+end_src\n") + (devops--rewrite-tangle-paths "/ssh:host1:/opt/app") + (goto-char (point-min)) + (should (search-forward ":tangle /ssh:host1:/etc/app.conf" nil t)) + (goto-char (point-min)) + (should-not (search-forward "/opt/app/etc" nil t)))) + +(ert-deftest devops--rewrite-tangle-paths-target-nil-test () + "A block that opted out with `:target nil' keeps its own local path." + (devops-test--with-org + (concat "* Heading\n\n" + "#+begin_src sh :tangle foo.txt\n" + "echo hi\n#+end_src\n\n" + "#+begin_src sh :target nil :tangle bar.txt\n" + "echo hi\n#+end_src\n") + (devops--rewrite-tangle-paths "/ssh:host1:" "/home/me/notes/") + (goto-char (point-min)) + (should (search-forward ":tangle /ssh:host1:foo.txt" nil t)) + ;; Relative, so expanded against LOCAL-DIR rather than the temp buffer. + (goto-char (point-min)) + (should (search-forward ":tangle /home/me/notes/bar.txt" nil t)) + (goto-char (point-min)) + (should-not (search-forward ":tangle /ssh:host1:bar.txt" nil t)))) + +(ert-deftest devops--rewrite-tangle-paths-target-nil-absolute-test () + "An opted-out block's absolute path is left as it stands." + (devops-test--with-org + (concat "* Heading\n\n" + "#+begin_src sh :target nil :tangle ~/bar.txt\n" + "echo hi\n#+end_src\n") + (devops--rewrite-tangle-paths "/ssh:host1:" "/home/me/notes/") + (goto-char (point-min)) + (should (search-forward (concat ":tangle " (expand-file-name "~/bar.txt")) + nil t)))) + +(ert-deftest devops--rewrite-tangle-paths-target-nil-from-property-test () + "A `:target nil' inherited from a `header-args' property opts out too." + (devops-test--with-org + (concat "* Heading\n" + ":PROPERTIES:\n" + ":header-args: :target nil\n" + ":END:\n\n" + "#+begin_src sh :tangle bar.txt\n" + "echo hi\n#+end_src\n") + (devops--rewrite-tangle-paths "/ssh:host1:" "/home/me/notes/") + (goto-char (point-min)) + (should (search-forward ":tangle /home/me/notes/bar.txt" nil t)))) + (ert-deftest devops--rewrite-tangle-paths-skip-yes-test () "Don't rewrite :tangle yes (the default-filename flag, not a path)." (devops-test--with-org @@ -437,6 +549,107 @@ targets land next to the org file rather than in the system temp dir." (should (equal (file-name-as-directory (file-truename (org-trim result))) (file-name-as-directory (file-truename target)))))))) +(ert-deftest devops-execute-src-block-explicit-dir-wins-test () + "An explicit :dir on the block overrides the heading's target." + (devops-test--with-local-target target + (devops-test--with-local-target other + (devops-test--with-org + (format (concat "#+TARGET: %s (local)\n\n" + "* Run\t\t:local:\n\n" + "#+begin_src sh :dir %s\npwd\n#+end_src\n") + target other) + (goto-char (point-min)) + (re-search-forward "begin_src") + (let* ((org-confirm-babel-evaluate nil) + (result (org-babel-execute-src-block))) + (should (equal (file-name-as-directory (file-truename (org-trim result))) + (file-name-as-directory (file-truename other))))))))) + +(ert-deftest devops-execute-src-block-explicit-dir-skips-prompt-test () + "With an explicit :dir, multiple target tags do not prompt for a target." + (devops-test--with-local-target other + (devops-test--with-org + (format (concat "#+TARGET: /srv/one/ (t1)\n" + "#+TARGET: /srv/two/ (t2)\n\n" + "* Run\t\t:t1:t2:\n\n" + "#+begin_src sh :dir %s\npwd\n#+end_src\n") + other) + (goto-char (point-min)) + (re-search-forward "begin_src") + (let ((org-confirm-babel-evaluate nil)) + (cl-letf (((symbol-function 'completing-read) + (lambda (&rest _) (error "Should not prompt for a target")))) + (should (equal (file-name-as-directory + (file-truename (org-trim (org-babel-execute-src-block)))) + (file-name-as-directory (file-truename other))))))))) + +(ert-deftest devops-execute-src-block-target-nil-runs-locally-test () + "`:target nil' opts the block out of the heading's target." + (devops-test--with-local-target target + (devops-test--with-org + (format (concat "#+TARGET: %s (local)\n\n" + "* Run\t\t:local:\n\n" + "#+begin_src sh :target nil\npwd\n#+end_src\n") + target) + (goto-char (point-min)) + (re-search-forward "begin_src") + (let* ((here default-directory) + (org-confirm-babel-evaluate nil) + (result (file-name-as-directory + (file-truename (org-trim (org-babel-execute-src-block)))))) + (should (equal result (file-name-as-directory (file-truename here)))) + (should-not (equal result + (file-name-as-directory (file-truename target)))))))) + +(ert-deftest devops-execute-src-block-target-nil-skips-prompt-test () + "With `:target nil', multiple target tags do not prompt for a target." + (devops-test--with-org + (concat "#+TARGET: /srv/one/ (t1)\n" + "#+TARGET: /srv/two/ (t2)\n\n" + "* Run\t\t:t1:t2:\n\n" + "#+begin_src sh :target nil\npwd\n#+end_src\n") + (goto-char (point-min)) + (re-search-forward "begin_src") + (let ((here default-directory) + (org-confirm-babel-evaluate nil)) + (cl-letf (((symbol-function 'completing-read) + (lambda (&rest _) (error "Should not prompt for a target")))) + (should (equal (file-name-as-directory + (file-truename (org-trim (org-babel-execute-src-block)))) + (file-name-as-directory (file-truename here)))))))) + +(ert-deftest devops-execute-src-block-target-nil-from-property-test () + "`:target nil' works when inherited from a `header-args' property." + (devops-test--with-local-target target + (devops-test--with-org + (format (concat "#+TARGET: %s (local)\n\n" + "* Run\t\t:local:\n" + ":PROPERTIES:\n" + ":header-args: :target nil\n" + ":END:\n\n" + "#+begin_src sh\npwd\n#+end_src\n") + target) + (goto-char (point-min)) + (re-search-forward "begin_src") + (let ((here default-directory) + (org-confirm-babel-evaluate nil)) + (should (equal (file-name-as-directory + (file-truename (org-trim (org-babel-execute-src-block)))) + (file-name-as-directory (file-truename here)))))))) + +(ert-deftest devops-execute-src-block-unknown-target-errors-test () + "An unrecognized :target value errors rather than falling back to the tag." + (devops-test--with-local-target target + (devops-test--with-org + (format (concat "#+TARGET: %s (local)\n\n" + "* Run\t\t:local:\n\n" + "#+begin_src sh :target elsewhere\npwd\n#+end_src\n") + target) + (goto-char (point-min)) + (re-search-forward "begin_src") + (let ((org-confirm-babel-evaluate nil)) + (should-error (org-babel-execute-src-block) :type 'user-error))))) + ;;; Multi-target tangling (README: same file to several servers) (ert-deftest devops-tangle-multi-target-test () @@ -455,6 +668,70 @@ targets land next to the org file rather than in the system temp dir." (should (file-exists-p (concat t1 "foo.txt"))) (should (file-exists-p (concat t2 "foo.txt")))))))) +(ert-deftest devops-tangle-absolute-path-escapes-target-dir-test () + "An absolute :tangle path is not nested under a directory target." + (devops-test--with-local-target target + (devops-test--with-local-target elsewhere + (devops-test--with-org + (format (concat "#+TARGET: %s (local)\n\n" + "* Deploy\t\t:local:\n\n" + "#+begin_src txt :tangle %sapp.conf\n" + "key=val\n#+end_src\n") + target elsewhere) + (devops-tangle-headline (current-buffer) "Deploy") + (should (file-exists-p (concat elsewhere "app.conf"))) + ;; Not TARGET + ELSEWHERE glued together. + (should-not (file-exists-p + (concat target (substring elsewhere 1) "app.conf"))))))) + +(ert-deftest devops-tangle-subdirectory-test () + "A relative subdirectory lands under the target, spelled either way." + (devops-test--with-local-target target + (devops-test--with-org + (format (concat "#+TARGET: %s (local)\n\n" + "* Deploy\t\t:local:\n\n" + "#+begin_src txt :tangle conf/a.txt :mkdirp yes\n" + "a\n#+end_src\n\n" + "#+begin_src txt :tangle ./conf/b.txt :mkdirp yes\n" + "b\n#+end_src\n") + target) + (devops-tangle-headline (current-buffer) "Deploy") + (should (file-exists-p (concat target "conf/a.txt"))) + (should (file-exists-p (concat target "conf/b.txt")))))) + +(ert-deftest devops-tangle-target-nil-tangles-locally-test () + "`:target nil' tangles beside the org file, leaving the target alone." + (devops-test--with-local-target target + (devops-test--with-local-target here + (devops-test--with-org + (format (concat "#+TARGET: %s (local)\n\n" + "* Deploy\t\t:local:\n\n" + "#+begin_src txt :tangle remote.txt\n" + "to the server\n#+end_src\n\n" + "#+begin_src txt :target nil :tangle local.txt\n" + "stays here\n#+end_src\n") + target) + (let ((default-directory here)) + (devops-tangle-headline (current-buffer) "Deploy")) + (should (file-exists-p (concat target "remote.txt"))) + (should (file-exists-p (concat here "local.txt"))) + ;; The opted-out block is not pushed to the target... + (should-not (file-exists-p (concat target "local.txt"))) + ;; ...and the targeted one is not left behind locally. + (should-not (file-exists-p (concat here "remote.txt"))))))) + +(ert-deftest devops-tangle-paths-target-nil-test () + "`devops--tangle-paths' names one local file for an opted-out block." + (devops-test--with-org + (concat "#+TARGET: /srv/one/ (t1)\n" + "#+TARGET: /srv/two/ (t2)\n\n" + "* Deploy\t\t:t1:t2:\n\n" + "#+begin_src txt :target nil :tangle foo.txt\nhi\n#+end_src\n") + (goto-char (point-min)) + (re-search-forward "begin_src") + (should (equal (devops--tangle-paths) + (list (expand-file-name "foo.txt")))))) + ;;; Noweb (README: secrets via <>, per-server blocks) (ert-deftest devops-tangle-noweb-executes-block-test () @@ -617,6 +894,47 @@ afterwards), in an org buffer visiting the formatted text." (goto-char (point-min)) (should-not (search-forward ":tangle /ssh:other:" nil t))))) +(ert-deftest devops--drift-rewrite-tangle-paths-target-nil-test () + "An opted-out block is left out of the mapping and neutralized." + (devops-test--with-org + (concat "* Heading\n\n" + "#+begin_src sh :tangle ~/foo.txt\n" + "echo hi\n#+end_src\n\n" + "#+begin_src sh :target nil :tangle ~/bar.txt\n" + "echo hi\n#+end_src\n") + (let ((mapping (devops--drift-rewrite-tangle-paths "/ssh:host1:" "/tmp/root"))) + (should (= 1 (length mapping))) + (should (equal (car mapping) + '("~/foo.txt" "/tmp/root/home/foo.txt" + "/ssh:host1:~/foo.txt"))) + ;; Neutralized, not merely unmapped: a drift check must not write + ;; the block's own path either. + (goto-char (point-min)) + (should (search-forward ":tangle no" nil t)) + (goto-char (point-min)) + (should-not (search-forward ":tangle ~/bar.txt" nil t))))) + +(ert-deftest devops-drift-check-target-nil-skipped-test () + "A block that opted out of the target is not drift-checked." + (devops-test--with-local-target target + (devops-test--with-local-target here + (devops-test--with-org + (format (concat "#+TARGET: %s (local)\n\n" + "* Deploy\t\t:local:\n\n" + "#+begin_src txt :tangle foo.txt\nhello\n#+end_src\n\n" + "#+begin_src txt :target nil :tangle local.txt\n" + "stays here\n#+end_src\n") + target) + (let ((default-directory here)) + (devops-tangle-headline (current-buffer) "Deploy")) + (let* ((result (devops--drift-check (current-buffer) t)) + (entries (cdr result))) + (unwind-protect + (progn + (should (= 1 (length entries))) + (should (equal (plist-get (car entries) :path) "foo.txt"))) + (delete-directory (car result) t))))))) + (ert-deftest devops-drift-check-in-sync-test () "A target that matches its tangled output reports `same'." (devops-test--with-local-target target diff --git a/devops.el b/devops.el index dc8ebb7..78b063e 100644 --- a/devops.el +++ b/devops.el @@ -90,13 +90,77 @@ user to select one." (let ((dir (devops--heading-target-dir))) (org-entry-put nil "header-args" (format ":dir %s" dir)))) -(defun devops--inject-header-args-from-tags (orig-fn &optional arg info params _babel-call) - "Advise org-babel-execute-src-block to inject :dir" - (let* ((dir (devops--heading-target-dir)) +(defconst devops--target-none-values '(nil "nil" "none") + "Values of a :target header argument that mean \"no target\". +Org reads a header value as a string, so a block written `:target nil' +arrives as \"nil\". A genuine nil is accepted too, for params passed to +`org-babel-execute-src-block' from Lisp.") + +(defun devops--block-params (info) + "Return the header arguments of the src block being executed. +INFO is the src block info given to `org-babel-execute-src-block', or nil +when point is on the block. Covers header arguments on the block itself, +on a #+header: line, inherited from a `header-args' property, and the +defaults in `org-babel-default-header-args'." + (nth 2 (or info + (ignore-errors + (org-babel-get-src-block-info 'no-eval))))) + +(defun devops--header-cell (key params block-params) + "Return the (KEY . VALUE) header argument in effect, or nil. +PARAMS is the override alist given to `org-babel-execute-src-block' and +BLOCK-PARAMS the block's own header arguments. PARAMS wins, as it does +in `org-babel-merge-params'." + (or (assq key params) + (assq key block-params))) + +(defun devops--target-opted-out-p (params block-params) + "Return non-nil if a :target header opts the block out of its heading's target. +PARAMS and BLOCK-PARAMS are as in `devops--header-cell'. Signal an error +for any :target value other than those in `devops--target-none-values': +running on the heading's target is the wrong answer when the block asked +for something else, and silence would hide the mistake until it landed on +a server." + (when-let* ((cell (devops--header-cell :target params block-params))) + (or (member (cdr cell) devops--target-none-values) + (user-error "Unknown :target value %S (expected nil)" (cdr cell))))) + +(defun devops--target-opted-out-regions () + "Return (BEG . END) for each src block that opts out of its heading's target. +Covers the accessible portion of the buffer, so a narrowed subtree yields +only its own blocks. Header arguments are read with the same merge rules +as execution, so a `:target nil' inherited from a `header-args' property +counts. The regions let a textual :tangle rewrite tell an opted-out +block's header from any other." + (org-element-map (org-element-parse-buffer 'element) 'src-block + (lambda (el) + (save-excursion + (goto-char (org-element-property :post-affiliated el)) + (when (devops--target-opted-out-p nil (devops--block-params nil)) + (cons (org-element-property :begin el) + (org-element-property :end el))))))) + +(defun devops--in-regions-p (pos regions) + "Return non-nil if POS falls inside one of REGIONS, a list of (BEG . END)." + (catch 'hit + (dolist (region regions) + (when (and (>= pos (car region)) (< pos (cdr region))) + (throw 'hit t))))) + +(defun devops--inject-header-args-from-tags (orig-fn &optional arg info params executor-type) + "Advise org-babel-execute-src-block to inject :dir from #+TARGET tags. +An explicit :dir wins: the heading's target is neither resolved nor +prompted for when the block already carries one. `:target nil' opts the +block out of the heading's target without naming a directory, leaving +:dir to org." + (let* ((block-params (devops--block-params info)) + (dir (unless (or (devops--target-opted-out-p params block-params) + (devops--header-cell :dir params block-params)) + (devops--heading-target-dir))) (params (if dir (cons (cons :dir dir) params) params))) - (funcall orig-fn arg info params))) + (apply orig-fn arg info params (and executor-type (list executor-type))))) (advice-add 'org-babel-execute-src-block :around #'devops--inject-header-args-from-tags) @@ -117,40 +181,77 @@ Blocks matching other tags get renamed to avoid resolution." (concat prefix basename) (concat prefix "_devops-excluded-" basename "-" block-tag))))))) +(defun devops--split-target (target) + "Split TARGET into a (PREFIX . ROOT) cons. +PREFIX is the TRAMP method/host header and ROOT the directory part: +\"/ssh:host:\" splits into (\"/ssh:host:\" . \"\"), \"/ssh:host:/etc\" into +\(\"/ssh:host:\" . \"/etc\"), and a local \"/srv/app\" into +\(\"\" . \"/srv/app\"). The split goes through `tramp-dissect-file-name' +rather than `file-remote-p', which reports only the last hop of a +multi-hop target like \"/ssh:host|podman:box:\"." + (if (tramp-tramp-file-p target) + (let ((root (tramp-file-name-localname (tramp-dissect-file-name target)))) + (cons (substring target 0 (- (length target) (length root))) root)) + (cons "" target))) + (defun devops--join-target (target path) - "Join TARGET prefix onto a relative :tangle PATH with one separator. -TARGET is a #+TARGET value (a directory or TRAMP prefix); PATH is a -relative :tangle filename. A \"/\" is inserted between them unless TARGET -already ends in \"/\" or \":\". A trailing \":\" marks a TRAMP method/host -prefix (e.g. \"/ssh:host:\") whose bare form already means the remote -login directory, so no separator is added there. - -This keeps awkward targets honest: \".\" yields \"./PATH\" (not the hidden -file \".PATH\") and \"/srv/app\" yields \"/srv/app/PATH\" (not -\"/srv/appPATH\")." - (if (or (string-suffix-p "/" target) - (string-suffix-p ":" target)) - (concat target path) - (concat target "/" path))) - -(defun devops--rewrite-tangle-paths (tramp-prefix) + "Join TARGET onto a :tangle PATH, reading PATH as its machine would. +TARGET is a #+TARGET value: a TRAMP prefix, a directory, or both. + +A relative PATH lands under TARGET's directory, with exactly one +separator between them. This keeps awkward targets honest: \".\" yields +\"./PATH\" (not the hidden file \".PATH\") and \"/srv/app\" yields +\"/srv/app/PATH\" (not \"/srv/appPATH\"). A leading \"./\" is dropped, so +\"./dir/f\" and \"dir/f\" name one file rather than two spellings of it. + +An absolute PATH (\"/etc/f\") or a home-relative one (\"~/f\") is already +absolute on TARGET's machine, so it replaces TARGET's directory and keeps +only its TRAMP prefix: at \"/ssh:host:/opt\", \"/etc/f\" is +\"/ssh:host:/etc/f\", not \"/ssh:host:/opt/etc/f\". \"~\" is left for TRAMP +to expand when the file is written, on the machine it belongs to." + (let* ((split (devops--split-target target)) + (prefix (car split)) + (root (cdr split)) + (path (if (string-prefix-p "./" path) (substring path 2) path))) + (cond + ((or (string-prefix-p "/" path) + (string-prefix-p "~" path)) + (concat prefix path)) + ((or (string= "" root) + (string-suffix-p "/" root)) + (concat prefix root path)) + (t + (concat prefix root "/" path))))) + +(defun devops--rewrite-tangle-paths (tramp-prefix &optional local-dir) "Rewrite :tangle header args in buffer to include TRAMP-PREFIX. Modifies buffer text. Skips :tangle no, :tangle yes, and paths already -containing a TRAMP prefix." - (save-excursion - (goto-char (point-max)) - (while (re-search-backward - ":tangle +\\([^ \t\n]+\\)" - nil t) - (let ((path (match-string 1))) - (when (and (not (member path '("no" "yes"))) - (not (tramp-tramp-file-p path))) - (replace-match (concat ":tangle " - (devops--join-target tramp-prefix path))) - ;; Step before the rewrite so the backward search keeps making - ;; progress. Otherwise a local (non-TRAMP) prefix would leave the - ;; rewritten path matchable and we'd re-prefix it forever. - (goto-char (match-beginning 0))))))) +containing a TRAMP prefix. + +A block that opted out with `:target nil' keeps its own path: the target +is off for tangling exactly as it is for execution, so the file lands +locally. Such a relative path is expanded against LOCAL-DIR, since +tangling runs in a temp buffer whose directory is the system temp dir and +`org-babel-tangle' would otherwise resolve it there." + (let ((opted-out (devops--target-opted-out-regions))) + (save-excursion + (goto-char (point-max)) + (while (re-search-backward + ":tangle +\\([^ \t\n]+\\)" + nil t) + (let ((path (match-string 1)) + (beg (match-beginning 0))) + (when (and (not (member path '("no" "yes"))) + (not (tramp-tramp-file-p path))) + (replace-match + (concat ":tangle " + (if (devops--in-regions-p beg opted-out) + (if local-dir (expand-file-name path local-dir) path) + (devops--join-target tramp-prefix path)))) + ;; Step before the rewrite so the backward search keeps making + ;; progress. Otherwise a local (non-TRAMP) prefix would leave the + ;; rewritten path matchable and we'd re-prefix it forever. + (goto-char beg))))))) (defun devops--tangle-heading (source-buf heading-pos tag target) "Tangle subtree at HEADING-POS from SOURCE-BUF to TARGET. @@ -161,11 +262,12 @@ A relative local TARGET (e.g. \".\" or \"../foo\") is expanded against SOURCE-BUF's directory before tangling. Tangling runs in a temp buffer whose file lives in the system temp dir, so without this a relative target would silently resolve against the temp dir instead of the org -file. TRAMP targets are left untouched." - (let* ((target (if (tramp-tramp-file-p target) +file. TRAMP targets are left untouched. Blocks that opted out of the +target with `:target nil' resolve against that same directory." + (let* ((local-dir (buffer-local-value 'default-directory source-buf)) + (target (if (tramp-tramp-file-p target) target - (expand-file-name - target (buffer-local-value 'default-directory source-buf)))) + (expand-file-name target local-dir))) (tmp-file (make-temp-file "devops-tangle-" nil ".org")) (tmp-buf (find-file-noselect tmp-file))) (unwind-protect @@ -177,7 +279,7 @@ file. TRAMP targets are left untouched." (org-narrow-to-subtree) (let* ((files (progn (devops--specialize-noweb-blocks tag) - (devops--rewrite-tangle-paths target) + (devops--rewrite-tangle-paths target local-dir) (org-babel-tangle)))) (widen) (when files (length files))))) @@ -293,18 +395,23 @@ argument. SOURCE-BUF must be an org-mode buffer." (devops--tangle-spec-execute source-buf (devops--tangle-spec t)))) (defun devops--tangle-paths () - "Return a list of file paths expanded with each target" - (let* ((spec (devops--tangle-spec)) - (params (nth 2 (org-babel-get-src-block-info))) + "Return a list of file paths expanded with each target. +A block that opted out with `:target nil' names one local file, resolved +like any other path in this buffer, rather than one file per target." + (let* ((params (nth 2 (org-babel-get-src-block-info))) (path (cdr (assq :tangle params)))) - (if (or (not path) - (member path '("no" "yes")) - (tramp-tramp-file-p path)) - nil + (cond + ((or (not path) + (member path '("no" "yes")) + (tramp-tramp-file-p path)) + nil) + ((devops--target-opted-out-p nil params) + (list (expand-file-name path))) + (t (mapcar (lambda (entry) (let ((target (plist-get entry :target))) (devops--join-target target path))) - spec)))) + (devops--tangle-spec)))))) (defun devops-visit-file (&optional arg) "Go to file at of source code block at point.