Merge branch 'curl-transport-60'. Close #60

README.org

@@ -27,6 +27,7 @@
 
   - Linux
   - Emacs version from 24.1 to 24.5
+  - cURL 7.35.0+ (optional)
 
 ** Windows
 

curl-integration-tests.el

@@ -0,0 +1,71 @@
+(require 'ert)
+
+(add-to-list 'load-path ".")
+(load "org-cliplink.el")
+
+(setq org-cliplink-transport-implementation 'curl)
+(setq org-cliplink-curl-transport-arguments '("--insecure"))
+
+(ert-deftest org-cliplink-without-title--http ()
+  (let ((url "http://127.0.0.1:8001/without-title.html")
+        (expected-outcome "[[http://127.0.0.1:8001/without-title.html]]")
+        (timeout 5))
+    (with-temp-buffer
+      (kill-new url)
+      (org-cliplink)
+      (sleep-for timeout)
+      (should (equal (buffer-string) expected-outcome)))))
+
+(ert-deftest org-cliplink-simple-title--http ()
+  (let ((url "http://127.0.0.1:8001/http.html")
+        (expected-outcome "[[http://127.0.0.1:8001/http.html][Hello World]]")
+        (timeout 5))
+    (with-temp-buffer
+      (kill-new url)
+      (org-cliplink)
+      (sleep-for timeout)
+      (should (equal (buffer-string) expected-outcome)))))
+
+(ert-deftest org-cliplink-escape-title--http ()
+  (let ((url "http://127.0.0.1:8001/html4-escaping.html")
+        (expected-outcome "[[http://127.0.0.1:8001/html4-escaping.html][&{Hello} '{World} α  ]]")
+        (timeout 5))
+    (with-temp-buffer
+      (kill-new url)
+      (org-cliplink)
+      (sleep-for timeout)
+      (should (equal (buffer-string) expected-outcome)))))
+
+(ert-deftest org-cliplink-simple-title--https ()
+  (let ((url "https://127.0.0.1:4443/http.html")
+        (expected-outcome "[[https://127.0.0.1:4443/http.html][Hello World]]")
+        (timeout 5))
+    (with-temp-buffer
+      (kill-new url)
+      (org-cliplink)
+      (sleep-for timeout)
+      (should (equal (buffer-string) expected-outcome)))))
+
+(ert-deftest org-cliplink-simple-title--http-with-basic-auth ()
+  (let ((url "http://127.0.0.1:8003/http.html")
+        (expected-outcome "[[http://127.0.0.1:8003/http.html][Hello World]]")
+        (timeout 5)
+        (org-cliplink-secrets-path "./test-data/secrets/org-cliplink-basic-auth-it.el"))
+    (with-temp-buffer
+      (kill-new url)
+      (org-cliplink)
+      (sleep-for timeout)
+      (should (equal (buffer-string) expected-outcome)))))
+
+(ert-deftest org-cliplink-simple-title--https-with-basic-auth ()
+  (let ((url "https://127.0.0.1:4445/http.html")
+        (expected-outcome "[[https://127.0.0.1:4445/http.html][Hello World]]")
+        (timeout 5)
+        (org-cliplink-secrets-path "./test-data/secrets/org-cliplink-basic-auth-it.el"))
+    (with-temp-buffer
+      (kill-new url)
+      (org-cliplink)
+      (sleep-for timeout)
+      (should (equal (buffer-string) expected-outcome)))))
+
+(ert-run-tests-batch-and-exit)

org-cliplink-transport.el

@@ -0,0 +1,103 @@
+;;; org-cliplink-transport.el --- insert org-mode links from the clipboard -*- lexical-binding: t -*-
+
+;; Copyright (C) 2014 Alexey Kutepov a.k.a rexim
+
+;; Author: Alexey Kutepov <reximkut@gmail.com>
+;; Maintainer: Alexey Kutepov <reximkut@gmail.com>
+;; URL: http://github.com/rexim/org-cliplink
+;; Version: 0.2
+
+;; Permission is hereby granted, free of charge, to any person
+;; obtaining a copy of this software and associated documentation
+;; files (the "Software"), to deal in the Software without
+;; restriction, including without limitation the rights to use, copy,
+;; modify, merge, publish, distribute, sublicense, and/or sell copies
+;; of the Software, and to permit persons to whom the Software is
+;; furnished to do so, subject to the following conditions:
+
+;; The above copyright notice and this permission notice shall be
+;; included in all copies or substantial portions of the Software.
+
+;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
+;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
+;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
+;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
+;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
+;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
+;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+;; SOFTWARE.
+
+(require 'url-parse)
+
+(require 'org-cliplink-string)
+
+(defvar org-cliplink-block-authorization nil
+  "Flag whether to block url.el's usual interactive authorisation procedure")
+
+(defadvice url-http-handle-authentication (around org-cliplink-fix)
+  (unless org-cliplink-block-authorization
+    ad-do-it))
+(ad-activate 'url-http-handle-authentication)
+
+(defun org-cliplink-credentials-to-basic-auth (username password)
+  (concat "Basic " (base64-encode-string
+                    (concat username ":" password))))
+
+(defun org-cliplink-curl-prepare-response-buffer-name (url)
+  (format " *curl-%s-%x*"
+          (url-host (url-generic-parse-url url))
+          (random)))
+
+(defun org-cliplink-build-curl-arguments (url basic-auth-credentials extra-curl-arguments)
+  (append extra-curl-arguments
+          (list "--include"
+                "--silent"
+                "--show-error"
+                "-X"
+                "GET")
+          (when basic-auth-credentials
+            (let ((username (plist-get basic-auth-credentials :username))
+                  (password (plist-get basic-auth-credentials :password)))
+              (list "--user"
+                    (format "%s:%s" username password))))
+          (list url)))
+
+(defun org-cliplink-make-curl-sentinel (response-buffer-name callback)
+  (lambda (process event)
+    (when (not (process-live-p process))
+      (if (zerop (process-exit-status process))
+          (when callback
+            (with-current-buffer response-buffer-name
+              (funcall callback nil)))
+        (with-current-buffer response-buffer-name
+          (error (buffer-string)))))))
+
+(defun org-cliplink-http-get-request--curl (url callback &optional basic-auth-credentials extra-curl-arguments)
+  (let* ((response-buffer-name (org-cliplink-curl-prepare-response-buffer-name url))
+         (curl-arguments (org-cliplink-build-curl-arguments url
+                                                            basic-auth-credentials
+                                                            extra-curl-arguments))
+         (curl-process (progn (message "Starting cURL...")
+                              (apply #'start-process
+                                     "curl"
+                                     response-buffer-name
+                                     (executable-find "curl")
+                                     curl-arguments))))
+    (set-process-sentinel curl-process
+                          (org-cliplink-make-curl-sentinel response-buffer-name
+                                                           callback))))
+
+(defun org-cliplink-http-get-request--url-el (url callback &optional basic-auth-credentials)
+  (if basic-auth-credentials
+      (let* ((org-cliplink-block-authorization t)
+             (username (plist-get basic-auth-credentials :username))
+             (password (plist-get basic-auth-credentials :password))
+             (url-request-extra-headers
+              `(("Authorization" . ,(org-cliplink-credentials-to-basic-auth
+                                     username password)))))
+        (url-retrieve url callback))
+    (url-retrieve url callback)))
+
+(provide 'org-cliplink-transport)
+
+;;; org-cliplink-transport.el ends here

org-cliplink.el

@@ -52,6 +52,7 @@
 (require 'em-glob)
 
 (require 'org-cliplink-string)
+(require 'org-cliplink-transport)
 
 (defconst org-cliplink-basic-escape-alist
   '((""" . "\"")             ;; " - double-quote
@@ -366,9 +367,6 @@
             ("\\]" . "}")
             ("&#\\([0-9]+\\);" . org-cliplink-escape-numeric-match))))
 
-(defvar org-cliplink-block-authorization nil
-  "Flag whether to block url.el's usual interactive authorisation procedure")
-
 (defgroup org-cliplink nil
   "A simple command that takes a URL from the clipboard and inserts an
 org-mode link with a title of a page found by the URL into the current
@@ -391,10 +389,19 @@ services."
   :group 'org-cliplink
   :type 'string)
 
-(defadvice url-http-handle-authentication (around org-cliplink-fix)
-  (unless org-cliplink-block-authorization
-    ad-do-it))
-(ad-activate 'url-http-handle-authentication)
+(defcustom org-cliplink-transport-implementation 'url-el
+  "The transport implementation.
+Supported transports are `url-el' and `curl'. `curl' is
+experimental so use it on your own risk."
+  :group 'org-cliplink
+  :type 'symbol)
+
+(defcustom org-cliplink-curl-transport-arguments '()
+  "Additional arguments for cURL.
+Used when the current transport implementation is set to
+`curl'."
+  :group 'org-cliplink
+  :type '(repeat string))
 
 (defun org-cliplink-clipboard-content ()
   (substring-no-properties (current-kill 0)))
@@ -478,10 +485,6 @@ services."
                            (plist-get secret :url-pattern)) url)
         (return secret)))))
 
-(defun org-cliplink-credentials-to-basic-auth (username password)
-  (concat "Basic " (base64-encode-string
-                    (concat username ":" password))))
-
 ;;;###autoload
 (defun org-cliplink-retrieve-title (url title-callback)
   (let* ((dest-buffer (current-buffer))
@@ -498,15 +501,10 @@ services."
               (let ((title (org-cliplink-extract-and-prepare-title-from-current-buffer)))
                 (with-current-buffer dest-buffer
                   (funcall title-callback url title)))))))
-    (if basic-auth
-      (let* ((org-cliplink-block-authorization t)
-             (basic-auth-username (plist-get basic-auth :username))
-             (basic-auth-password (plist-get basic-auth :password))
-             (url-request-extra-headers
-              `(("Authorization" . ,(org-cliplink-credentials-to-basic-auth
-                                     basic-auth-username basic-auth-password)))))
-        (url-retrieve url url-retrieve-callback))
-      (url-retrieve url url-retrieve-callback))))
+    (if (equal 'curl org-cliplink-transport-implementation)
+        (org-cliplink-http-get-request--curl url url-retrieve-callback basic-auth
+                                             org-cliplink-curl-transport-arguments)
+      (org-cliplink-http-get-request--url-el url url-retrieve-callback basic-auth))))
 
 ;;;###autoload
 (defun org-cliplink-insert-transformed-title (url transformer)

run-travis-ci.sh

@@ -11,5 +11,6 @@ echo "Starting testing server..."
 ./run-testing-server.py &
 sleep 1
 
-emacs --batch --no-site-file --no-splash -l ert --script integration-tests.el || exit 1
+emacs --batch --no-site-file --no-splash -l ert --script url-el-integration-tests.el || exit 1
+emacs --batch --no-site-file --no-splash -l ert --script curl-integration-tests.el || exit 1
 cask exec ert-runner || exit 1

test/org-cliplink-test.el

@@ -55,10 +55,6 @@
                    '(:url-pattern "http://rexim.me/*" :username "horta" :password "hell")))
     (should (not (org-cliplink-check-basic-auth-for-url "http://fornever.me/test")))))
 
-(ert-deftest org-cliplink-credentials-to-basic-auth-test ()
-  (should (equal "Basic aGVsbG86d29ybGQ="
-                 (org-cliplink-credentials-to-basic-auth "hello" "world"))))
-
 (ert-deftest org-cliplink-extract-and-prepare-title-from-current-buffer-test ()
   (with-mock
    (stub org-cliplink-parse-response =>
@@ -104,4 +100,3 @@
   (kill-append "khooy" nil)
   (should (equal "khooy"
                  (org-cliplink-clipboard-content))))
-

test/org-cliplink-transport-test.el

@@ -0,0 +1,43 @@
+;;; -*- lexical-binding: t -*-
+
+(ert-deftest org-cliplink-curl-prepare-response-buffer-name ()
+  (let ((url "http://rexim.me/"))
+    (should (string-match " \\*curl-rexim.me-[a-z0-9]+"
+                          (org-cliplink-curl-prepare-response-buffer-name url)))))
+
+(ert-deftest org-cliplink-credentials-to-basic-auth-test ()
+  (should (equal "Basic aGVsbG86d29ybGQ="
+                 (org-cliplink-credentials-to-basic-auth "hello" "world"))))
+
+(ert-deftest org-cliplink-build-curl-arguments-test ()
+  (let* ((url "http://rexim.me")
+         (username "rexim")
+         (password "nyasha")
+         (extra-arguments (list "--secure"))
+         (expected-output (list "--secure"
+                                "--include"
+                                "--silent"
+                                "--show-error"
+                                "-X" "GET"
+                                "--user"
+                                (concat username ":" password)
+                                url)))
+    (should (equal expected-output
+                   (org-cliplink-build-curl-arguments url
+                                                      (list :username username
+                                                            :password password)
+                                                      extra-arguments)))))
+
+(ert-deftest org-cliplink-make-curl-sentinel-test ()
+  (let* ((process 42)
+         (callback-invoked nil)
+         (response-buffer-name "khooy"))
+    (with-mock
+     (mock (process-live-p 42) => nil)
+     (mock (process-exit-status 42) => 0)
+     (mock (curl-sentinel-callback-mock nil) => nil :times 1)
+     (let ((sentinel (org-cliplink-make-curl-sentinel
+                      response-buffer-name
+                      #'curl-sentinel-callback-mock)))
+       (generate-new-buffer response-buffer-name)
+       (funcall sentinel process nil)))))

integration-tests.el → url-el-integration-tests.el

@@ -3,6 +3,8 @@
 (add-to-list 'load-path ".")
 (load "org-cliplink.el")
 
+(customize-set-variable org-cliplink-transport-implementation 'url-el)
+
 (ert-deftest org-cliplink-without-title--http ()
   (let ((url "http://127.0.0.1:8001/without-title.html")
         (expected-outcome "[[http://127.0.0.1:8001/without-title.html]]")