src/main.lisp

   1 (in-package :cl-mediawiki)
   2
   3 (defclass mediawiki ()
   4   ((url :accessor url :initarg :url :initform nil)
   5    (auth :accessor auth :initarg :auth :initform nil)
   6    (cookie-jar :accessor cookie-jar :initarg cookie-jar :initform (make-instance 'drakma:cookie-jar))))
   7
   8 (defvar *mediawiki* nil
   9   "the current instance of media wiki we are dealing with (mostly for use with with-mediawiki)")
  10
  11 (defmacro with-mediawiki ((obj) &body body)
  12   `(let ((*mediawiki* ,(typecase obj
  13                          (string `(make-instance 'mediawiki :url ,obj))
  14                          (T obj))))
  15      ,@body
  16      ))
  17
  18 (defun make-api-request (api-params &key (basic-authorization (auth *mediawiki* )) (force-ssl nil force-ssl-p) (method :get))
  19   ;; force-ssl should either be whats passed in, or if nothing is passed in
  20   ;; check to see what protocol we used to connect to the server
  21   (let ((force-ssl (if force-ssl-p
  22                        force-ssl
  23                        (eq 0 (search "https://" (url *mediawiki*) :test #'char-equal ))
  24                        ))
  25         (full-url (format nil "~a/api.php" (url *mediawiki*))))
  26     (push '("format" . "xml") api-params)
  27     (multiple-value-bind (content status headers uri stream must-close status-word)
  28         (let ((drakma:*drakma-default-external-format* :utf-8))
  29           (drakma:http-request
  30            full-url
  31            :method method
  32            :basic-authorization basic-authorization
  33            :force-ssl force-ssl
  34            :parameters api-params
  35            :cookie-jar (cookie-jar *mediawiki*)
  36            ))
  37       (declare (ignore headers uri stream must-close status-word))
  38       (values content status))))
  39
  40 (defun make-parameters (params)
  41   (loop for binding in params
  42         when binding
  43           collecting
  44        (destructuring-bind (key val) binding
  45          (cons (format nil "~(~a~)" key)
  46                (typecase val
  47                  (symbol (format nil "~(~a~)" val))
  48                  (string val))))))
  49
  50 (defun parse-api-response-to-sxml (content)
  51   (cxml:parse content (cxml-xmls:make-xmls-builder) :validate nil))
  52
  53 (defun attribute-value (key alist)
  54   (cadr (assoc key alist :test #'equalp)))
  55
  56 (define-condition media-wiki-error (error)
  57   ((obj :accessor obj :initarg :obj :initform nil)
  58    (code :accessor code :initarg :code :initform nil)
  59    (message :accessor message :initarg :message :initform nil)))
  60
  61 (defmethod print-object ((err media-wiki-error) stream)
  62   (format stream "MEDIA-WIKI-ERROR: ~a ~a ~%~a"
  63           (code err)
  64           (message err)
  65           (obj err)
  66           ))
  67
  68 (define-condition match-error (error)
  69   ((obj :accessor obj :initarg :obj :initform nil)
  70    (match-against :accessor match-against :initarg :match-against :initform nil)
  71    (message :accessor message :initarg :message :initform nil)))
  72
  73 (defmacro match-response-with-error-reporting ((match-form object)&body body)
  74   "Attempts to unify body as (match (match-form obj) ,@body)
  75
  76    will detect wiki errors and hand them back to us as reasonable CL signals
  77    if we canot match signal a matching-error
  78   "
  79   (let ((obj-sym (gensym "obj")))
  80     `(let ((,obj-sym ,object))
  81        (unify:match-case
  82         (,obj-sym)
  83         (`("api"
  84            NIL
  85            ("error" ?err))
  86           (error 'media-wiki-error :obj ,obj-sym
  87                                    :code (attribute-value "code" err)
  88                                    :message (attribute-value "info" err)))
  89         (,match-form
  90          ,@body)
  91         (T
  92          (error 'match-error :message "Error matching"
  93                              :obj ,obj-sym
  94                              :match-against ,match-form))
  95         ))))