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   )
  50
  51 (define-ffi-enum curl-info
  52   (:effective-url  #x100001)
  53   (:response-code  #x200002)
  54   (:header-size    #x20000b)
  55   (:content-type   #x100012)
  56   (:size-download  #x300008)
  57   (:speed-download #x300009))
  58
  59 (cffi:defcfun ("curl_easy_init" curl:curl_easy_init) pointer)
  60 (cffi:defcfun ("curl_easy_cleanup" curl:curl_easy_cleanup) void
  61   (handler pointer))
  62 (cffi:defcfun ("curl_easy_perform" curl:curl_easy_perform) int
  63   (handler pointer))
  64
  65 (cffi:defcfun ("curl_easy_setopt" curl:curl_easy_setopt) int
  66   (handler pointer) (opt curl-option) &rest)
  67 (cffi:defcfun ("curl_easy_getinfo" curl:curl_easy_getinfo) int
  68   (handler pointer) (info curl-info) &rest)
  69
  70 ;;}}}
  71 \f
  72 ;;{{{ Errors list
  73
  74 (defconst curl:errors-alist
  75   '((1 . "Unsupported protocol")
  76     (2 . "Failed init")
  77     (3 . "Malformated URL")
  78     (4 . "NOT USED")
  79     (5 . "Could not resolve proxy")
  80     (6 . "Could not resolve host")
  81     (7 . "Could not connect")
  82     (8 . "FTP weird server reply")
  83     (9 . "FTP access denied")
  84     (10 . "FTP user or password is incorrect")
  85     (11 . "FTP weird PASS reply")
  86     (12 . "FTP weird USER reply")
  87     (13 . "FTP weird PASV reply")
  88     (14 . "FTP weird 227 format")
  89     (15 . "FTP can't get host")
  90     (16 . "FTP can't reconnect")
  91     (17 . "FTP could not set binary")
  92     (18 . "partial file")
  93     (19 . "FTP could not RETR file")
  94     (20 . "FTP write error")
  95     (21 . "FTP quote error")
  96     (22 . "HTTP returned errror")
  97     (23 . "write error")
  98     (24 . "NOT USED")
  99     (25 . "failed FTP upload")
 100     (26 . "could open/read from file")
 101     (27 . "Out of memory")
 102     (28 . "the timeout time was reached")
 103     (29 . "TYPE A failed")
 104     (30 . "FTP PORT operation failed")
 105     (31 . "the REST command failed")
 106     (32 . "the SIZE command failed")
 107     (33 . "RANGE \"command\" didn't work")
 108     (34 . "HTTP port error")
 109     (35 . "wrong when connecting with SSL")
 110     (36 . "couldn't resume download")
 111     (37 . "FILE could not read file")
 112     (38 . "LDAP cannot bind")
 113     (39 . "LDAP search failed")
 114     (40 . "library not found")
 115     (41 . "function not found")
 116     (42 . "aborted by callback")
 117     (43 . "bad function argument")
 118     (44 . "NOT USED")
 119     (45 . "CURLOPT_INTERFACE failed")
 120     (46 . "NOT USED")
 121     (47 . "catch endless re-direct loops")
 122     (48 . "User specified an unknown option")
 123     (49 . "Malformed telnet option")
 124     (50 . "NOT USED")
 125     (51 . "peer's certificate wasn't ok")
 126     (52 . "when this is a specific error")
 127     (53 . "SSL crypto engine not found")
 128     (54 . "can not set SSL crypto engine as default")
 129     (55 . "failed sending network data")
 130     (56 . "failure in receiving network data")
 131     (57 . "share is in use")
 132     (58 . "problem with the local certificate")
 133     (59 . "couldn't use specified cipher")
 134     (60 . "problem with the CA cert (path?)")
 135     (61 . "Unrecognized transfer encoding")
 136     (62 . "Invalid LDAP URL")
 137     (63 . "Maximum file size exceeded")
 138     (64 . "Requested FTP SSL level failed"))
 139   "Alist of error codes and associated clear-text error messages.")
 140
 141 ;;}}}
 142 \f
 143 ;;{{{ High level API
 144
 145 (defun curl:easy-init ()
 146   "Initialize curl easy interface and return a context handle."
 147   (let ((ret (curl:curl_easy_init)))
 148     (when (ffi-null-p ret)
 149       (error "curl:easy-init: Can't init easy interface"))
 150     ret))
 151
 152 (defun curl:easy-cleanup (ctx)
 153   "Clean up context CTX and free resources allocated with it.
 154 This function must be called after every easy session."
 155   (curl:curl_easy_cleanup ctx)
 156   ;; Remove references to saved values
 157   (remprop ctx 'saved-values))
 158
 159 (defun curl:easy-setopt (ctx &rest options)
 160   "Set OPTIONS for curl transfer.
 161 Options are passed as keyword-value-pairs. Supported keywords are:
 162 :url string - a valid Uniform Resource Locator.
 163 :fstream ffi-fo - a file descriptor to which output is redirected."
 164   (while options
 165     (let ((option (car options))
 166           (value (cadr options))
 167           error)
 168       ;; Handle special cases in options
 169       (case option
 170         ((:url :post-fields)
 171          (unless (stringp value)
 172            (error 'invalid-argument
 173                   "curl:easy-setopt invalid option value(must be string)"
 174                   option value))
 175          (setq value (ffi-create-fo 'c-string value))
 176          ;; Keep reference to value until context is destroyed
 177          (push value (get ctx 'saved-values)))
 178
 179         ((:read-function :write-function)
 180          (setq value (ffi-callback-fo value)))
 181
 182         ((:nobody :header :post)
 183          (setq value (ffi-create-fo 'int (if value 1 0)))))
 184
 185       (setq error (curl:curl_easy_setopt ctx option value))
 186       (unless (zerop error)
 187         (error 'invalid-operation "curl:easy-setopt error" error))
 188
 189       (setq options (cddr options)))))
 190
 191 (defun curl:easy-perform (ctx)
 192   "Perform cURL operation on the context CTX.
 193 To control the behaviour of the session or set options into the
 194 context, see `curl:easy-setopt'."
 195   (let ((err (curl:curl_easy_perform ctx)))
 196     (unless (zerop err)
 197       (error 'invalid-operation "curl:easy-perform error"
 198              (cdr (assq err curl:errors-alist))))
 199     err))
 200
 201 (defun curl:easy-perform& (ctx sentinel fs)
 202   "Perform cURL operation on CTX, return a worker job object.
 203 Afterwards run SENTINEL.
 204
 205 The original (curl) context CTX is stored in the plist of the worker job
 206 object with key 'ctx to keep it accessible."
 207   (if (featurep 'workers)
 208       (let* ((job (ffi-call-function&
 209                    (get 'curl:curl_easy_perform 'ffi-fun)
 210                    ctx sentinel fs ctx)))
 211         ;; add ctx to plist of job
 212         (put job 'ctx ctx)
 213         job)
 214     (error 'unimplemented "Asynchronous Event Queues")))
 215
 216 (defun curl:easy-perform-sentinel (job fs ctx)
 217   (curl:easy-cleanup ctx)
 218   (unless (car fs) (c:fclose (cdr fs)))
 219   (run-hook-with-args 'curl:download&-post-hook job))
 220
 221 (defun curl:easy-getinfo (ctx what)
 222   "Get info from the context CTX about WHAT."
 223   (let* ((ival (cdr (assq what (ffi-enum-values 'curl-info))))
 224          (itype (if (not (numberp ival))
 225                     (error "Unsupported info" what)
 226                   (ecase (lsh (logand #xf00000 ival) -20)
 227                     (1 'c-string) (2 'long) (3 'double))))
 228          (retfo (make-ffi-object itype)))
 229     (unless (zerop (curl:curl_easy_getinfo
 230                     ctx what (ffi-address-of retfo)))
 231       (error 'invalid-operation "curl:easy-getinfo error"))
 232     (ffi-get retfo)))
 233
 234 (defvar curl:download-history nil
 235   "History for `curl:download' and `curl:download&'.")
 236
 237 (define-ffi-callback curl:cb-write-to-buffer int
 238   ((ptr pointer) (size int) (nmemb int) (stream pointer))
 239   "Writer to STREAM buffer."
 240   (let ((buf (ffi-pointer-to-lisp-object stream))
 241         (rsz (* size nmemb)))
 242     (when (and (positivep rsz) (buffer-live-p buf))
 243       (with-current-buffer buf
 244         (insert (ffi-get ptr :type (cons 'c-data rsz)))))
 245     rsz))
 246
 247 ;;;###autoload
 248 (defun curl:download (url file-or-buffer &rest options)
 249   "Download the contents of URL and write them to FILE-OR-BUFFER.
 250
 251 Optionally you can specify keywords in OPTIONS.  The options are
 252 keyword-value-pairs and are set via `curl:easy-setopt'.
 253
 254 When called interactively you can choose, with a prefix arg, to download
 255 the HTTP header instead of the actual remote file.  Obviously this only
 256 works with HTTP URLs."
 257   (interactive
 258    (list (read-string "URL: " (and-fboundp #'ffap-url-at-point
 259                                 (ffap-url-at-point))
 260                       curl:download-history)
 261          (read-file-name "Local file: " default-directory
 262                          (expand-file-name (make-temp-name "curl:downloaded:")
 263                                            (temp-directory)))))
 264   (when current-prefix-arg
 265     ;; In case of C-u
 266     (and (y-or-n-p (format "Only download %s's HTTP header? "
 267                            (file-basename file-or-buffer)))
 268          (setq options (list :header t :nobody t))))
 269
 270   (let* ((ctx (curl:easy-init))
 271          (bufferp (bufferp file-or-buffer))
 272          (fs (if bufferp
 273                  (ffi-lisp-object-to-pointer file-or-buffer)
 274                (c:fopen (expand-file-name file-or-buffer) "w"))))
 275     (unwind-protect
 276         (progn
 277           (when bufferp
 278             (curl:easy-setopt ctx :write-function 'curl:cb-write-to-buffer))
 279           (apply #'curl:easy-setopt ctx :fstream fs :url url options)
 280           (curl:easy-perform ctx))
 281       (unless bufferp (c:fclose fs))
 282       (curl:easy-cleanup ctx))))
 283
 284 ;;;###autoload
 285 (defun curl:download& (url file-or-buffer &rest options)
 286   "Download the contents of URL and write them to FILE asynchronously.
 287
 288 Optionally you can specify keywords in OPTIONS.  The options are
 289 keyword-value-pairs and are set via `curl:easy-setopt'.
 290
 291 When called interactively you can choose, with a prefix arg, to download
 292 the HTTP header instead of the actual remote file.  Obviously this only
 293 works with HTTP URLs.
 294
 295 After the download operation succeeded the hook `curl:download&-post-hook'
 296 is run.  Functions in there will be called with an argument JOB."
 297   (interactive
 298    (list (read-string "URL: " (and-fboundp #'ffap-url-at-point
 299                                 (ffap-url-at-point))
 300                       curl:download-history)
 301          (read-file-name "Local file: " default-directory
 302                          (expand-file-name (make-temp-name "curl:downloaded:")
 303                                            (temp-directory)))))
 304   (when current-prefix-arg
 305     (and (y-or-n-p (format "Only download %s's HTTP header? "
 306                            (file-basename file-or-buffer)))
 307          (setq options (list :header t :nobody t))))
 308
 309   (if (featurep 'workers)
 310       (let* ((ctx (curl:easy-init))
 311              (bufferp (bufferp file-or-buffer))
 312              (fs (if bufferp
 313                      (ffi-lisp-object-to-pointer file-or-buffer)
 314                    (c:fopen (expand-file-name file-or-buffer) "w"))))
 315         (condition-case cerr
 316             (progn
 317               (when bufferp
 318                 (curl:easy-setopt ctx :write-function 'curl:cb-write-to-buffer))
 319               (apply #'curl:easy-setopt ctx :fstream fs :url url options)
 320               (curl:easy-perform& ctx #'curl:easy-perform-sentinel
 321                                   (cons bufferp fs)))
 322
 323           ;; Close FS, cleanup CTX and resignal error
 324           (t (unless bufferp (c:fclose fs))
 325              (curl:easy-cleanup ctx)
 326              (signal (car cerr) (cdr cerr)))))
 327     (error 'unimplemented "Asynchronous Event Queues")))
 328
 329 ;;;###autoload
 330 (defvar curl:download&-post-hook nil
 331   "*Hook run after a `curl:download&' call.
 332 Functions in here are called with one argument JOB containing
 333 the job which just finished.")
 334
 335 ;;}}}
 336
 337 \f
 338 (provide 'ffi-curl)
 339
 340 ;;; ffi-curl.el ends here