moikrug.el -- Emacs interface to MoiKrug

[Zajcev Evgeny]

MoiKrug(http://moikrug.ru) is first social networks service in Russia.
MoiKrug is like LinkedIn, but provides cleaner interface and reguards
russian specific.  MoiKrug still in beta testing mode, however already
had huge amount of users and much usability.  MoiKrug authors kindly
provided (yet) simple Web API via SOAP for third party software.  Here
is code that works as bridge between BBDB and MoiKrug, it provides
only two commands - `moikrug-bbdb-merge-in' to merge MoiKrug records
into your BBDB and `moikrug-bbdb-invite' to invite person from BBDB
into your MoiKrug.

This code tested to work with (S)XEmacs, however might work with GNU
Emacs as well, please let me know whether it works or not and send
patches to zevlg AT yandex.ru

Thanks!

;;; moikrug.el --- (S)XEmacs interface to MoiKrug.

;;{{{ `-- Top Comments

;; Copyright (C) 2006 by Zajcev Evgeny

;; Author: Zajcev Evgeny <address@hidden>
;; Keywords: bbdb
;; Created: Thu Jan 12 15:03:17 MSK 2006
;; Version: 1.0

;; This file is NOT part of XEmacs.

;; XEmacs is free software; you can redistribute it and/or modify it
;; under the terms of the GNU General Public License as published by
;; the Free Software Foundation; either version 2, or (at your option)
;; any later version.

;; XEmacs is distributed in the hope that it will be useful, but
;; WITHOUT ANY WARRANTY; without even the implied warranty of
;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
;; General Public License for more details.

;; You should have received a copy of the GNU General Public License
;; along with XEmacs; see the file COPYING.  If not, write to the Free
;; Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA
;; 02111-1307, USA.

;;; Synched up with: Not in FSF

;;; Commentary:

;; This is the Emacs interface to MoiKrug (http://moikrug.ru) service.
;; It has only two commands:

;;   moikrug-bbdb-invite   - Invite person from bbdb to your MoiKrug.
;;   moikrug-bbdb-merge-in - Merge MoiKrug entries into bbdb.

;; moikrug.el depends on w3, net-utils, gnus and bbdb packages, make
;; sure they are installed.

;; Sample configuration might look like:

;;   (autoload 'moikrug-bbdb-invite "moikrug" nil t)
;;   (autoload 'moikrug-bbdb-merge-in "moikrug" nil t)

;;   (setq moikrug-login user-mail-address)

;;   (add-hook 'bbdb-mode-hook
;;             (lambda ()
;;               (define-key bbdb-mode-map [?u] 'moikrug-bbdb-merge-in)
;;               (define-key bbdb-mode-map [?i] 'moikrug-bbdb-invite)))

;;; Note:

;; File layout controlled by Emacs folding.el available at:
;; http://www.csd.uu.se/~andersl/emacs.shtml - Latest included in
;; XEmacs

;;; Thanks:

;;  - MoiKrug project for providing API.
;;  - Edward O'Connor for his soap.el and google.el code.

;;; Bugs:

;;  - Built-in UTF8<-->KOI8-R convertor.

;;}}}

;;; Code:

;;{{{ `-- Requires

(require 'cl)
(require 'parse-time)
(require 'time-date)
(require 'bbdb-com)
(require 'url)
(require 'xml)

;;}}}
;;{{{ `-- Customization

(defgroup moikrug nil
  "Group to customize moikrug."
  :prefix "moikrug-"
  :group 'tools)

(defcustom moikrug-login 'ask-once
  "Login for your account at MoiKrug."
  :type '(choice (const :tag "Ask everytime" ask)
                 (const :tag "Ask once" ask-once)
                 (string :tag "Set password"))
  :group 'moikrug)

(defcustom moikrug-password 'ask-once
  "Password for your account at MoiKrug."
  :type '(choice (const :tag "Ask everytime" ask)
                 (const :tag "Ask once" ask-once)
                 (string :tag "Set password"))
  :group 'moikrug)

(defcustom moikrug-sort-type 'modified
  "Default sorting type when merging in moikrug."
  :type '(choice (const :tag "By name" name)
                 (const :tag "Modification date" modified)
                 (const :tag "Number of contacts" contacts))
  :group 'moikrug)

(defcustom moikrug-invite-subject "Приглашаю в Мой Круг"
  "Subject for invite mail."
  :type 'string
  :group 'moikrug)

(defcustom moikrug-invite-message
  "Я восстанавливаю информацию о знакомых, чтобы в будущем не терять с
ними связь.

Приглашаю присоединиться к Моему Кругу, чтобы мы имели доступ к
профессиональной контакной информации друг друга.

MoiKrug.ru позволяет:

 - Найти через меня полезные профессиональные контакты и наших общих
   знакомых

 - Добавить свое резюме и знакомых в конфиденциальную записную книжку
   online, которая всегда будет содержать актуальную информацию

Вот что о них пишет пресса: http://moikrug.ru/press/";
  "Body for invite mail."
  :type 'string
  :group 'moikrug)

;;}}}


;;{{{ `-- SOAP

(defun soap-process-response (response-buffer)
  "Process the SOAP response in RESPONSE-BUFFER."
  (let ((retval nil))
    (with-current-buffer response-buffer
      (goto-char (point-min))
      (when (re-search-forward "^HTTP/1.* 200 OK\015?$" nil t)
        (re-search-forward "^\015?$" nil t 1)
        (setq retval (buffer-substring-no-properties (point) (point-max)))))
    (with-temp-buffer
      (insert "\n" retval "\n")
      (goto-char (point-min))
      (while (re-search-forward "\r" nil t)
        (replace-match ""))
      (xml-parse-region (point-min) (point-max)))))

(defun soap-request (url data)
  "Send and process SOAP request to URL with DATA."
  (let* ((url-request-extra-headers
          `(("Content-type" . "text/xml; charset=\"utf-8\"")
            ("SOAPAction" . ,(format "%S" url))))
         (url-request-method "POST")
         (url-request-data
          (concat "<?xml version=\"1.0\" encoding=\"utf-8\" ?>\n"
                  data)))
    (let* ((url-inhibit-mime-parsing t)
           (buf (cdr (url-retrieve url))))
      (with-current-buffer buf
        (save-excursion
          (goto-char (point-min))
          (while (search-forward "\015" nil t)
            (replace-match ""))))
      (soap-process-response buf))))

;;}}}
;;{{{ `-- XML-SEXP

(defun moikrug-xml-sexp-attr-to-xml (attr-cons)
  "Convert S-exp ATTR-CONS to xml form."
  (let ((attr-name (car attr-cons))
        (attr-val (cdr attr-cons)))
    (unless (stringp attr-val)
      (setq attr-val (format "%s" attr-val)))
    (concat (format " %s=" attr-name)
            (if (string-match "[\"]" attr-val)
                (format "'%s'" attr-val)
              (format "\"%s\"" attr-val)))))

(defun moikrug-xml-sexp-to-xml (xml-sexp)
  "Return a string containing an XML representation of XML-SEXP."
  (cond ((null xml-sexp) "")
        ((stringp xml-sexp) xml-sexp)
        ((listp xml-sexp)
         (let ((tag (xml-node-name xml-sexp))
               (attrs (xml-node-attributes xml-sexp))
               (children (xml-node-children xml-sexp)))
           (concat (format "<%s" tag)
                   (if attrs
                       (mapconcat #'moikrug-xml-sexp-attr-to-xml attrs "")
                     "")
                   (if children
                       (concat
                        ">" (mapconcat #'moikrug-xml-sexp-to-xml children "")
                        (format "</%s>" tag))
                     "/>"))))
        (t (moikrug-xml-sexp-to-xml (format "%s" xml-sexp)))))

;;}}}

;;{{{ `-- Request

(defvar moikrug-gate "https://moikrug.ru/extras/alpha.ws";
  "Set it to https://moikrug.ru/extras/alpha.ws for plain/text request.")

(defun moikrug-send-request (xml-sexp)
  "Send XML-SEXP to MoiKrug as a request."
  (soap-request moikrug-gate (moikrug-xml-sexp-to-xml xml-sexp)))

(defun moikrug-request (msg-type &rest params)
  "Requst MoiKrug API.
MSG-TYPE is one of:
  'list - PARAMS are :login and :password
  'invite - PARAMS are :email, :firstname, :lastname, :message"
  (let ((login (if (stringp moikrug-login) moikrug-login
                 (read-string "MoiKrug login: " user-mail-address)))
        (passwd (if (stringp moikrug-password) moikrug-password
                  (read-passwd "MoiKrug password: "))))
    ;; Save login/password in case of ask-once
    (when (eq moikrug-login 'ask-once)
      (setq moikrug-login login))
    (when (eq moikrug-password 'ask-once)
      (setq moikrug-password passwd))

    (moikrug-send-request
     `(SOAP-ENV:Envelope
       ((xmlns:SOAP-ENV . "http://schemas.xmlsoap.org/soap/envelope/";)
        (xmlns:xsi . "http://www.w3.org/1999/XMLSchema-instance";)
        (xmlns:xsd . "http://www.w3.org/1999/XMLSchema";))
       (SOAP-ENV:Body
        ()
        ,(nconc (list (ecase msg-type
                        (list 'ns1:getFirstCircle)
                        (invite 'ns1:invitePerson))
                      (list (cons 'xmlns:ns1 "urn:MoikrugContacts")
                            (cons 'SOAP-ENV:encodingStyle
                                  "http://schemas.xmlsoap.org/soap/encoding/";))
                      (list 'login '((xsi:type . "xsd:string")) login)
                      (list 'password '((xsi:type . "xsd:string")) passwd))
                (when (eq msg-type 'invite)
                  (list (list 'targetEmail '((xsi:type . "xsd:string"))
                              (plist-get params :email))
                        (list 'targetFirstname '((xsi:type . "xsd:string"))
                              (plist-get params :firstname))
                        (list 'targetLastname '((xsi:type . "xsd:string"))
                              (plist-get params :lastname))
                        (list 'message '((xsi:type . "xsd:string"))
                              (plist-get params :message)))))
        )))))

(put 'moikrug-request 'lisp-indent-function 'defun)

;;}}}

;;{{{ `-- UTF8 <--> KOI8-R convertor

;; GNU Emacs compatibility
(unless (fboundp 'char-to-int)
  (defalias 'char-to-int 'identity))
(unless (fboundp 'int-to-char)
  (defalias 'int-to-char 'identity))

(defvar moikrug-utf8-koi8-table
  (list [#x10 ?А] [#x11 ?Б] [#x12 ?В] [#x13 ?Г] [#x14 ?Д] [#x15 ?Е]
        [#x16 ?Ж] [#x17 ?З] [#x18 ?И] [#x19 ?Й] [#x1A ?К] [#x1B ?Л]
        [#x1C ?М] [#x1D ?Н] [#x1E ?О] [#x1F ?П]

        [#x20 ?Р] [#x21 ?С] [#x22 ?Т] [#x23 ?У] [#x24 ?Ф] [#x25 ?Х]
        [#x26 ?Ц] [#x27 ?Ч] [#x28 ?Ш] [#x29 ?Щ] [#x2A ??] [#x2B ?Ы]
        [#x2C ?Ь] [#x2D ?Э] [#x2E ?Ю] [#x2F ?Я]

        [#x30 ?а] [#x31 ?б] [#x32 ?в] [#x33 ?г] [#x34 ?д] [#x35 ?е]
        [#x36 ?ж] [#x37 ?з] [#x38 ?и] [#x39 ?й] [#x3A ?к] [#x3B ?л]
        [#x3C ?м] [#x3D ?н] [#x3E ?о] [#x3F ?п]

        [#x40 ?р] [#x41 ?с] [#x42 ?т] [#x43 ?у] [#x44 ?ф] [#x45 ?х]
        [#x46 ?ц] [#x47 ?ч] [#x48 ?ш] [#x49 ?щ] [#x4A ??] [#x4B ?ы]
        [#x4C ?ь] [#x4D ?э] [#x4E ?ю] [#x4F ?я] [#x51 ?ё]))

(defun moikrug-utf8-to-koi8-char (utf8-char)
  "Convert UTF8-CHAR to KOI8-R character."
  (let  ((ukl moikrug-utf8-koi8-table))
    (while (and ukl
                (not (= (aref (car ukl) 0) utf8-char)))
      (setq ukl (cdr ukl)))
    (or (and ukl
             (aref (car ukl) 1))
        ??)))

(defun moikrug-utf8-to-koi8 (utf8-string)
  "Convert UTF8-STRING to KOI8 string.

Here is how UTF-8 looks like

1:  0xxxxxxx
2:  110xxxxx 10xxxxxx
3:  1110xxxx 10xxxxxx 10xxxxxx
4:  11110xxx 10xxxxxx 10xxxxxx 10xxxxxx
5:  111110xx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx
6:  1111110x 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx 10xxxxxx

Supported types:

1:  0xxxxxxx
2:  110000xx 10xxxxxx

\\0400 - cyrillic"
  (let ((rstr "") fc ulen)
    (while (not (string= utf8-string ""))
      (setq fc (aref utf8-string 0))
      (when (= (logand #xa0 fc) #xa0)
        (error "Unsupported utf8 character type %d" fc))
      (setq ulen (if (zerop (logand #x80 fc)) 1 2))

      (if (= ulen 1)
          (setq rstr (concat rstr (char-to-string fc))
                utf8-string (substring utf8-string 1))
        (setq rstr (concat rstr
                           (char-to-string
                            (moikrug-utf8-to-koi8-char
                             (logior (lsh (logand #xf fc) 6)
                                     (logand #x3f (aref utf8-string 1))))))
              utf8-string (substring utf8-string 2))))
    rstr))

(defun moikrug-koi8-to-utf8-char (koi8-char)
  "Convert KOI8-CHAR to UTF8 character."
  (let  ((ukl moikrug-utf8-koi8-table))
    (while (and ukl
                (not (= (aref (car ukl) 1) koi8-char)))
      (setq ukl (cdr ukl)))
    (or (and ukl
             (aref (car ukl) 0))
        ??)))

(defun moikrug-koi8-to-utf8 (koi8-string)
  "Convert KOI8-STRING to UTF8 string."
  (mapconcat #'(lambda (k8c)
                 (if (zerop (logand (char-to-int k8c) #x80))
                     (char-to-string k8c)
                   (let ((cc (moikrug-koi8-to-utf8-char k8c)))
                     (concat (char-to-string
                              (int-to-char (logior 208 (lsh cc -6))))
                             (char-to-string
                              (int-to-char (logior 128 (logand 63 cc))))))))
             (string-to-list koi8-string) ""))

;;}}}
;;{{{ `-- Processing response

(defun moikrug-process-list (response &optional sort-type)
  "Process getFirstCircleResponse RESPONSE.
If SORT-TYPE is specified, then sort entries.  SORT-TYPE can be one of:
  'name     - Sort by name (default)
  'modified - Sort by recency of entry modification
  'contacts - Sort by number of contacts"
  (let* ((body (car (xml-get-children (car response) 'SOAP-ENV:Body)))
         (gfcr (car (xml-get-children body 'ns1:getFirstCircleResponse)))
         (return (car (xml-get-children gfcr 'return)))
         (items (xml-get-children return 'item))
         (retval '()))
    (while items
      (let (tits contact)
        (setq tits (xml-get-children (car items) 'item))
        (while tits
          (push (cons (intern (nth 2 (car (xml-get-children (car tits) 'key))))
                      (moikrug-utf8-to-koi8
                       (nth 2 (car (xml-get-children (car tits) 'value)))))
                contact)
          (setq tits (cdr tits)))
        (push (nreverse contact) retval))
      (setq items (cdr items)))

    ;; Sort the result according to
    (sort (nreverse retval)
          #'(lambda (c1 c2)
              (ecase sort-type
                ((name nil) nil)
                (modified
                 (let ((m1 (cdr (assq 'modified c1)))
                       (m2 (cdr (assq 'modified c2))))
                   (cond ((and m1 m2)
                          (> (time-to-seconds
                              (apply #'encode-time (parse-time-string m1)))
                             (time-to-seconds
                              (apply #'encode-time (parse-time-string m2)))))
                         ((and m1 (null m2)) t)
                         ((and (null m1) m2) nil))))
                (contacts (let ((cc1 (string-to-int
                                      (cdr (assq 'contacts_count c1))))
                                (cc2 (string-to-int
                                      (cdr (assq 'contacts_count c2)))))
                            (> cc1 cc2))))))))

(defun moikrug-process-invite (response)
  "Process invitePersonResponse RESPONSE."
  (let* ((body (car (xml-get-children (car response) 'SOAP-ENV:Body)))
         (gfcr (car (xml-get-children body 'ns1:invitePersonResponse)))
         (retval (car (xml-get-children gfcr 'return))))
    (nth 2 retval)))

(defun moikrug-process (msg-type response)
  "Process MSG-TYPE RESPONSE from MoiKrug."
  (ecase msg-type
    (list (moikrug-process-list response))
    (invite (moikrug-process-invite response))))

;;}}}

;;{{{ `-- BBDB Commands

;;;###autoload
(defun moikrug-bbdb-invite (record)
  "Invite person stored in RECORD."
  (interactive (list (bbdb-current-record)))
  (let* ((buf (get-buffer-create " *moi-krug-invite*"))
         (message (save-excursion
                    (set-window-buffer (selected-window) buf)
                    (erase-buffer)
                    (insert moikrug-invite-message)
                    (text-mode)
                    (local-set-key (kbd "C-c C-c") 'exit-recursive-edit)
                    (message "Press `C-c C-c' when done")
                    (recursive-edit)
                    (prog1
                        (buffer-substring (point-min) (point-max))
                      (kill-buffer (current-buffer)))))
         (ret (moikrug-process-invite
               (moikrug-request 'invite
                 :firstname (moikrug-koi8-to-utf8
                             (bbdb-record-firstname record))
                 :lastname (moikrug-koi8-to-utf8
                            (bbdb-record-lastname record))
                 :email (car (bbdb-record-net record))
                 :message (moikrug-koi8-to-utf8 message)))))
    (unless (string= ret "true")        ; XXX
      (error (format "Error inviting %s %s: %s" (bbdb-record-firstname record)
                     (bbdb-record-lastname record) ret)))
    (bbdb-record-putprop record 'moikrug-invite-date (current-time-string))
    (bbdb-display-records (list record))))

;;;###autoload
(defun moikrug-bbdb-merge-in (sort-type)
  "Merge MoiKrug records into BBDB.
If prefix argument is specified it will ask for SORT-TYPE,
otherwise `moikrug-sort-type' will be used."
  (interactive
   (list (if (null current-prefix-arg)
             moikrug-sort-type
           (intern (completing-read
                    (format "MoiKrug Sort [%S]: " moikrug-sort-type)
                    '(("name") ("modified") ("contacts")) nil t nil nil
                    (symbol-name moikrug-sort-type))))))
  (bbdb-display-records
   (mapcar #'(lambda (mkr)
               ;; Try to find appropriate BBDB record, create new BBDB
               ;; record if not found
               (let* ((email (cdr (assq 'email_primary mkr)))
                      (firstname (cdr (assq 'firstname mkr)))
                      (lastname (cdr (assq 'lastname mkr)))
                      (record (car (bbdb-search (bbdb-records) nil nil email))))
                 (unless record
                   ;; Create new BBDB record
                   (setq record
                         (bbdb-create-internal
                          (concat firstname " " lastname) nil email nil
                          nil nil)))
                 ;; Update record
                 (bbdb-record-set-firstname record firstname)
                 (bbdb-record-set-lastname record lastname)
                 (bbdb-record-set-net
                  record (union (bbdb-record-net record)
                                (list email) :test #'string=))
                 (when (cdr (assq 'modified mkr))
                   (bbdb-record-putprop
                    record 'moikrug-modified
                    (format-time-string
                     bbdb-time-display-format
                     (apply #'encode-time
                            (parse-time-string (cdr (assq 'modified mkr)))))))
                 (bbdb-record-putprop
                  record 'moikrug-merge
                  (format-time-string bbdb-time-display-format))
                 (bbdb-record-putprop
                  record 'moikrug-contacts (cdr (assq 'contacts_count mkr)))
                 (bbdb-change-record record t)
                 record))
           (moikrug-process-list (moikrug-request 'list) sort-type))))

;;}}}

(provide 'moikrug)

;;; moikrug.el ends here

-- 
lg