?  search:
summary | log | graphiclog1 | graphiclog2 | commit | commitdiff | tree | refs | edit | fork
blame | history | raw | HEAD
Improve skip test if socks server is unavailable
[navi2ch.git] / navi2ch-net.el
blob01ff7b37bbf8eac0fea4a6320e1958861005e58e
1 ;;; navi2ch-net.el --- Network module for navi2ch -*- coding: iso-2022-7bit; -*-
2
3 ;; Copyright (C) 2000, 2001, 2002, 2003, 2004, 2005, 2006, 2008, 2009
4 ;; by Navi2ch Project
5
6 ;; Author: Taiki SUGAWARA <taiki@users.sourceforge.net>
7 ;; Keywords: network 2ch
8
9 ;; This file is free software; you can redistribute it and/or modify
10 ;; it under the terms of the GNU General Public License as published by
11 ;; the Free Software Foundation; either version 2, or (at your option)
12 ;; any later version.
13
14 ;; This file is distributed in the hope that it will be useful,
15 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
17 ;; GNU General Public License for more details.
18
19 ;; You should have received a copy of the GNU General Public License
20 ;; along with GNU Emacs; see the file COPYING. If not, write to
21 ;; the Free Software Foundation, Inc., 59 Temple Place - Suite 330,
22 ;; Boston, MA 02111-1307, USA.
23
24 ;;; Commentary:
25
26 ;;
27
28 ;;; Code:
29 (provide 'navi2ch-net)
30 (defconst navi2ch-net-ident
31 "$Id$")
32
33 (eval-when-compile
34 (require 'cl-lib)
35 (require 'navi2ch-decls)
36 (require 'navi2ch-inline))
37
38 (require 'navi2ch-rfc3986)
39 (require 'navi2ch-vars)
40
41 (require 'gnutls)
42 (require 'nsm)
43 (require 'socks)
44 (require 'puny)
45 (require 'timezone)
46 (require 'base64)
47
48 (defvar navi2ch-net-connection-name "navi2ch connection")
49 (defvar navi2ch-net-user-agent "Monazilla/1.00 Navi2ch")
50 (defvar navi2ch-net-setting-file-name "SETTING.TXT")
51 (defvar navi2ch-net-last-date nil)
52 (defvar navi2ch-net-last-url nil)
53 (defvar navi2ch-net-process nil)
54 (defvar navi2ch-net-last-host nil)
55 (defvar navi2ch-net-last-port nil)
56 (defvar navi2ch-net-status nil)
57 (defvar navi2ch-net-header nil)
58 (defvar navi2ch-net-content nil)
59 (defvar navi2ch-net-state-header-table
60 (navi2ch-alist-to-hash
61 '((aborn . "X-Navi2ch-Aborn") ; \e$B$"$\!<$s$5$l$F$k\e(B
62 (kako . "X-Navi2ch-Kako") ; \e$B2a5n%m%0$K$J$C$F$k\e(B
63 (not-updated . "X-Navi2ch-Not-Updated") ; \e$B99?7$5$l$F$$$J$$\e(B
64 (error . "X-Navi2ch-Error"))) ; \e$B%(%i!<\e(B(\e$B%U%!%$%k$,<hF@$G$-$J$$$H$+\e(B)
65 "STATE \e$B$N%7%s%\%k$H<B:]$K%X%C%@$K=q$+$l$kJ8;zNs$N\e(B hash\e$B!#\e(B")
66
67 (defcustom navi2ch-net-5chdat-downgrade-to-http nil
68 "*non-nil\e$B$+$D\e(Bnavi2ch-net-http-proxy\e$A$,\e(Bnon-nil\e$A$N\e$(G^[\e$A:O\e(B5ch\e$A$N\e(Bdat\e$AH!5C$N\e$(Gkc\e$A$O\e$(GZ0\e$AVF5D$K\e(Bhttp\e$A$G%G\e$B!<\e$A%?$rH!5C$9$k!#\e(B"
69 :type 'boolean
70 :group 'navi2ch)
71
72 (add-hook 'navi2ch-exit-hook 'navi2ch-net-cleanup)
73
74 ;; shut up XEmacs warnings
75 (eval-when-compile
76 (defvar inherit-process-coding-system))
77
78 (defmacro navi2ch-net-ignore-errors (&rest body)
79 "BODY \e$B$rI>2A$7!"$=$NCM$rJV$9!#\e(B
80 BODY \e$B$NI>2ACf$K%(%i!<$,5/$3$k$H\e(B nil \e$B$rJV$9!#\e(B"
81 (let ((done (make-symbol "--done-temp--"))
82 (err (make-symbol "--err-temp--")))
83 `(let ((,done nil))
84 (unwind-protect
85 (condition-case ,err
86 (prog1
87 ,(cons 'progn body)
88 (setq ,done t))
89 (error
90 (ding)
91 (if ,err
92 (message "Error: %s" (error-message-string ,err))
93 (message "Error"))
94 (sleep-for 1)
95 nil))
96 (unless ,done
97 (ignore-errors
98 (navi2ch-net-cleanup-process)))))))
99
100 (defun navi2ch-net-cleanup ()
101 (let (buf)
102 (if (processp navi2ch-net-process)
103 (setq buf (process-buffer navi2ch-net-process)))
104 (unwind-protect
105 (navi2ch-net-cleanup-process)
106 (if buf
107 (kill-buffer buf)))))
108
109 (defun navi2ch-net-cleanup-process ()
110 (unwind-protect
111 (if (processp navi2ch-net-process)
112 (delete-process navi2ch-net-process))
113 (setq navi2ch-net-process nil)
114 (navi2ch-net-cleanup-vars)))
115
116 (defun navi2ch-net-cleanup-vars ()
117 (setq navi2ch-net-status nil
118 navi2ch-net-header nil
119 navi2ch-net-content nil))
120
121 (defun navi2ch-open-network-stream-with-retry (name buffer host service &rest rest)
122 (let ((retry t) proc)
123 (while retry
124 (condition-case err
125 (setq proc (apply #'open-network-stream name buffer host service rest)
126 retry nil)
127 (file-error
128 (save-match-data
129 (if (string-match "in progress" ; EINPROGRESS or EALREADY
130 (nth 2 err))
131 (progn
132 (setq retry t)
133 (sleep-for 1))
134 (signal (car err) (cdr err)))))))
135 proc))
136
137 (cl-defstruct
138 (navi2ch-net-url
139 (:constructor
140 new-net-url
141 (protocol user password host port
142 path query fragment hostport)))
143 protocol
144 user
145 password
146 host
147 port
148 path
149 query
150 fragment
151 hostport)
152
153
154 (defun navi2ch-open-network-stream-via-command (name buffer host service &rest rest)
155 (let ((command (cond ((stringp navi2ch-open-network-stream-command)
156 (format navi2ch-open-network-stream-command
157 host service (memq (plist-get rest :type) '(tls ssl))))
158 ((functionp navi2ch-open-network-stream-command)
159 (apply navi2ch-open-network-stream-command
160 host service rest)))))
161 (apply #'start-process name buffer
162 (if (stringp command)
163 (list shell-file-name shell-command-switch command)
164 command))))
165
166 (defconst navi2ch-net--regexp-url (navi2ch-net-rfc3986-regexp 'absolute-URI:G))
167 (defun navi2ch-net-match-url (url)
168 (and url (string-match navi2ch-net--regexp-url url)
169 (mapcar (lambda (i)
170 (cons (car i) (match-string (cdr i) url)))
171 '((protocol . 1)
172 (user . 2)
173 (password . 3)
174 (host . 4)
175 (port . 5)
176 (path . 6)
177 (query . 7)
178 (fragment . 8)))))
179
180 (defun navi2ch-net-parse-url (url)
181 (let* ((url (cond
182 ;; proxy2ch\e$BBP1~\e(B
183 ;; https://5ch\e$BHD%[%9%H\e(B/\e$A0eC{\e(B/dat/\e$A%9%l%C%I%-\e$B!<\e(B.dat
184 ;; \e$A$N\e$(G^[\e$A:O$O\e(Bhttp\e$A$K%@%&%s%0%l\e$B!<\e$A%I$9$k\e(B
185 ((and navi2ch-net-5chdat-downgrade-to-http navi2ch-net-http-proxy
186 (not (string-match
187 (concat "\\`https://"
188 (regexp-opt navi2ch-list-invalid-hostnames)
189 "[:/]")
190 url))
191 (string-match
192 (concat "\\`https://[^/.]+\\(?:\\.[^./]+\\)*"
193 (regexp-opt navi2ch-list-valid-hostnames)
194 "/[^/]+/dat/[^/]+\\.dat\\(?:\\.gz\\)?")
195 url))
196 (concat "http" (substring url 5)))
197 (t url)))
198 (alist (navi2ch-net-match-url url)))
199 (when alist
200 (new-net-url
201 (cdr (assq 'protocol alist)) ; scheme(protocol)
202 (cdr (assq 'user alist)) ; user
203 (cdr (assq 'password alist)) ; password
204 (if (string-match ; host
205 "^\\[\\([^\\]+\\)\\]$" (cdr (assq 'host alist)))
206 (match-string 1 (cdr (assq 'host alist))) ; ipv6
207 (cdr (assq 'host alist))) ; hostname, ipv4
208 (cond ((cdr (assq 'port alist)) ; port present?
209 (string-to-number (cdr (assq 'port alist))))
210 ((cdr (assoc (cdr (assq 'protocol alist)) ; handled protocol
211 '(("http" . 80)
212 ("https" . 443)
213 ("socks4" . 1080)
214 ("socks5" . 1080)))))
215 (t nil))
216 (cdr (assq 'path alist))
217 (cdr (assq 'query alist))
218 (cdr (assq 'fragment alist))
219 (apply #'concat
220 (cdr (assq 'host alist))
221 (when (cdr (assq 'port alist))
222 (list ":" (cdr (assq 'port alist)))))))))
223
224 ;; (let ((sum 0))
225 ;; (dotimes (i 400 sum)
226 ;; (setq sum (+ sum (1- (floor (expt 1.00925 i)))))))
227 ;; => 3602
228 (defvar navi2ch-net-connect-wait-power 1.00925)
229 (defvar navi2ch-net-connect-time-list '())
230 (defvar navi2ch-net-fall-back-host "bg20.5ch.net")
231 ;;
232 ;; 5ch\e$BF10l%5!<%P!<$+$i$N\e(Bdat\e$BO"B3<hF@$O\e(Bbg20.5ch.net\e$A$X%U%)\e$B!<\e$A%k%P%C%/$9$k\e(B
233 ;;
234 (defun navi2ch-net-connect-check (server-info)
235 (let ((server-info server-info)
236 (host (navi2ch-net-url-host server-info))
237 (path (navi2ch-net-url-path server-info))
238 (protocol (navi2ch-net-url-protocol server-info)))
239
240 (when (string-match "[25]ch\\.net\\|bbspink\\.com\\|machi\\.to" host)
241 (let* ((now (navi2ch-float-time))
242 (limit (- now 3600.0))
243 (list (delq nil (mapcar (lambda (x) (if (> (cdr x) limit) x))
244 navi2ch-net-connect-time-list)))
245 (len (length (delq nil (mapcar (lambda (x)
246 (if (string= host (car x)) x))
247 list))))
248 (wait (floor (- (+ (expt navi2ch-net-connect-wait-power len)
249 (or (cdr (assoc host list)) now))
250 1
251 now))))
252 (if (> wait 0)
253 ; then
254 (if (and (string-match "[25]ch\\.net" host)
255 (string-match "/\\([^/]+\\)/dat/\\([0-9]+\\).dat" path))
256 (progn
257 (message "falling back to %s" navi2ch-net-fall-back-host)
258 (setq navi2ch-net-connect-time-list list)
259
260 (setq server-info
261 (navi2ch-net-parse-url
262 (concat protocol "://" navi2ch-net-fall-back-host
263 (format "/test/r.so/%s/%s/%s/"
264 host
265 (match-string 1 path)
266 (match-string 2 path))))))
267 ; else
268 (message "waiting for %dsec..." wait)
269 (sleep-for wait)
270 (message "waiting for %dsec...done" wait))
271 (setq navi2ch-net-connect-time-list
272 (cons (cons host (navi2ch-float-time)) list)))))
273 server-info))
274
275 (defvar navi2ch-net-down-host-alist nil)
276
277 (defvar navi2ch-net-retry-down-host 300
278 "\e$B0JA0Mn$A$F$$$?%[%9%H$K:F@\B3$9$k$^$G$NIC?t!#\e(B
279 nil \e$B$J$i>o$K:F@\B3$9$k!#\e(B")
280
281 (defun navi2ch-net-add-down-host (host)
282 (setq host (intern (downcase (format "%s" host))))
283 (setq navi2ch-net-down-host-alist
284 (navi2ch-put-alist host (navi2ch-float-time)
285 navi2ch-net-down-host-alist)))
286
287 (defun navi2ch-net-down-p (host)
288 (setq host (intern (downcase (format "%s" host))))
289 (let ((elt (assq host navi2ch-net-down-host-alist)))
290 (and elt
291 (numberp navi2ch-net-retry-down-host)
292 (> navi2ch-net-retry-down-host 0)
293 (< (navi2ch-float-time)
294 (+ (cdr elt) (float navi2ch-net-retry-down-host))))))
295
296
297 (defun navi2ch-net-send-request (url method &optional other-header content)
298 (setq navi2ch-net-last-url url)
299 (unless navi2ch-net-enable-http11
300 (navi2ch-net-cleanup-process))
301 (let ((buf (get-buffer-create (concat " *" navi2ch-net-connection-name)))
302 (process-connection-type nil)
303 (inherit-process-coding-system navi2ch-net-inherit-process-coding-system)
304 (request-url (navi2ch-net-connect-check (navi2ch-net-parse-url url)))
305 (proxy-url (navi2ch-net-parse-url navi2ch-net-http-proxy)))
306
307 (let ((proxy-credentials
308 (and proxy-url
309 (navi2ch-net-http-basic-credentials
310 (or navi2ch-net-http-proxy-userid
311 (navi2ch-net-url-user proxy-url))
312 (or navi2ch-net-http-proxy-password
313 (navi2ch-net-url-password proxy-url)))))
314 (protocol (navi2ch-net-url-protocol request-url))
315 (user (navi2ch-net-url-user request-url))
316 (pass (navi2ch-net-url-password request-url))
317 (host (navi2ch-net-url-host request-url))
318 (path (navi2ch-net-url-path request-url))
319 (port (navi2ch-net-url-port request-url))
320 (auth (navi2ch-net-http-basic-credentials
321 (navi2ch-net-url-user request-url)
322 (navi2ch-net-url-password request-url)))
323 (query (navi2ch-net-url-query request-url))
324 (rest (list :type (when (string= (navi2ch-net-url-protocol request-url) "https") 'tls)))
325 (proc navi2ch-net-process))
326
327 ; clean garbage
328 (condition-case nil
329 (if (and navi2ch-net-enable-http11
330 (equal host navi2ch-net-last-host)
331 (equal port navi2ch-net-last-port)
332 (processp proc)
333 (memq (process-status proc) '(open run)))
334 (progn
335 (message "Reusing connection...")
336 (navi2ch-net-get-content proc)) ; \e$BA02s$N%4%_$rFI$_Ht$P$7$F$*$/\e(B
337 (if (processp proc)
338 (delete-process proc))
339 (setq proc nil))
340 (setq proc nil))
341
342
343 ;; (error (setq proc nil)))
344
345 (when (or (not proc)
346 (not (processp proc))
347 (not (memq (process-status proc) '(open run))))
348 (message "Now connecting...")
349 (navi2ch-log)
350 (setq proc nil)
351 (unless (navi2ch-net-down-p host)
352 (condition-case nil
353 (setq proc (if (and proxy-url (string= protocol "http"))
354 (funcall navi2ch-open-network-stream-function
355 navi2ch-net-connection-name buf
356 (navi2ch-net-url-host proxy-url)
357 (navi2ch-net-url-port proxy-url)
358 :type (if (string= (navi2ch-net-url-protocol proxy-url) "https") 'tls nil))
359 (apply navi2ch-open-network-stream-function
360 navi2ch-net-connection-name buf host port rest)))
361 (message "%shost is down" (current-message))
362 (navi2ch-log)
363 (navi2ch-net-add-down-host host))))
364
365 (when proc
366 ;; (when (string= "https" scheme)
367 ;; (gnutls-negotiate :process proc :type 'gnutls-x509pki :hostname (puny-encode-domain host)))
368 (with-current-buffer buf
369 (navi2ch-set-buffer-multibyte nil)
370 (erase-buffer))
371 (setq navi2ch-net-last-host host)
372 (setq navi2ch-net-last-port port)
373 (message "%ssending request to %s:%s..." (current-message) host port)
374 (navi2ch-log)
375 (set-process-coding-system proc 'binary 'binary)
376 (set-process-sentinel proc 'ignore) ; exited abnormary \e$B$r=P$5$J$/$9$k\e(B
377
378 (let ((request-line (format "%s %s HTTP/1.1"
379 method
380 (apply #'concat
381 (when (and proxy-url
382 (string= protocol "http"))
383 (format "http://%s" (navi2ch-net-url-hostport request-url)))
384 path
385 (when query (list "?" query)))))
386 (request-message (format (concat
387 "MIME-Version: 1.0\r\n"
388 "Host: %s\r\n"
389 "%s" ;connection
390 "%s" ;other-header
391 "%s" ;content
392 "\r\n")
393 (navi2ch-net-url-hostport request-url)
394 (if navi2ch-net-enable-http11
395 ""
396 "Connection: close\r\n")
397 (or (navi2ch-net-make-request-header
398 (append (list (cons "Proxy-Authorization" proxy-credentials)
399 (cons "User-Agent" navi2ch-net-user-agent)
400 (cons "Authorization" auth)
401 (cons "Accept-Language" "en-US, ja"))
402 other-header))
403 "")
404 (if content
405 (format "Content-length: %d\r\n\r\n%s"
406 (length content) content)
407 ""))))
408
409 (navi2ch-log 'LOG_INFO "%s" request-line)
410 (navi2ch-log 'LOG_VERBOSE "%s" request-message)
411 (process-send-string proc (concat request-line "\r\n" request-message)))
412
413 (process-put proc 'method method)
414 (message "%sdone" (current-message)))
415
416 (navi2ch-net-cleanup-vars)
417 (setq navi2ch-net-process proc))))
418
419 (defun navi2ch-net-split-url (url &optional proxy)
420 (let (host2ch authinfo user pass)
421 (string-match "https?://\\([^@/]+@\\)?\\([^/]+\\)" url)
422 ; authinfo\e$B$+$i\e(Buser, pass\e$B$rCj=P\e(B
423 (when (setq authinfo (match-string 1 url))
424 (save-match-data
425 (string-match "\\(?:\\([^:]+\\):\\)?\\(.*\\)@" authinfo)
426 (if (match-beginning 1)
427 (setq user (match-string 1 authinfo)
428 pass (match-string 2 authinfo))
429 (setq user (match-string 2 authinfo)))))
430
431 ;; host2ch \e$A%*%j%8%J%k%[%9%H\e(B:port
432 (setq host2ch (match-string 2 url))
433 (if proxy
434 (progn
435 (string-match "^\\(?:\\(https?\\)://\\)?\\(.*\\):\\([0-9]\\{1,5\\}\\)" proxy)
436 (list
437 (cons 'protocol (match-string 1 proxy))
438 (cons 'user user)
439 (cons 'pass pass)
440 (cons 'host (match-string 2 proxy))
441 (cons 'file url)
442 (cons 'port (string-to-number (match-string 3 proxy)))))
443
444 ;; direct connection
445 (string-match "^\\(https?\\)://\\(?:[^@/]+@\\)?\\([^/:]+\\)\\(?::\\([0-9]+\\)\\)?\\(.*\\)" url)
446 (list
447 (cons 'protocol (match-string 1 url))
448 (cons 'user user)
449 (cons 'pass pass)
450 (cons 'host (match-string 2 url))
451 (cons 'port (cond ((match-string 3 url)
452 (string-to-number (match-string 3 url)))
453 ((string-equal "https" (match-string 1 url))
454 443)
455 (t 80)))
456 (cons 'file (match-string 4 url))
457 (cons 'host2ch host2ch)))))
458
459 (defun navi2ch-net-http-basic-credentials (user pass)
460 "USER \e$B$H\e(B PASS \e$B$+$i\e(B Basic \e$BG'>Z$N>ZL@=q\e(B (?) \e$BItJ,$rJV$9!#\e(B"
461 (when (and user pass)
462 (concat "Basic "
463 (base64-encode-string
464 (concat user ":" pass)))))
465
466 (defun navi2ch-net-make-request-header (header-alist)
467 "'((NAME . VALUE)...) \e$B$J\e(B HEADER-ALIST \e$B$+$i%j%/%(%9%H%X%C%@$r:n$k!#\e(B"
468 (let (header)
469 (dolist (pair header-alist)
470 (when (and pair (cdr pair))
471 (setq header (concat header
472 (car pair) ": " (cdr pair) "\r\n"))))
473 header))
474
475
476 (defun navi2ch-net-get-status (proc)
477 "PROC \e$B$N@\B3$N%9%F!<%?%9It$rJV$9!#\e(B"
478 (navi2ch-net-ignore-errors
479 (or navi2ch-net-status
480 (with-current-buffer (process-buffer proc)
481 (while (and (memq (process-status proc) '(open run))
482 (goto-char (point-min))
483 (not (looking-at "HTTP/1\\.[01] \\([0-9]\\{3\\}\\)")))
484 (accept-process-output proc))
485 (goto-char (point-min))
486 (if (looking-at "HTTP/1\\.[01] \\([0-9]\\{3\\}\\)")
487 (setq navi2ch-net-status (match-string 1)))))))
488
489 (defun navi2ch-net-get-protocol (proc)
490 (when (navi2ch-net-get-status proc)
491 (with-current-buffer (process-buffer proc)
492 (goto-char (point-min))
493 (if (looking-at "\\(HTTP/1\\.[01]\\) [0-9]+")
494 (match-string 1)))))
495
496 (defun navi2ch-net-get-status-line (proc)
497 (when (navi2ch-net-get-status proc)
498 (with-current-buffer (process-buffer proc)
499 (goto-char (point-min))
500 (if (looking-at "\\(HTTP/1\\.[01] [0-9]+.*\\)")
501 (match-string 1)))))
502
503 (defun navi2ch-net-get-header (proc)
504 "PROC \e$B$N@\B3$N%X%C%@It$rJV$9!#\e(B"
505 (when (navi2ch-net-get-status proc)
506 (navi2ch-net-ignore-errors
507 (or navi2ch-net-header
508 (with-current-buffer (process-buffer proc)
509 (while (and (memq (process-status proc) '(open run))
510 (goto-char (point-min))
511 (not (re-search-forward "\r\n\r?\n" nil t)))
512 (accept-process-output proc))
513 (goto-char (point-min))
514 (re-search-forward "\r\n\r?\n")
515 (let ((end (match-end 0))
516 list)
517 (goto-char (point-min))
518 (while (re-search-forward "^\\([^\r\n:]+\\): \\(.+\\)\r\n" end t)
519 (setq list (cons (cons (intern (downcase (match-string 1)))
520 (match-string 2))
521 list)))
522 (let ((date (assq 'date list)))
523 (when (and date (stringp (cdr date)))
524 (setq navi2ch-net-last-date (cdr date))))
525 (setq navi2ch-net-header (nreverse list))))))))
526
527 (defun navi2ch-net-get-content-subr-with-temp-file (gzip-p start end)
528 (if gzip-p
529 (let* ((tempfn (make-temp-name (navi2ch-temp-directory)))
530 (tempfngz (concat tempfn ".gz")))
531 (let ((coding-system-for-write 'binary)
532 ;; auto-compress-mode\e$B$r\e(Bdisable\e$B$K$9$k\e(B
533 (inhibit-file-name-operation 'write-region)
534 (inhibit-file-name-handlers (cons 'jka-compr-handler
535 inhibit-file-name-handlers)))
536 (navi2ch-write-region start end tempfngz))
537 (let ((status
538 (let ((default-directory (navi2ch-default-directory)))
539 (call-process shell-file-name nil nil nil
540 shell-command-switch
541 (concat "gzip -d " tempfngz)))))
542 (unless (and (numberp status) (zerop status))
543 (error "Failed to execute gzip")))
544 (delete-region start end)
545 (goto-char start)
546 (goto-char (+ start
547 (nth 1 (insert-file-contents-literally tempfn))))
548 (delete-file tempfn))))
549
550 (defun navi2ch-net-get-content-subr-region (gzip-p start end)
551 (if gzip-p
552 (let (status)
553 (setq status
554 (let ((default-directory (navi2ch-default-directory)))
555 (apply 'call-process-region
556 start end
557 navi2ch-net-gunzip-program t t nil
558 navi2ch-net-gunzip-args)))
559 (unless (and (numberp status) (zerop status))
560 (error "Failed to execute gzip")))))
561
562 (eval-and-compile
563 (defalias 'navi2ch-net-get-content-subr
564 (navi2ch-ifemacsce
565 'navi2ch-net-get-content-subr-with-temp-file
566 'navi2ch-net-get-content-subr-region)))
567
568 (defun navi2ch-net-get-chunk (proc)
569 "\e$B%+%l%s%H%P%C%U%!$N\e(B PROC \e$B$N\e(B point \e$B0J9_$r\e(B chunk \e$B$H$_$J$7$F\e(B chunk \e$B$rF@$k!#\e(B
570 chunk \e$B$N%5%$%:$rJV$9!#\e(Bpoint \e$B$O\e(B chunk \e$B$ND>8e$K0\F0!#\e(B"
571 (catch 'ret
572 (let ((p (point))
573 size end)
574 (while (and (not (looking-at "\\([0-9a-fA-F]+\\)[^\r\n]*\r\n"))
575 (memq (process-status proc) '(open run)))
576 (accept-process-output proc)
577 (goto-char p))
578 (when (not (match-string 1))
579 (message "No chunk-size line")
580 (throw 'ret 0))
581 (goto-char (match-end 0))
582 (setq size (string-to-number (match-string 1) 16)
583 end (+ p size 2)) ; chunk-data CRLF
584 (delete-region p (point)) ; chunk size \e$B9T$r>C$9\e(B
585 (if (= size 0)
586 (throw 'ret 0))
587 (while (and (memq (process-status proc) '(open run))
588 (goto-char end)
589 (not (= (point) end)))
590 (accept-process-output proc))
591 (goto-char end)
592 (when (not (= (point) end))
593 (message "Unable goto chunk end (size: %d, end: %d, point: %d)"
594 size end (point))
595 (throw 'ret 0))
596 (when (not (string= (buffer-substring (- (point) 2) (point))
597 "\r\n"))
598 (message "Invalid chunk body")
599 (throw 'ret 0)) ; chunk-data \e$B$NKvHx$,\e(B CRLF \e$B$8$c$J$$\e(B
600 (delete-region (- (point) 2) (point))
601 size)))
602
603 (defun navi2ch-net-get-content (proc)
604 "PROC \e$B$N@\B3$NK\J8$rJV$9!#\e(B"
605 (when (and (navi2ch-net-get-status proc)
606 (navi2ch-net-get-header proc)
607 (not (string= (process-get proc 'method) "HEAD")))
608 (navi2ch-net-ignore-errors
609 (or navi2ch-net-content
610 (let* ((header (navi2ch-net-get-header proc))
611 (gzip (and navi2ch-net-accept-gzip
612 (string-match "gzip"
613 (or (cdr (assq 'content-encoding
614 header))
615 ""))))
616 p)
617 (with-current-buffer (process-buffer proc)
618 (goto-char (point-min))
619 (re-search-forward "\r\n\r?\n") ; header \e$B$N8e$J$N$G<h$l$F$k$O$:\e(B
620 (setq p (point))
621 (cond ((equal (cdr (assq 'transfer-encoding header))
622 "chunked")
623 (while (> (navi2ch-net-get-chunk proc) 0)
624 nil))
625 ((assq 'content-length header)
626 (let ((size (string-to-number (cdr (assq 'content-length
627 header)))))
628 (while (and (memq (process-status proc) '(open run))
629 (goto-char (+ p size))
630 (not (= (point) (+ p size))))
631 (accept-process-output proc))
632 (goto-char (+ p size))))
633 ((or (string= (navi2ch-net-get-protocol proc)
634 "HTTP/1.0")
635 (not navi2ch-net-enable-http11)
636 (and (stringp (cdr (assq 'connection header)))
637 (string= (cdr (assq 'connection header))
638 "close")))
639 (while (memq (process-status proc) '(open run))
640 (accept-process-output proc))
641 (goto-char (point-max))))
642 (when (and (stringp (cdr (assq 'connection header)))
643 (string= (cdr (assq 'connection header))
644 "close"))
645 (delete-process proc))
646 (navi2ch-net-get-content-subr gzip p (point))
647 (setq navi2ch-net-content
648 (buffer-substring-no-properties p (point)))))))))
649
650 (defun navi2ch-net-download-file
651 (url &optional time accept-status other-header allow-redirect)
652 "URL \e$B$+$i%@%&%s%m!<%I$r3+;O$9$k!#\e(B
653 TIME \e$B$,\e(B `non-nil' \e$B$J$i$P\e(B TIME \e$B$h$j?7$7$$;~$@$1%@%&%s%m!<%I$9$k!#\e(B
654 \e$B%j%9%H\e(B ACCEPT-STATUS \e$B$,\e(B `non-nil' \e$B$J$i$P%9%F!<%?%9$,\e(B ACCEPT-STATUS \e$B$K4^$^$l\e(B
655 \e$B$F$$$k;~$@$1%@%&%s%m!<%I$9$k!#\e(B
656 OTHER-HEADER \e$B$,\e(B `non-nil' \e$B$J$i$P%j%/%(%9%H$K$3$N%X%C%@$rDI2C$9$k!#\e(B
657 \e$B%@%&%s%m!<%I$G$-$l$P$=$N@\B3$rJV$9!#\e(B
658 allow-redirect\e$A$,U{J}$J$i$P\e$(I/N\e$A$rIOO^$H$7$F!"\e(Bt\e$A$N\e$(G^[\e$A:O$OIOO^$J$7$G%j%@%$%l%/%H$9$k!#\e(B
659 "
660 (let ((time (if (or (null time) (stringp time))
661 time
662 (navi2ch-http-date-encode time)))
663 (url url))
664 (cl-multiple-value-bind (proc status header)
665 (cl-loop
666 (let* ((proc (let
667 ((proc (navi2ch-net-ignore-errors
668 (navi2ch-net-send-request
669 url "GET"
670 (append
671 (list (if navi2ch-net-force-update
672 (cons "Pragma" "no-cache")
673 (and time (cons "If-Modified-Since" time)))
674 (and navi2ch-net-accept-gzip
675 ;; regexp \e$B$OJQ?t$K$7$?J}$,$$$$$N$+$J!#$$$$JQ?tL>$,;W$$$D$+$J$$!#\e(B
676 (not (string-match "\\.gz$" url))
677 (not (assoc "Range" other-header))
678 '("Accept-Encoding" . "gzip, deflate")))
679 other-header)))))
680 (if proc
681 proc
682 (cl-return (cl-values nil nil nil)))))
683 (status (progn
684 (message "Checking file...")
685 (navi2ch-log 'LOG_INFO "%s" (current-message))
686 (navi2ch-net-get-status proc)))
687 (header (navi2ch-net-get-header proc)))
688
689 (cond ((and allow-redirect
690 (assoc status '("301" "302")))
691 (when (and (numberp allow-redirect)
692 (minusp (cl-decf allow-redirect)))
693 (cl-return (cl-values proc status header)))
694 (setq url (cond ((cdr (assq 'location header)))
695 (t (error "Location Header\e$B$,B8:_$7$^$;$s!#\e(B")))))
696 ((and (string= status "416")
697 (assoc "Range" other-header))
698 (let ((elt (assoc "Range" other-header)))
699 (setq other-header (delq elt other-header))))
700 (t
701 (cl-return (cl-values proc status header))))
702 (message "Retrying...")
703 (navi2ch-log)
704 (sleep-for 3)))
705
706
707 (navi2ch-log 'LOG_INFO "%s" (navi2ch-net-get-status-line proc))
708 (let ((proc (cond ((not (stringp status))
709 (message "%serror" (or (current-message) ""))
710 (delete-process proc)
711 nil)
712 ((string= status "404")
713 (message "%snot found" (or (current-message) ""))
714 (delete-process proc)
715 nil)
716 ((string= status "304")
717 (message "%snot updated" (or (current-message) ""))
718 proc)
719 ((string= status "302")
720 (message "%smoved" (or (current-message) ""))
721 proc)
722 ((string-match "\\`2[0-9][0-9]\\'" status)
723 (message "%supdated" (or (current-message) ""))
724 proc)
725 (t
726 (message "%serror" (or (current-message) ""))
727 nil))))
728 (when (or (not accept-status)
729 (member status accept-status))
730 proc)))))
731
732 (defun navi2ch-net-download-file:old
733 (url &optional time accept-status other-header)
734 "URL \e$B$+$i%@%&%s%m!<%I$r3+;O$9$k!#\e(B
735 TIME \e$B$,\e(B `non-nil' \e$B$J$i$P\e(B TIME \e$B$h$j?7$7$$;~$@$1%@%&%s%m!<%I$9$k!#\e(B
736 \e$B%j%9%H\e(B ACCEPT-STATUS \e$B$,\e(B `non-nil' \e$B$J$i$P%9%F!<%?%9$,\e(B ACCEPT-STATUS \e$B$K4^$^$l\e(B
737 \e$B$F$$$k;~$@$1%@%&%s%m!<%I$9$k!#\e(B
738 OTHER-HEADER \e$B$,\e(B `non-nil' \e$B$J$i$P%j%/%(%9%H$K$3$N%X%C%@$rDI2C$9$k!#\e(B
739 \e$B%@%&%s%m!<%I$G$-$l$P$=$N@\B3$rJV$9!#\e(B
740 "
741 (catch 'ret
742 (navi2ch-net-ignore-errors
743 (let ((time (if (or (null time) (stringp time)) time
744 (navi2ch-http-date-encode time)))
745 proc status)
746 (while (not status)
747 (setq proc
748 (navi2ch-net-send-request
749 url "GET"
750 (append
751 (list (if navi2ch-net-force-update
752 (cons "Pragma" "no-cache")
753 (and time (cons "If-Modified-Since" time)))
754 (and navi2ch-net-accept-gzip
755 ;; regexp \e$B$OJQ?t$K$7$?J}$,$$$$$N$+$J!#$$$$JQ?tL>$,;W$$$D$+$J$$!#\e(B
756 (not (string-match "\\.gz$" url))
757 (not (assoc "Range" other-header))
758 '("Accept-Encoding" . "gzip, deflate")))
759 other-header)))
760 (unless proc
761 (throw 'ret nil))
762 (navi2ch-log 'LOG_INFO "Checking file...")
763 (message "Checking file...")
764 (setq status (navi2ch-net-get-status proc))
765 (when (and (string= status "416")
766 (assoc "Range" other-header))
767 (let ((elt (assoc "Range" other-header)))
768 (setq other-header (delq elt other-header)
769 status nil)))
770 (unless status
771 (message "Retrying...")
772 (navi2ch-log)
773 (sleep-for 3))) ; \e$B%j%H%i%$$9$kA0$K$A$g$C$HBT$D\e(B
774 (navi2ch-log 'LOG_INFO "%s" (navi2ch-net-get-status-line proc))
775 (cond ((not (stringp status))
776 (message "%serror" (current-message))
777 (setq proc nil))
778 ((string= status "404")
779 (message "%snot found" (current-message))
780 (setq proc nil))
781 ((string= status "304")
782 (message "%snot updated" (current-message)))
783 ((string= status "302")
784 (message "%smoved" (current-message)))
785 ((string-match "\\`2[0-9][0-9]\\'" status)
786 (message "%supdated" (current-message)))
787 (t
788 (message "%serror" (current-message))
789 (setq proc nil)))
790 (if (or (not accept-status)
791 (member status accept-status))
792 proc)))))
793
794 (defun navi2ch-net-download-file-range (url range &optional time other-header)
795 "Range \e$B%X%C%@$r;H$C$F%U%!%$%k$r%@%&%s%m!<%I$9$k!#\e(B"
796 (navi2ch-net-download-file url time '("206" "200" "304") ;; 200 \e$B$b$"$C$F$b$$$$$N$+$J!)\e(B
797 (append
798 (list (cons "Range" (concat "bytes=" range)))
799 other-header)))
800
801 (defsubst navi2ch-net-add-state (state header)
802 "HEADER \e$B$K\e(B STATE \e$B$rDI2C$9$k!#\e(B"
803 (navi2ch-put-alist (gethash state navi2ch-net-state-header-table)
804 "yes"
805 header))
806
807 (defun navi2ch-net-is-tanpan-thread-p (cont)
808 (and cont
809 (string-match
810 "\\`[^\n<]+<><>[0-9]+/[0-9]+/[0-9]+ [0-9]+:[0-9]+:[0-9]+ ID:TanpanM<>"
811 cont)))
812
813 (defun navi2ch-net-update-file (url file
814 &optional time func location diff other-header)
815 "FILE \e$B$r99?7$9$k!#\e(B
816 TIME \e$B$,\e(B non-nil \e$B$J$i$P\e(B TIME \e$B$h$j?7$7$$;~$@$199?7$9$k!#\e(B
817 TIME \e$B$,\e(B 'file \e$B$J$i$P%U%!%$%k$N99?7F|;~$r\e(B TIME \e$B$H$9$k!#\e(B
818 FUNC \e$B$,\e(B non-nil \e$B$J$i$P99?78e\e(B FUNC \e$B$r;H$C$F%U%!%$%k$rJQ49$9$k!#\e(B
819 FUNC \e$B$O\e(B current-buffer \e$B$rA`:n$9$k4X?t$G$"$k;v!#\e(B
820 LOCATION \e$B$,\e(B non-nil \e$B$J$i$P\e(B Location \e$B%X%C%@$,$"$C$?$i$=$3$K0\F0$9$k$h$&\e(B
821 \e$B$K$9$k!#\e(B
822 DIFF \e$B$,\e(B non-nil \e$B$J$i$P\e(B \e$B:9J,$H$7$F\e(B FILE \e$B$r>e=q$-$;$:$KDI2C$9$k!#\e(B
823 OTHER-HEADER \e$B$O\e(B `navi2ch-net-download-file' \e$B$KEO$5$l$k!#\e(B
824 \e$B99?7$G$-$l$P\e(B header \e$B$rJV$9\e(B"
825 (when (eq time 'file)
826 (setq time (and (file-exists-p file)
827 (navi2ch-file-mtime file))))
828 (let ((dir (file-name-directory file)))
829 (unless (file-exists-p dir)
830 (make-directory dir t)))
831 (let ((coding-system-for-write 'binary)
832 (coding-system-for-read 'binary)
833 (redo t)
834 proc status header cont)
835 (while redo
836 (setq redo nil
837 proc (navi2ch-net-download-file url time
838 (list "200" "304"
839 (and location "302"))
840 other-header)
841 status (and proc
842 (navi2ch-net-get-status proc))
843 header (and proc
844 (navi2ch-net-get-header proc)))
845 (cond ((or (not proc)
846 (not status)
847 (not header))
848 ;; \e$BG0$N$?$a\e(B
849 (setq header (navi2ch-net-add-state 'error header)))
850 ((string= status "200")
851 (message (if diff
852 "%s: Getting file diff..."
853 "%s: Getting new file...")
854 (current-message))
855 (setq cont (navi2ch-net-get-content proc))
856 (when (and cont func)
857 (message "%stranslating..." (current-message))
858 (setq cont (with-temp-buffer
859 (navi2ch-set-buffer-multibyte nil)
860 (insert cont)
861 (goto-char (point-min))
862 (set (make-local-variable 'navi2ch-list-media-type)
863 (if (assq 'content-type header)
864 (assq 'content-type header)))
865 (funcall func)
866 (buffer-string))))
867 (when (navi2ch-net-is-tanpan-thread-p cont)
868 (setq cont nil)
869 (setq header (navi2ch-net-add-state 'error header)))
870 (if (and cont (not (string= cont "")))
871 (with-temp-file file
872 (navi2ch-set-buffer-multibyte nil)
873 (when diff
874 (insert-file-contents file)
875 (goto-char (point-max)))
876 (insert cont)
877 (message "%sdone" (current-message)))
878 (setq header (navi2ch-net-add-state 'not-updated header))
879 (message "%snot updated" (current-message))))
880 ((and location
881 (string= status "302")
882 (assq 'location header))
883 (setq url (cdr (assq 'location header))
884 redo t)
885 (message "%s: Redirecting..." (current-message)))
886 ((string= status "304")
887 (setq header (navi2ch-net-add-state 'not-updated header)))
888 (t
889 ;; \e$B$3$3$KMh$k$O$:$J$$$1$I0l1~\e(B
890 (setq header (navi2ch-net-add-state 'error header)))))
891 header))
892
893 (defun navi2ch-net-get-length-from-header (header)
894 "header \e$B$+$i\e(B contents \e$BA4BN$ND9$5$rF@$k!#\e(B
895 header \e$B$KD9$5$,4^$^$l$F$$$J$$>l9g$O\e(B nil \e$B$rJV$9!#\e(B"
896 (let ((range (cdr (assq 'content-range header)))
897 (length (cdr (assq 'content-length header))))
898 (cond ((and range
899 (string-match "/\\(.+\\)" range))
900 (string-to-number (match-string 1 range)))
901 (length
902 (string-to-number length)))))
903
904 (defun navi2ch-net-check-aborn (size header)
905 "\e$B$"$\!<$s$5$l$F$J$1$l$P\e(B t \e$B$rJV$9!#\e(B"
906 (let ((len (navi2ch-net-get-length-from-header header)))
907 (if len
908 (>= len (or size 0))
909 t))) ; \e$B%[%s%H$K$3$l$G$$$$$+$J\e(B?
910
911 (defconst navi2ch-net-update-file-diff-size 16
912 "\e$B:9J,<hF@$9$k:]$K%*!<%P!<%i%C%W$5$;$kI}!#\e(B")
913
914 (defun navi2ch-net-update-file-diff (url file &optional time)
915 "FILE \e$B$r:9J,$G99?7$9$k!#\e(B
916 TIME \e$B$,\e(B `non-nil' \e$B$J$i$P\e(B TIME \e$B$h$j?7$7$$;~$@$199?7$9$k!#\e(B
917 \e$B99?7$G$-$l$P\e(B HEADER \e$B$rJV$9!#\e(B"
918 (let ((dir (file-name-directory file)))
919 (unless (file-exists-p dir)
920 (make-directory dir t)))
921 (let* ((coding-system-for-write 'binary)
922 (coding-system-for-read 'binary)
923 ;; \e$B%U%!%$%k%5%$%:$HEy$7$$CM$r\e(B range \e$B$K$9$k$H%U%!%$%k$rA4ItAw$C\e(B
924 ;; \e$B$F$/$k$N$G0z$$$F$*$/!#\e(B
925 (size (max 0 (- (navi2ch-file-size file)
926 navi2ch-net-update-file-diff-size)))
927 (last (and (> size 0)
928 (with-temp-buffer
929 (navi2ch-set-buffer-multibyte nil)
930 (insert-file-contents file nil size)
931 (buffer-string))))
932 (last-all (with-temp-buffer
933 (navi2ch-set-buffer-multibyte nil)
934 (insert-file-contents file)
935 (buffer-string)))
936 proc header status aborn-p)
937 (setq proc (navi2ch-net-download-file-range url (format "%d-" size) time))
938 (setq header (and proc
939 (navi2ch-net-get-header proc)))
940 (setq status (and proc
941 (navi2ch-net-get-status proc)))
942 (cond ((or (not proc)
943 (not header)
944 (not status))
945 (setq header (navi2ch-net-add-state 'error header)))
946 ((string= status "304")
947 (setq header (navi2ch-net-add-state 'not-updated header)))
948 ((string= status "206")
949 (if (not (navi2ch-net-check-aborn size header))
950 (setq aborn-p t)
951 (message "%s: Getting file diff..." (current-message))
952 (let ((cont (navi2ch-net-get-content proc)))
953 (cond ((and (> size 0) last
954 (or (> (length last) (length cont))
955 (not (string= (substring cont 0 (length last))
956 last))))
957 (setq aborn-p t)) ; \e$BA02s$H0lCW$7$J$$>l9g$O$"$\!<$s\e(B
958 ((string= cont last)
959 (message "%snot updated" (current-message))
960 (setq header
961 (navi2ch-net-add-state 'not-updated header)))
962 (t
963 (with-temp-file file
964 (navi2ch-set-buffer-multibyte nil)
965 (insert-file-contents file nil nil size)
966 (goto-char (point-max))
967 (insert cont))
968 (message "%sdone" (current-message)))))))
969 ((string= status "200")
970 (if (not (navi2ch-net-check-aborn size header))
971 (setq aborn-p t)
972 (message "%s: Getting whole file..." (current-message))
973 (let ((cont (navi2ch-net-get-content proc)))
974 (with-temp-file file
975 (navi2ch-set-buffer-multibyte nil)
976 (insert cont))
977 (if (string= cont last-all)
978 (progn
979 (message "%sdone...not updated" (current-message))
980 (setq header
981 (navi2ch-net-add-state 'not-updated header)))
982 (message "%sdone" (current-message))))))
983 (t
984 (setq header (navi2ch-net-add-state 'error header))))
985 (if (not aborn-p)
986 header
987 (message "\e$B$"$\!<$s\e(B!!!")
988 (navi2ch-net-save-aborn-file file)
989 (navi2ch-net-add-state
990 'aborn
991 (navi2ch-net-update-file url file)))))
992
993 (defun navi2ch-net-save-aborn-file (file)
994 (when (and navi2ch-net-save-old-file-when-aborn
995 (or (not (eq navi2ch-net-save-old-file-when-aborn
996 'ask))
997 (y-or-n-p "\e$B$"$\!<$s\e(B!!! Backup old file? ")))
998 (copy-file file (read-file-name "file name: "))))
999
1000 ;; <http://www.ietf.org/rfc/rfc2396.txt>
1001 ;; 2.3. Unreserved Characters
1002 ;; unreserved = alphanum | mark
1003 ;; mark = "-" | "_" | "." | "!" | "~" | "*" | "'" | "(" | ")"
1004
1005 ;; from Emacs/W3
1006 (defconst navi2ch-net-url-unreserved-chars
1007 '(
1008 ?a ?b ?c ?d ?e ?f ?g ?h ?i ?j ?k ?l ?m ?n ?o ?p ?q ?r ?s ?t ?u ?v ?w ?x ?y ?z
1009 ?A ?B ?C ?D ?E ?F ?G ?H ?I ?J ?K ?L ?M ?N ?O ?P ?Q ?R ?S ?T ?U ?V ?W ?X ?Y ?Z
1010 ?0 ?1 ?2 ?3 ?4 ?5 ?6 ?7 ?8 ?9
1011 ?- ?_ ?. ?! ?~ ?* ?' ?\( ?\))
1012 "A list of characters that are _NOT_ reserve in the URL spec.
1013 This is taken from RFC 2396.")
1014
1015 ;; from Emacs/W3
1016 (defun navi2ch-net-url-hexify-string (str &optional coding-system)
1017 "Escape characters in a string."
1018 (mapconcat (lambda (char)
1019 (if (memq char navi2ch-net-url-unreserved-chars)
1020 (char-to-string char)
1021 (format "%%%02X" char)))
1022 (encode-coding-string str (or coding-system navi2ch-coding-system)) ""))
1023
1024 ;; convert unencodable char to Nemric Character Reference and hexify
1025 (defun navi2ch-net-url-ncrify-string (str &optional coding-system)
1026 "Convert unencodable char into nemric character reference and escape reserved characters"
1027 (letrec ((rewrite-fun
1028 (lambda (str start end coding-system result)
1029 (let ((pos (unencodable-char-position start end coding-system nil str)))
1030 (cond (pos ;; split the str into three parts
1031 ;; 1'st is encodable
1032 (when (> pos start)
1033 (nconc result (list (navi2ch-net-url-hexify-string
1034 (substring str start pos) coding-system))))
1035 ; 2'nd part is unencodaple, convert it into Nemric Character Reference and hexify
1036 (nconc result (list (format "%%26%%23%d%%3b" (aref str pos))))
1037 ; 3'rd part is encodable
1038 (when (< pos end)
1039 (funcall rewrite-fun str (1+ pos) end coding-system result)))
1040 ((< start end) ; nexify rest
1041 (nconc result (list (navi2ch-net-url-hexify-string
1042 (substring str start) coding-system)))))
1043 result))))
1044 (apply #'concat
1045 (cdr (funcall rewrite-fun
1046 str 0 (length str) (or coding-system navi2ch-coding-system) (list nil))))))
1047
1048 (defun navi2ch-net-get-param-string (param-alist &optional coding-system)
1049 (mapconcat (lambda (x)
1050 (concat (navi2ch-net-url-hexify-string (car x) coding-system) "="
1051 (navi2ch-net-url-ncrify-string (cdr x) coding-system)))
1052 param-alist "&"))
1053
1054 (defun navi2ch-net-send-message-success-p (proc coding-system)
1055 (when proc
1056 (let ((str (decode-coding-string (navi2ch-net-get-content proc)
1057 coding-system)))
1058 (cond ((or (string-match "\e$B=q$-$3$_$^$7$?!#\e(B" str)
1059 (string-match "\e$B=q$-$3$_$,=*$o$j$^$7$?!#\e(B" str))
1060 t)
1061 ((or (string-match "<b>\e$B%/%C%-!<$,$J$$$+4|8B@Z$l$G$9!*\e(B</b>" str)
1062 (string-match "<b>\e$B=q$-$3$_!u%/%C%-!<3NG'\e(B</b>" str))
1063 'retry)
1064 (t
1065 nil)))))
1066
1067 (defun navi2ch-net-send-message-error-string (proc coding-system)
1068 (when proc
1069 (let ((str (decode-coding-string (navi2ch-net-get-content proc)
1070 coding-system)))
1071 (cond ((string-match "\e$B#E#R#R#O#R!'\e(B\\([^<]+\\)" str)
1072 (match-string 1 str))
1073 ;; Samba24 http://age.s22.xrea.com/talk2ch/new.txt
1074 ((string-match "\e$B#E#R#R#O#R\e(B - \\([^<\n]+\\)" str)
1075 (match-string 1 str))
1076 ((string-match "\\(\e$B%m%0%$%s%(%i!<\e(B[^<]*\\)<br>" str)
1077 (match-string 1 str))
1078 ((string-match "<b>\\([^<]+\\)" str)
1079 (match-string 1 str))
1080 ((string-match "\\([^<>\n]+\\)<br>\\([^<>]+\\)<hr>" str)
1081 (concat (match-string 1 str) (match-string 2 str)))))))
1082
1083 ;; Cookie \e$B$O$3$s$J46$8$N\e(B alist \e$B$KF~$l$F$*$/!#\e(B
1084 ;; ((domain1 (/path1 ("name1" "value1" ...)
1085 ;; ("name2" "value2" ...) ...)
1086 ;; (/path2 ...) ...)
1087 ;; (domain2 ...) ...)
1088
1089 (defvar navi2ch-net-cookies nil)
1090
1091 (defun navi2ch-net-cookie-domains (host)
1092 (let* ((host (downcase host))
1093 (domain-list (list (intern host)
1094 (intern (concat "." host)))))
1095 (while (string-match "\\.\\(.*\\..*\\)\\'" host)
1096 (push (intern (match-string 0 host)) domain-list)
1097 (let ((h (match-string 1 host)))
1098 (push (intern h) domain-list)
1099 (setq host h)))
1100 domain-list))
1101
1102 (defun navi2ch-net-cookie-paths (file)
1103 (let (path-list)
1104 (while (string-match "\\`\\(.*\\)/" file)
1105 (push (intern (match-string 0 file)) path-list)
1106 (let ((f (match-string 1 file)))
1107 (unless (string= f "")
1108 (push (intern f) path-list))
1109 (setq file f)))
1110 path-list))
1111
1112 (defun navi2ch-net-store-cookie (cookie domain path)
1113 (let ((domain (if (stringp domain) (intern (downcase domain)) domain))
1114 (path (if (stringp path) (intern path) path)))
1115 (let ((path-alist (assq domain navi2ch-net-cookies)))
1116 (unless path-alist
1117 (setq path-alist (list domain))
1118 (push path-alist navi2ch-net-cookies))
1119 (let ((cookie-list (assq path (cdr path-alist))))
1120 (if cookie-list
1121 (let ((elt (assoc (car cookie) (cdr cookie-list))))
1122 (if elt
1123 (setcdr elt (cdr cookie))
1124 (setcdr cookie-list (cons cookie (cdr cookie-list)))))
1125 (setq cookie-list (list path cookie))
1126 (setcdr path-alist (cons cookie-list (cdr path-alist))))))))
1127
1128 (defun navi2ch-net-match-cookies (url)
1129 (let* ((alist (navi2ch-net-split-url url))
1130 (domain-list (navi2ch-net-cookie-domains (cdr (assq 'host alist))))
1131 (path-list (navi2ch-net-cookie-paths (cdr (assq 'file alist)))))
1132 (cl-flet ((mcn (function list) (apply #'nconc (mapcar function list))))
1133 (mcn (lambda (domain)
1134 (mcn (lambda (path)
1135 (navi2ch-net-expire-cookies
1136 (cdr (assq path
1137 (cdr (assq domain
1138 navi2ch-net-cookies))))))
1139 path-list))
1140 domain-list))))
1141
1142 (defvar navi2ch-net-cookie-file "cookie.info")
1143
1144 (defun navi2ch-net-save-cookies ()
1145 (let ((now (current-time)))
1146 (cl-flet ((strip (f l) (let ((tmp (delq nil (mapcar f (cdr l)))))
1147 (and tmp (cons (car l) tmp)))))
1148 (navi2ch-save-info
1149 navi2ch-net-cookie-file
1150 (delq nil
1151 (mapcar (lambda (path-alist)
1152 (strip (lambda (cookie-list)
1153 (strip (lambda (cookie)
1154 (and (cddr cookie)
1155 (navi2ch-compare-times
1156 (cddr cookie) now)
1157 cookie))
1158 cookie-list))
1159 path-alist))
1160 navi2ch-net-cookies))))))
1161
1162 (defun navi2ch-net-load-cookies ()
1163 (setq navi2ch-net-cookies
1164 (navi2ch-load-info navi2ch-net-cookie-file)))
1165
1166 (add-hook 'navi2ch-save-status-hook 'navi2ch-net-save-cookies)
1167 (add-hook 'navi2ch-load-status-hook 'navi2ch-net-load-cookies)
1168
1169 (defun navi2ch-net-update-cookies (url proc coding-system)
1170 (let* ((case-fold-search t)
1171 (alist (navi2ch-net-split-url url))
1172 (host (cdr (assq 'host alist)))
1173 (file (cdr (assq 'file alist)))
1174 (domain-list (navi2ch-net-cookie-domains host))
1175 (path-list (navi2ch-net-cookie-paths file)))
1176 (dolist (pair (navi2ch-net-get-header proc) navi2ch-net-cookies)
1177 (when (eq (car pair) 'set-cookie)
1178 (let* ((str (cdr pair))
1179 (date (when (string-match "expires=\\([^;]+\\)" str)
1180 (navi2ch-http-date-decode (match-string 1 str))))
1181 (domain (intern (downcase (if (string-match "domain=\\([^;]+\\)"
1182 str)
1183 (match-string 1 str)
1184 host))))
1185 (path (intern (if (string-match "path=\\([^;]+\\)" str)
1186 (match-string 1 str)
1187 (if (and (string-match "\\(.*\\)/" file)
1188 (> (length (match-string 1 file)) 0))
1189 (match-string 1 file)
1190 "/")))))
1191 (when (and (memq domain domain-list)
1192 (memq path path-list)
1193 (string-match "^\\([^=]+\\)=\\([^;]*\\)" str))
1194 (let ((name (match-string 1 str))
1195 (value (match-string 2 str)))
1196 (setq value
1197 (decode-coding-string
1198 (navi2ch-replace-string "%[0-9A-Za-z][0-9A-Za-z]"
1199 (lambda (s)
1200 (string (string-to-number
1201 (substring s 1) 16)))
1202 value t t t)
1203 coding-system))
1204 (navi2ch-net-store-cookie (cons name
1205 (cons value date))
1206 domain path))))))))
1207
1208 (defun navi2ch-net-expire-cookies (cookie-list)
1209 "COOKIE-LIST \e$B$+$i4|8B@Z$l$N%/%C%-!<$r=|$$$?%j%9%H$rJV$9!#\e(B"
1210 (let ((now (current-time)))
1211 (delq nil
1212 (mapcar (lambda (cookie)
1213 (when (or (null (cddr cookie))
1214 (navi2ch-compare-times (cddr cookie) now))
1215 cookie))
1216 cookie-list))))
1217
1218 (defun navi2ch-net-cookie-string (cookies coding-system)
1219 "HTTP \e$B$N\e(B Cookie \e$B%X%C%@$H$7$FEO$9J8;zNs$rJV$9!#\e(B"
1220 (mapconcat (lambda (elt)
1221 (concat (navi2ch-net-url-hexify-string (car elt)
1222 coding-system)
1223 "="
1224 (navi2ch-net-url-ncrify-string (cadr elt)
1225 coding-system)))
1226 cookies "; "))
1227
1228 (defun navi2ch-net-download-logo (board)
1229 (let ((coding-system-for-read 'binary)
1230 (coding-system-for-write 'binary)
1231 (setting-file (navi2ch-board-get-file-name
1232 board navi2ch-net-setting-file-name))
1233 (setting-url (navi2ch-board-get-url
1234 board navi2ch-net-setting-file-name))
1235 content src)
1236 (when (and (navi2ch-net-update-file setting-url setting-file 'file)
1237 (file-exists-p setting-file))
1238 (setq content (with-temp-buffer
1239 (insert-file-contents setting-file)
1240 (buffer-string))))
1241 (when (and content
1242 (string-match
1243 "BBS_\\(TITLE_PICTURE\\|FIGUREHEAD\\)=\\(.+\\)" content))
1244 (setq src (match-string 2 content))
1245 (let (url file)
1246 (setq url (if (string-match "https?://" src)
1247 src
1248 (navi2ch-board-get-url board src)))
1249 (string-match "/\\([^/]+\\)$" url)
1250 (setq file (match-string 1 url))
1251 (when file
1252 (setq file (navi2ch-board-get-file-name board file))
1253 (when (navi2ch-net-update-file url file 'file nil t)
1254 file))))))
1255
1256 ;(run-hooks 'navi2ch-net-load-hook)
1257 (provide 'navi2ch-net)
1258 ;;; navi2ch-net.el ends here