[nongnu] elpa/hyperdrive 8a453f0eb4 14/82: WIP: All tests passing! (so far)

[ELPA Syncer]

branch: elpa/hyperdrive
commit 8a453f0eb406b5ee57c933250614e7af134c2533
Author: Adam Porter <adam@alphapapa.net>
Commit: Adam Porter <adam@alphapapa.net>

    WIP: All tests passing! (so far)
---
 hyperdrive-lib.el                 | 17 +++++++----
 hyperdrive-org.el                 | 63 ++++++++++++++++++++++++++++++++-------
 tests/test-hyperdrive-org-link.el | 32 ++++++++++++--------
 tests/test-hyperdrive.el          | 23 ++++++++++++--
 4 files changed, 104 insertions(+), 31 deletions(-)

diff --git a/hyperdrive-lib.el b/hyperdrive-lib.el
index f5fae59e0f..85975def50 100644
--- a/hyperdrive-lib.el
+++ b/hyperdrive-lib.el
@@ -64,7 +64,7 @@ Passes ARGS to `format-message'."
   ;; could theoretically contain a slash, and `file-name-nondirectory'
   ;; would return the wrong value in that case.
   (name nil :documentation "Decoded filename of entry (excluding leading 
slash).")
-  (path nil :documentation "Encoded path (including leading slash).")
+  (path nil :documentation "Decoded path (including leading slash).")
   (headers nil :documentation "HTTP headers from request.")
   (mtime nil :documentation "Last modified time.")
   (size nil :documentation "Size of file.")
@@ -97,6 +97,12 @@ domains slot."
                (host (or public-key (car domains))))
     (concat "hyper://" host)))
 
+(defun hyperdrive--url-hexify-string (string)
+  "Return STRING having been URL-encoded.
+Calls `url-hexify-string' with the \"/\" character added to
+`url-unreserved-chars'."
+  (url-hexify-string string (cons ?/ url-unreserved-chars)))
+
 (defun hyperdrive-entry-url (entry)
   "Return ENTRY's canonical URL.
 Returns URL with hyperdrive's full public key."
@@ -267,14 +273,15 @@ before making the entry struct."
                               (or (gethash host hyperdrive-hyperdrives)
                                   (hyperdrive-create :public-key host)))))
                (etc (when target
-                      (list (cons 'target target))))
+                      (list (cons 'target (url-unhex-string target)))))
                (version (pcase path
                           ((rx "/$/version/" (let v (1+ num)) (let p (0+ 
anything)))
                            (setf path p)
                            (string-to-number v)))))
     ;; e.g. for hyper://PUBLIC-KEY/path/to/basename, we do:
     ;; :path "/path/to/basename" :name "basename"
-    (hyperdrive-entry-create :hyperdrive hyperdrive :path path :version 
version :etc etc)))
+    (hyperdrive-entry-create :hyperdrive hyperdrive :path (url-unhex-string 
path)
+                             :version version :etc etc)))
 
 ;;;; Entries
 
@@ -964,9 +971,9 @@ URL."
                (version-part (and version (format "/$/version/%s" version)))
                ((map target) etc)
                (target-part (when (and with-target target)
-                              (concat fragment-prefix target)))
+                              (concat fragment-prefix 
(hyperdrive--url-hexify-string target))))
                (path (when with-path
-                       path))
+                       (hyperdrive--url-hexify-string path)))
                (url (concat protocol host version-part path target-part)))
     (if with-help-echo
         (propertize url
diff --git a/hyperdrive-org.el b/hyperdrive-org.el
index 2118e7a431..dcc38307e4 100644
--- a/hyperdrive-org.el
+++ b/hyperdrive-org.el
@@ -166,30 +166,71 @@ Otherwise, follow setting in `org-link-file-path-type'."
   (when (and hyperdrive-mode hyperdrive-current-entry)
     (let* ((link-element (org-element-context))
            (_ (cl-assert (eq 'link (car link-element))))
-           (target-entry (hyperdrive-url-entry (org-element-property :raw-link 
link-element)))
+           (url (org-element-property :raw-link link-element))
+           (target-entry (hyperdrive-url-entry url))
            (host-format '(public-key)) (with-path t) (with-protocol t)
-           fragment-prefix)
-      (cond ((hyperdrive-entry-equal-p hyperdrive-current-entry target-entry)
+           fragment-prefix destination)
+      (cond (hyperdrive-org-link-full-url
+             ;; User wants only full "hyper://" URLs.
+             (when (alist-get 'target (hyperdrive-entry-etc target-entry))
+               (setf fragment-prefix (concat "#" (url-hexify-string "::")))
+               (cl-callf url-hexify-string (alist-get 'target 
(hyperdrive-entry-etc target-entry))))
+             (setf destination (hyperdrive--format-entry-url
+                                target-entry :fragment-prefix fragment-prefix
+                                :with-path with-path
+                                :with-protocol with-protocol :host-format 
host-format)))
+            ((hyperdrive-entry-equal-p hyperdrive-current-entry target-entry)
              ;; Link points to same file on same hyperdrive: make link
              ;; relative.
              (setf with-protocol nil
                    host-format nil
-                   with-path nil))
+                   with-path (if (alist-get 'target (hyperdrive-entry-etc 
target-entry))
+                                 nil t)
+                   destination (concat "./"
+                                       (file-relative-name
+                                        (hyperdrive-entry-path target-entry)
+                                        (file-name-directory 
(hyperdrive-entry-path target-entry)))))
+             (pcase org-link-file-path-type
+               ((or 'absolute 'noabbrev)
+                ;; These two options are the same for our purposes,
+                ;; because hyperdrives have no home directory.
+                (setf destination (hyperdrive-entry-path target-entry)))
+               ('adaptive
+                (setf destination
+                      (if (string-prefix-p (file-name-parent-directory
+                                            (hyperdrive-entry-path 
hyperdrive-current-entry))
+                                           (hyperdrive-entry-path 
target-entry))
+                          ;; Link points to file in same directory tree: use 
relative link.
+                          (concat "./"
+                                  (file-relative-name
+                                   (hyperdrive-entry-path target-entry)
+                                   (file-name-directory (hyperdrive-entry-path 
target-entry))))
+                        (hyperdrive-entry-path target-entry))))
+               ('relative
+                (setf destination
+                      (concat "./"
+                              (file-relative-name
+                               (hyperdrive-entry-path target-entry)
+                               (file-name-directory (hyperdrive-entry-path 
target-entry))))))))
             ((hyperdrive-entry-hyperdrive-equal-p hyperdrive-current-entry 
target-entry)
              ;; Link points to same hyperdrive as the file the link is in:
              ;; make link relative.
              (setf with-protocol nil
-                   host-format nil))
+                   host-format nil
+                   destination (concat "./"
+                                       (file-relative-name
+                                        (hyperdrive-entry-path target-entry)
+                                        (file-name-directory 
(hyperdrive-entry-path target-entry))))))
             (t
              (setf fragment-prefix (concat "#" (url-hexify-string "::")))
-             (cl-callf url-hexify-string (alist-get 'target 
(hyperdrive-entry-etc target-entry)))))
+             (cl-callf url-hexify-string (alist-get 'target 
(hyperdrive-entry-etc target-entry)))
+             (setf destination (hyperdrive--format-entry-url
+                                target-entry :fragment-prefix fragment-prefix
+                                :with-path with-path
+                                :with-protocol with-protocol :host-format 
host-format))))
       (delete-region (org-element-property :begin link-element)
                      (org-element-property :end link-element))
-      (insert (org-link-make-string
-               (hyperdrive--format-entry-url
-                target-entry :fragment-prefix fragment-prefix
-                :with-path with-path
-                :with-protocol with-protocol :host-format host-format))))))
+      (insert (org-link-make-string destination)))))
 
 ;;;###autoload
 (with-eval-after-load 'org
diff --git a/tests/test-hyperdrive-org-link.el 
b/tests/test-hyperdrive-org-link.el
index bbb22be1ea..c12fe2218c 100644
--- a/tests/test-hyperdrive-org-link.el
+++ b/tests/test-hyperdrive-org-link.el
@@ -42,11 +42,11 @@
   (declare (indent defun))
   (let ((org-id-link-to-org-use-id nil)
         (default-directory "/")
-        (org-link-file-path-type
-         (lambda (path)
-           (replace-regexp-in-string (rx bos (optional "file:")
-                                         "/hyper:/")
-                                     "hyper://" path)))
+        ;; (org-link-file-path-type
+        ;;  (lambda (path)
+        ;;    (replace-regexp-in-string (rx bos (optional "file:")
+        ;;                                  "/hyper:/")
+        ;;                              "hyper://" path)))
         ;; (org-link-file-path-type
         ;;  (lambda (path)
         ;;    (string-trim-left (file-relative-name path)
@@ -91,21 +91,27 @@
 
 ;;     * No search option :: e.g. ~hyper://deadbeef/foo/bar%20quux.org~, which 
decodes to ~hyper://deadbeef/foo/bar quux.org~
 
-(cl-defmacro hyperdrive-test-org-link (name &key store-body store-from 
insert-into results)
+(cl-defmacro hyperdrive-test-org-link-deftest (name &key store-body store-from 
insert-into results)
   "FIXME: Docstring."
-  (declare (indent defun))
-  (let ((test-name (make-symbol (concat "hyperdrive-test-org-link/" 
(symbol-name name))))
+  (declare (indent defun)
+          ;; (debug (&define symbolp &rest [&or [":store-body" stringp]
+          ;;                                 [":store-from" sexp]
+          ;;                                 [":insert-into" sexp]
+          ;;                                 [":results" sexp]]))
+          )
+  (let ((test-name (intern (concat "hyperdrive-test-org-link/" (symbol-name 
name))))
         body-forms)
     (pcase-dolist ((map (:let vars) (:result result)) results)
       (push `(let (,@vars)
-               (should (equal (hyperdrive-test-org-link-roundtrip ,store-body
-                                :store-from ,store-from :insert-into 
,insert-into)
-                              ,result)))
+               (should (equal ,result
+                              (hyperdrive-test-org-link-roundtrip ,store-body
+                                :store-from ,store-from :insert-into 
,insert-into))))
             body-forms))
     `(ert-deftest ,test-name ()
+       "Docstring."
        ,@(nreverse body-forms))))
 
-(hyperdrive-test-org-link same-drive-same-file-before-heading
+(hyperdrive-test-org-link-deftest same-drive-same-file-before-heading
   :store-body "<|>
 * Heading A
 :PROPERTIES:
@@ -137,7 +143,7 @@
             
             ( :let ((org-link-file-path-type 'adaptive)
                     (hyperdrive-org-link-full-url nil))
-              :result "[[./foo/bar quux.org]]")
+              :result "[[./bar quux.org]]")
             ( :let ((org-link-file-path-type 'adaptive)
                     (hyperdrive-org-link-full-url t))
               :result "[[hyper://deadbeef/foo/bar%20quux.org]]")))
diff --git a/tests/test-hyperdrive.el b/tests/test-hyperdrive.el
index d8b4d3862a..ad3753220b 100644
--- a/tests/test-hyperdrive.el
+++ b/tests/test-hyperdrive.el
@@ -52,7 +52,7 @@
   (let ((name (intern (concat "hyperdrive-" (symbol-name name)))))
     `(cl-macrolet ((make-url
                      (&rest args) `(concat "hyper://" 
test-hyperdrive-public-key ,@args))
-                   (hexify (string) `(url-hexify-string ,string (cons ?/ 
url-unreserved-chars))))
+                   (hexify (string) `(hyperdrive--url-hexify-string ,string)))
        (ert-deftest ,name () ,@args))))
 
 ;;;; Tests
@@ -74,7 +74,7 @@
   (pcase-let (((cl-struct hyperdrive-entry name path)
                (hyperdrive-url-entry (make-url (hexify "/name with spaces")))))
     (should (equal name "name with spaces"))
-    (should (equal path "/name%20with%20spaces")))
+    (should (equal path "/name with spaces")))
   (pcase-let (((cl-struct hyperdrive-entry name path)
                (hyperdrive-url-entry (make-url "/subdir/"))))
     (should (equal name "subdir/"))
@@ -117,6 +117,25 @@
                ((cl-struct hyperdrive public-key) hyperdrive))
     (should (equal public-key test-hyperdrive-public-key))))
 
+(hyperdrive-deftest entry-url-round-trip ()
+
+  (let ((url (hyperdrive-entry-url (hyperdrive-url-entry (make-url "")))))
+    (should (equal url (concat "hyper://" test-hyperdrive-public-key "/"))))
+
+  (let ((url (hyperdrive-entry-url (hyperdrive-url-entry (make-url "/")))))
+    (should (equal url (concat "hyper://" test-hyperdrive-public-key "/"))))
+
+  (let ((url (hyperdrive-entry-url (hyperdrive-url-entry (make-url 
"/name-without-spaces")))))
+    (should (equal url (concat "hyper://" test-hyperdrive-public-key 
"/name-without-spaces"))))
+
+  (let ((url (hyperdrive-entry-url (hyperdrive-url-entry (make-url 
"/name%20without%20spaces")))))
+    (should (equal url (concat "hyper://" test-hyperdrive-public-key 
"/name%20without%20spaces"))))
+
+  (let ((url (hyperdrive-entry-url (hyperdrive-url-entry
+                                    (make-url 
"/name%20without%20spaces/subdir")))))
+    (should (equal url (concat "hyper://" test-hyperdrive-public-key
+                               "/name%20without%20spaces/subdir")))))
+
 ;;;; Link testing
 
 ;;;;; Opening links