summaryrefslogtreecommitdiffstats
path: root/parrot-pdir.el
blob: 054500d0102240d6b5978ced4c7ff46d47703ffe (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
;;; -*- lexical-binding: t -*-

(defvar pdir-url "https://intranet.parrot.biz/directory/")
(defvar pdir-buffer "*Parrot Directory*")

(defun pdir-find-persons (filter list &optional acc)
  (cond ((consp list)
         (append (pdir-find-persons filter (car list))
                 (pdir-find-persons filter (cdr list))
                 (if (funcall filter list)
                     (cons list acc))
                 acc))))

(defun pdir-post-request (name)
  (let ((url-request-method "POST")
        (url-request-extra-headers
         `(("Content-Type" . "application/x-www-form-urlencoded")))
        (url-request-data (format "name=%s" name)))
    (with-current-buffer
        (url-retrieve-synchronously pdir-url)
      (libxml-parse-html-region (point-min) (point-max)))))

(defun pdir-extract-infos (person)
  (require 's)                          ;s-trim
  (require 'cl)                         ;cadar
  (let (pname
        ptel
        padress
        pmail
        ppic
        pjob)
    (mapc (lambda (e)
            (cond
             ((not (consp e)))
             ((string= (assoc-default 'class (cadr e)) "tel")
              (setq ptel (nth 4 e)))
             ((string= (assoc-default 'class (cadr e)) "photo")
              (setq ppic (assoc-default 'src (cadar (last e)))))
             ((string= (assoc-default 'class (cadr e)) "adress")
              (setq padress (nth 7 e)))
             ((string= (assoc-default 'class (cadr e)) "web")
              (setq pmail (car (last (car (last (butlast e)))))))
             ((string= (assoc-default 'class (cadr e)) "infos")
              (setq pname (caddr (nth 3 e)))
              (setq pjob (if (> (length (nth 4 e)) 1)
                             (nth 4 e)
                           (car (last (car (last e)))))))))
          person)

    (setq ppic (concat pdir-url ppic))

    (mapc (lambda (pair)
            (cons (car pair)
                  (s-trim (cdr pair))))
          (list (cons 'name pname)
                (cons 'tel ptel)
                (cons 'pic ppic)
                (cons 'mail pmail)
                (cons 'addr padress)
                (cons 'job pjob)))))

(defun pdir-print-person (person)
  (let ((pad (if (display-graphic-p) "    " "")))
    (insert pad)
    (pdir-put-pic (assoc-default 'pic person))
    (insert (concat (format "\n%sNom : %s\n" pad (assoc-default 'name person))
                    (format "%sJob : %s\n" pad (assoc-default 'job  person))
                    (format "%sLoc : %s\n" pad (assoc-default 'addr person))
                    (format "%sMail : %s\n" pad (assoc-default 'mail  person))
                    (format "%sTel : %s\n" pad (assoc-default 'tel  person))))
    (insert pad)
    (insert-button (assoc-default 'mail  person)
                   'action (lambda (x)
                             (compose-mail (button-label x) "")))
    (insert "\n\n")))

(defun pdir-put-pic (url)
  (let* ((buf (url-retrieve-synchronously url))
         (pic (with-current-buffer
                  buf
                (goto-char (point-min))
                (search-forward "\n\n")
                (buffer-substring (point) (point-max))))
         (err (with-current-buffer
                  buf
                (goto-char (point-min))
                (search-forward "not found" nil t))))
    (unless err
      ;; If image extension is .jpg and image format is bitmap,
      ;; `image-type' (called by `insert-image') will call `error',
      ;; which we don't want because it will block the whole process.
      ;; TODO: use the command "file" to check the file format and
      ;; change the extension accordingly.
      (ignore-errors
        (insert-image (if (image-type-available-p 'imagemagick)
                          (create-image pic 'imagemagick t
                                        :max-width 150
                                        :max-height 150)
                        (create-image pic nil t)))))))

(defun pdir-do-search (search)
  (let* ((html (pdir-post-request search))
         (pfilter (lambda (p) (and (eq (car p) 'div)
                                   (string= (assoc-default 'class (cadr p))
                                            "person"))))
         (persons (pdir-find-persons pfilter html)))
    (mapc 'pdir-print-person
          (mapcar 'pdir-extract-infos persons))))

;;;###autoload
(defun pdir-search ()
  (interactive)
  (let ((buffer (get-buffer-create pdir-buffer))
        (search (read-string "Search : ")))
    (with-current-buffer
        buffer
      (pdir-mode)
      (let ((inhibit-read-only 't))
        (erase-buffer)
        (if (not (pdir-do-search search))
            (insert "no matches")
          (goto-char (point-min))
          (forward-button 1))))
    (switch-to-buffer buffer)))

(defun pdir-kill-address ()
  (interactive)
  (let ((buffer (get-buffer pdir-buffer))
        (mail)
        (name ""))
    (with-current-buffer
        buffer
      (setq mail (s-chomp (thing-at-point 'line t)))
      (re-search-backward "Nom : \\(.*?\\)[ ]*$")
      (setq name (match-string 1))
      (kill-new (format "%s <%s>" name mail))
      (forward-button 1))))

(defvar pdir-mode-map
  (let ((map (make-sparse-keymap)))
    (define-key map (kbd "q") (lambda () (interactive) (quit-window t)))
    (define-key map (kbd "s") 'pdir-search)
    (define-key map (kbd "y") 'pdir-kill-address)
    (define-key map (kbd "n") 'forward-button)
    (define-key map (kbd "TAB") 'forward-button)
    (define-key map (kbd "p") 'backward-button)
    map))

;;;###autoload
(define-derived-mode pdir-mode fundamental-mode "pdir"
  "A mode to consult Parrot Directory"
  (read-only-mode))

(provide 'parrot-pdir)