cgit.sxemacs.org Git - sxemacs/blob - lisp/ffi/ffi-curl.el

   1 ;;; ffi-curl.el --- Emacs interface to libcurl.
   2
   3 ;; Copyright (C) 2005-2009 by Zajcev Evgeny.
   4
   5 ;; Author: Zajcev Evgeny <zevlg@yandex.ru>
   6 ;; Keywords: ffi, curl, ftp
   7
   8 ;; This file is part of SXEmacs.
   9
  10 ;; SXEmacs is free software: you can redistribute it and/or modify
  11 ;; it under the terms of the GNU General Public License as published by
  12 ;; the Free Software Foundation, either version 3 of the License, or
  13 ;; (at your option) any later version.
  14
  15 ;; SXEmacs is distributed in the hope that it will be useful,
  16 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  17 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
  18 ;; GNU General Public License for more details.
  19
  20 ;; You should have received a copy of the GNU General Public License
  21 ;; along with this program.  If not, see <http://www.gnu.org/licenses/>.
  22
  23 ;;; Synched up with: Not in FSF
  24
  25 ;;; Commentary:
  26
  27 ;;
  28
  29 ;;; Code:
  30 \f
  31 (require 'ffi)
  32 (require 'ffi-libc)
  33
  34 (ffi-load "libcurl")
  35
  36 ;;{{{ Low-level FFI: types and functions
  37
  38 (define-ffi-enum curl-option
  39   (:fstream 10001)                      ; FILE* stream to write to
  40   (:url 10002)                          ; full URL to get/put
  41   (:port 3)                             ; port number to connect to
  42   (:write-function 20011)
  43   (:read-function 20012)
  44   (:timeout 13)                         ; read timeout in seconds
  45   (:post-fields 10015)                  ; POST static input fields
  46   (:header 42)                          ; throw the header out too
  47   (:nobody 44)                          ; use HEAD to get http document
  48   (:post 47)                            ; HTTP POST method
  49   (:nosignal 99)
  50   )
  51
  52 (define-ffi-enum curl-info
  53   (:effective-url  #x100001)
  54   (:response-code  #x200002)
  55   (:header-size    #x20000b)
  56   (:content-type   #x100012)
  57   (:size-download  #x300008)
  58   (:speed-download #x300009))
  59
  60 (cffi:defcfun ("curl_easy_init" curl:curl_easy_init) pointer)
  61 (cffi:defcfun ("curl_easy_cleanup" curl:curl_easy_cleanup) void
  62   (handler pointer))
  63 (cffi:defcfun ("curl_easy_perform" curl:curl_easy_perform) int
  64   (handler pointer))
  65
  66 (cffi:defcfun ("curl_easy_setopt" curl:curl_easy_setopt) int
  67   (handler pointer) (opt curl-option) &rest)
  68 (cffi:defcfun ("curl_easy_getinfo" curl:curl_easy_getinfo) int
  69   (handler pointer) (info curl-info) &rest)
  70
  71 ;;}}}
  72 \f
  73 ;;{{{ Errors list
  74
  75 (defconst curl:errors-alist
  76   '((1 . "Unsupported protocol")
  77     (2 . "Failed init")
  78     (3 . "Malformated URL")
  79     (4 . "NOT USED")
  80     (5 . "Could not resolve proxy")
  81     (6 . "Could not resolve host")
  82     (7 . "Could not connect")
  83     (8 . "FTP weird server reply")
  84     (9 . "FTP access denied")
  85     (10 . "FTP user or password is incorrect")
  86     (11 . "FTP weird PASS reply")
  87     (12 . "FTP weird USER reply")
  88     (13 . "FTP weird PASV reply")
  89     (14 . "FTP weird 227 format")
  90     (15 . "FTP can't get host")
  91     (16 . "FTP can't reconnect")
  92     (17 . "FTP could not set binary")
  93     (18 . "partial file")
  94     (19 . "FTP could not RETR file")
  95     (20 . "FTP write error")
  96     (21 . "FTP quote error")
  97     (22 . "HTTP returned errror")
  98     (23 . "write error")
  99     (24 . "NOT USED")
 100     (25 . "failed FTP upload")
 101     (26 . "could open/read from file")
 102     (27 . "Out of memory")
 103     (28 . "the timeout time was reached")
 104     (29 . "TYPE A failed")
 105     (30 . "FTP PORT operation failed")
 106     (31 . "the REST command failed")
 107     (32 . "the SIZE command failed")
 108     (33 . "RANGE \"command\" didn't work")
 109     (34 . "HTTP port error")
 110     (35 . "wrong when connecting with SSL")
 111     (36 . "couldn't resume download")
 112     (37 . "FILE could not read file")
 113     (38 . "LDAP cannot bind")
 114     (39 . "LDAP search failed")
 115     (40 . "library not found")
 116     (41 . "function not found")
 117     (42 . "aborted by callback")
 118     (43 . "bad function argument")
 119     (44 . "NOT USED")
 120     (45 . "CURLOPT_INTERFACE failed")
 121     (46 . "NOT USED")
 122     (47 . "catch endless re-direct loops")
 123     (48 . "User specified an unknown option")
 124     (49 . "Malformed telnet option")
 125     (50 . "NOT USED")
 126     (51 . "peer's certificate wasn't ok")
 127     (52 . "when this is a specific error")
 128     (53 . "SSL crypto engine not found")
 129     (54 . "can not set SSL crypto engine as default")
 130     (55 . "failed sending network data")
 131     (56 . "failure in receiving network data")
 132     (57 . "share is in use")
 133     (58 . "problem with the local certificate")
 134     (59 . "couldn't use specified cipher")
 135     (60 . "problem with the CA cert (path?)")
 136     (61 . "Unrecognized transfer encoding")
 137     (62 . "Invalid LDAP URL")
 138     (63 . "Maximum file size exceeded")
 139     (64 . "Requested FTP SSL level failed"))
 140   "Alist of error codes and associated clear-text error messages.")
 141
 142 ;;}}}
 143 \f
 144 ;;{{{ High level API
 145
 146 (defun curl:easy-init ()
 147   "Initialize curl easy interface and return a context handle."
 148   (let ((ret (curl:curl_easy_init)))
 149     (when (ffi-null-p ret)
 150       (error "curl:easy-init: Can't init easy interface"))
 151     ret))
 152
 153 (defun curl:easy-cleanup (ctx)
 154   "Clean up context CTX and free resources allocated with it.
 155 This function must be called after every easy session."
 156   (curl:curl_easy_cleanup ctx)
 157   ;; Remove references to saved values
 158   (remprop ctx 'saved-values))
 159
 160 (defun curl:easy-setopt (ctx &rest options)
 161   "Set OPTIONS for curl transfer.
 162 Options are passed as keyword-value-pairs. Supported keywords are:
 163 :url string - a valid Uniform Resource Locator.
 164 :fstream ffi-fo - a file descriptor to which output is redirected."
 165   (while options
 166     (let ((option (car options))
 167           (value (cadr options))
 168           error)
 169       ;; Handle special cases in options
 170       (case option
 171         ((:url :post-fields)
 172          (unless (stringp value)
 173            (error 'invalid-argument
 174                   "curl:easy-setopt invalid option value(must be string)"
 175                   option value))
 176          (setq value (ffi-create-fo 'c-string value))
 177          ;; Keep reference to value until context is destroyed
 178          (push value (get ctx 'saved-values)))
 179
 180         ((:read-function :write-function)
 181          (setq value (ffi-callback-fo value)))
 182
 183         ((:nobody :header :post :nosignal)
 184          (setq value (ffi-create-fo 'int (if value 1 0)))))
 185
 186       (setq error (curl:curl_easy_setopt ctx option value))
 187       (unless (zerop error)
 188         (error 'invalid-operation "curl:easy-setopt error" error))
 189
 190       (setq options (cddr options)))))
 191
 192 (defun curl:easy-perform (ctx)
 193   "Perform cURL operation on the context CTX.
 194 To control the behaviour of the session or set options into the
 195 context, see `curl:easy-setopt'."
 196   (let ((err (curl:curl_easy_perform ctx)))
 197     (unless (zerop err)
 198       (error 'invalid-operation "curl:easy-perform error"
 199              (cdr (assq err curl:errors-alist))))
 200     err))
 201
 202 (defun curl:easy-perform& (ctx sentinel fs)
 203   "Perform cURL operation on CTX, return a worker job object.
 204 Afterwards run SENTINEL.
 205
 206 The original (curl) context CTX is stored in the plist of the worker job
 207 object with key 'ctx to keep it accessible."
 208   (if (featurep 'workers)
 209       (let* ((job (ffi-call-function&
 210                    (get 'curl:curl_easy_perform 'ffi-fun)
 211                    ctx sentinel fs ctx)))
 212         ;; add ctx to plist of job
 213         (put job 'ctx ctx)
 214         job)
 215     (error 'unimplemented "Asynchronous Event Queues")))
 216
 217 (defun curl:easy-perform-sentinel (job fs ctx)
 218   (curl:easy-cleanup ctx)
 219   (unless (car fs) (c:fclose (cdr fs)))
 220   (run-hook-with-args 'curl:download&-post-hook job))
 221
 222 (defun curl:easy-getinfo (ctx what)
 223   "Get info from the context CTX about WHAT."
 224   (let* ((ival (cdr (assq what (ffi-enum-values 'curl-info))))
 225          (itype (if (not (numberp ival))
 226                     (error "Unsupported info" what)
 227                   (ecase (lsh (logand #xf00000 ival) -20)
 228                     (1 'c-string) (2 'long) (3 'double))))
 229          (retfo (make-ffi-object itype)))
 230     (unless (zerop (curl:curl_easy_getinfo
 231                     ctx what (ffi-address-of retfo)))
 232       (error 'invalid-operation "curl:easy-getinfo error"))
 233     (ffi-get retfo)))
 234
 235 (defvar curl:download-history nil
 236   "History for `curl:download' and `curl:download&'.")
 237
 238 (ignore-errors
 239   (define-ffi-callback curl:cb-write-to-buffer int
 240     ((ptr pointer) (size int) (nmemb int) (stream pointer))
 241     "Writer to STREAM buffer."
 242     (let ((buf (ffi-pointer-to-lisp-object stream))
 243           (rsz (* size nmemb)))
 244       (when (and (positivep rsz) (buffer-live-p buf))
 245         (with-current-buffer buf
 246           (insert (ffi-get ptr :type (cons 'c-data rsz)))))
 247       rsz)))
 248
 249 ;;;###autoload
 250 (defun curl:download (url file-or-buffer &rest options)
 251   "Download the contents of URL and write them to FILE-OR-BUFFER.
 252
 253 Optionally you can specify keywords in OPTIONS.  The options are
 254 keyword-value-pairs and are set via `curl:easy-setopt'.
 255
 256 When called interactively you can choose, with a prefix arg, to download
 257 the HTTP header instead of the actual remote file.  Obviously this only
 258 works with HTTP URLs."
 259   (interactive
 260    (list (read-string "URL: " (and-fboundp #'ffap-url-at-point
 261                                 (ffap-url-at-point))
 262                       curl:download-history)
 263          (read-file-name "Local file: " default-directory
 264                          (make-temp-name
 265                           (expand-file-name "curl:downloaded:"
 266                                             (temp-directory))))))
 267   (when current-prefix-arg
 268     ;; In case of C-u
 269     (and (y-or-n-p (format "Only download %s's HTTP header? "
 270                            (file-basename file-or-buffer)))
 271          (setq options (list :header t :nobody t))))
 272
 273   (let* ((ctx (curl:easy-init))
 274          (bufferp (when (bufferp file-or-buffer)
 275                     (or (boundp 'curl:cb-write-to-buffer)
 276                         (error 'unimplemented 'ffi-make-callback
 277                                "for this architecture"))))
 278          (fs (if bufferp
 279                  (ffi-lisp-object-to-pointer file-or-buffer)
 280                (c:fopen (expand-file-name file-or-buffer) "w"))))
 281     (unwind-protect
 282         (progn
 283           (when bufferp
 284             (curl:easy-setopt ctx :write-function 'curl:cb-write-to-buffer))
 285
 286           ;; Avoid signalling!
 287           (curl:easy-setopt ctx :nosignal t)
 288
 289           (apply #'curl:easy-setopt ctx :fstream fs :url url options)
 290           (curl:easy-perform ctx))
 291       (unless bufferp (c:fclose fs))
 292       (curl:easy-cleanup ctx))))
 293
 294 ;;;###autoload
 295 (defun curl:download& (url file-or-buffer &rest options)
 296   "Download the contents of URL and write them to FILE asynchronously.
 297
 298 Optionally you can specify keywords in OPTIONS.  The options are
 299 keyword-value-pairs and are set via `curl:easy-setopt'.
 300
 301 When called interactively you can choose, with a prefix arg, to download
 302 the HTTP header instead of the actual remote file.  Obviously this only
 303 works with HTTP URLs.
 304
 305 After the download operation succeeded the hook `curl:download&-post-hook'
 306 is run.  Functions in there will be called with an argument JOB."
 307   (interactive
 308    (list (read-string "URL: " (and-fboundp #'ffap-url-at-point
 309                                 (ffap-url-at-point))
 310                       curl:download-history)
 311          (read-file-name "Local file: " default-directory
 312                          (make-temp-name
 313                           (expand-file-name "curl:downloaded:"
 314                                             (temp-directory))))))
 315   (when current-prefix-arg
 316     (and (y-or-n-p (format "Only download %s's HTTP header? "
 317                            (file-basename file-or-buffer)))
 318          (setq options (list :header t :nobody t))))
 319
 320   (if (featurep 'workers)
 321       (let* ((ctx (curl:easy-init))
 322              (bufferp (when (bufferp file-or-buffer)
 323                         (or (boundp 'curl:cb-write-to-buffer)
 324                             (error 'unimplemented 'ffi-make-callback
 325                                    "for this architecture"))))
 326              (fs (if bufferp
 327                      (ffi-lisp-object-to-pointer file-or-buffer)
 328                    (c:fopen (expand-file-name file-or-buffer) "w"))))
 329         (condition-case cerr
 330             (progn
 331               (when bufferp
 332                 (curl:easy-setopt ctx :write-function 'curl:cb-write-to-buffer))
 333
 334               ;; Avoid signalling!
 335               (curl:easy-setopt ctx :nosignal t)
 336
 337               (apply #'curl:easy-setopt ctx :fstream fs :url url options)
 338               (curl:easy-perform& ctx #'curl:easy-perform-sentinel
 339                                   (cons bufferp fs)))
 340
 341           ;; Close FS, cleanup CTX and resignal error
 342           (t (unless bufferp (c:fclose fs))
 343              (curl:easy-cleanup ctx)
 344              (signal (car cerr) (cdr cerr)))))
 345     (error 'unimplemented "Asynchronous Event Queues")))
 346
 347 ;;;###autoload
 348 (defvar curl:download&-post-hook nil
 349   "*Hook run after a `curl:download&' call.
 350 Functions in here are called with one argument JOB containing
 351 the job which just finished.")
 352
 353 ;;}}}
 354 \f
 355 ;;{{{ file handlers
 356 ;; There's probably more that could be added here, but for now, just
 357 ;; enough to get PUI working seemlessly with ffi-curl (HTTP/FTP) or
 358 ;; EFS (FTP). --SY.
 359
 360 ;; file-exists-p
 361 (defun curl:file-exists-p (uri)
 362   "Curl implementation of `file-exists-p'.
 363
 364 Don't call this directly, use `file-exists-p' and give it a URI for
 365 the FILENAME arg.  The underlying file name handlers will take care of
 366 calling this function.
 367
 368 Currently only HTTP and FTP are supported, and then only if the URL ends
 369 in a filename. IOW you can't do \(file-exists-p \"http://example.com/\"\)"
 370   (let ((lfile (make-temp-name
 371                 (expand-file-name "curl:" (temp-directory))))
 372         (resp nil))
 373     (curl:download uri lfile :header t :nobody t)
 374     (with-temp-buffer
 375       (insert-file-contents-literally lfile)
 376       (and (re-search-forward #r"^\(HTTP/1\.1 200 OK\|Content-Length\)" nil t)
 377            (setq resp t)))
 378     (delete-file lfile)
 379     resp))
 380 (put 'file-exists-p 'curl 'curl:file-exists-p)
 381
 382 ;; file-readable-p
 383 ;; doesn't make much sense for HTTP, so just alias to file-exists-p
 384 (defalias 'curl:file-readable-p 'curl:file-exists-p)
 385 (put 'file-readable-p 'curl 'curl:file-readable-p)
 386
 387 ;; insert-file-contents-literally
 388 (defun curl:insert-file-contents-literally (uri &optional visit
 389                                                 start end replace)
 390   "Curl implementation of `insert-file-contents-literally'.
 391
 392 Don't call this directly, use `insert-file-contents-literally' and
 393 give it a URI for the FILENAME arg.  The underlying file name handlers
 394 will take care of calling this function.
 395
 396 Currently only HTTP and FTP are supported, and then only if the URL
 397 ends in a filename."
 398   (let ((file-name-handler-alist nil)
 399         (format-alist nil)
 400         (after-insert-file-functions nil)
 401         (coding-system-for-read 'binary)
 402         (coding-system-for-write 'binary)
 403         (find-buffer-file-type-function
 404          (if (fboundp 'find-buffer-file-type)
 405              (symbol-function 'find-buffer-file-type)
 406            nil))
 407         (lfile (make-temp-name
 408                 (expand-file-name "curl:" (temp-directory)))))
 409     (unwind-protect
 410         (progn
 411           (curl:download uri lfile)
 412           (fset 'find-buffer-file-type (lambda (lfile) t))
 413           (insert-file-contents lfile visit start end replace))
 414       (if find-buffer-file-type-function
 415           (fset 'find-buffer-file-type find-buffer-file-type-function)
 416         (fmakunbound 'find-buffer-file-type))
 417       (delete-file lfile))))
 418 (put 'insert-file-contents-literally
 419      'curl 'curl:insert-file-contents-literally)
 420
 421 ;;; FIXME: calling `copy-file' interactively on a URI doesn't work. The
 422 ;;; minibuffer tries to do expansion or completion or something on the
 423 ;;; URI before the file name handlers kick in. --SY.
 424 ;; copy-file
 425 (defun curl:copy-file (uri newname &optional ok-if-already-exists
 426                            &rest args)
 427   "Curl implementation of `copy-file'.
 428
 429 Copy remote file, URI to local file, NEWNAME.  Copying in the
 430 other direction, local to remote, is not supported and will result in
 431 an error.
 432
 433 Signals a `file-already-exists' error if file NEWNAME already exists,
 434 unless a third argument OK-IF-ALREADY-EXISTS is supplied and non-nil.
 435 A number as third arg means request confirmation if NEWNAME already
 436 exists.  This is the default for interactive use.
 437
 438 Don't call this directly, use `copy-file' and give it a URI for
 439 the FILENAME arg.  The underlying file name handlers will take care of
 440 calling this function.
 441
 442 Currently only HTTP and FTP are supported, and then only if the URL
 443 ends in a filename."
 444   (when (string-match #r"^\(https?\|s?ftp\)://" newname)
 445     (error 'invalid-argument newname "Destination cannot be a URI"))
 446   (let ((newname (expand-file-name newname))
 447         doit)
 448     (if (file-exists-p newname)
 449         (if (or (interactive-p) (numberp ok-if-already-exists))
 450             (and (y-or-n-p
 451                   (format "Existing file: %s Overwrite? " newname))
 452                  (setq doit t))
 453           (if ok-if-already-exists
 454               (setq doit t)
 455             (error 'file-already-exists "Existing file" newname)))
 456       (setq doit t))
 457     (and doit (curl:download uri newname))))
 458 (put 'copy-file 'curl 'curl:copy-file)
 459
 460 ;; expand-file-name
 461 (defun curl:expand-file-name (&rest args)
 462   "Return the 1st argument unchanged.
 463
 464 Don't use this.  In fact, forget that you even saw it.  There is no
 465 way you're ever going to need to use this.  It's sole purpose is to
 466 keep `file-exists-p' happy when that is given a URI to check. "
 467   (car args))
 468 (put 'expand-file-name 'curl 'curl:expand-file-name)
 469
 470 ;; file-name-directory
 471 (defun curl:file-name-directory (uri)
 472   "A curl implementation of `file-name-directory'.
 473
 474 Returns URI without the filename.
 475
 476 Don't call this directly, use `file-name-directory' with URI for the
 477 FILENAME arg.  The underlying file name handlers will take care of
 478 calling this function.
 479
 480 Currently only HTTP and FTP are supported, and then only if the URL
 481 ends in a filename."
 482   (progn
 483     (string-match curl:file-handler-regexp uri)
 484     (substring uri (match-beginning 1) (match-end 2))))
 485 (put 'file-name-directory 'curl 'curl:file-name-directory)
 486
 487 ;; file-name-nondirectory
 488 (defun curl:file-name-nondirectory (uri)
 489   "A curl implementation of `file-name-nondirectory'.
 490
 491 Returns the filename portion of URI.
 492
 493 Don't call this directly, use `file-name-nondirectory' with URI for the
 494 FILENAME arg.  The underlying file name handlers will take care of
 495 calling this function.
 496
 497 Currently only HTTP and FTP are supported, and then only if the URL
 498 ends in a filename."
 499   (progn
 500     (string-match curl:file-handler-regexp uri)
 501     (substring uri (match-end 2))))
 502 (put 'file-name-nondirectory 'curl 'curl:file-name-nondirectory)
 503
 504 ;; This regexp contains trailing whitespace DO NOT REMOVE OR MANGLE
 505 (defregexp curl:file-handler-regexp
 506   #r"\(https?://\|s?ftp://\)[^]
 507  \"'()<>[^`{}]*[^]
 508  \"'()<>[^`{}.,;]+\(/\)\([^/].*[^/]$\)"
 509 "Regexp used in `file-name-handler-alist'.
 510
 511 It matches HTTP/FTP URLs but only if they end with a filename.
 512 So, for example, \"http://example.com/file.ext\" would match, but
 513 \"http://example.com/\" would not.")
 514
 515 ;; handler function
 516 (defun curl:file-handler (operation &rest args)
 517   (let ((op (get operation 'curl)))
 518     (if op
 519         (apply op args)
 520       (error 'unimplemented
 521              (concat "curl:" (symbol-name operation))))))
 522
 523 (defvar curl:file-handler
 524   (cons curl:file-handler-regexp 'curl:file-handler))
 525
 526 (unless (memq curl:file-handler file-name-handler-alist)
 527   (setq file-name-handler-alist
 528         (cons curl:file-handler file-name-handler-alist)))
 529
 530 ;;}}}
 531
 532 \f
 533 (provide 'ffi-curl)
 534
 535 ;;; ffi-curl.el ends here