basic-retrieve.lisp 8.45 KB
Newer Older
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
(in-package :thoughtful-theridion)

(defvar *default-user-agent*
  "Thoughtful-Theridion/0.0 (magic matching strings: Gecko Firefox)")

(defclass http-fetcher ()
  ((cookie-jar :accessor cookie-jar
               :initform (make-instance 'drakma:cookie-jar))
   (pending-redirect :accessor pending-redirect :initform nil)
   (current-url :accessor current-url :initform nil)
   (current-intended-url :accessor current-intended-url :initform nil)
   (current-status-code :accessor current-status-code :initform nil)
   (current-status-line :accessor current-status-line :initform nil)
   (current-headers :accessor current-headers :initform nil)
   (current-content :accessor current-content :initform nil)
   (current-content-bytes :accessor current-content-bytes :initform nil)
   (parsed-content :accessor parsed-content :initform nil)
   (parser-warnings :accessor parser-warnings :initform nil)
   (referer-policy :accessor referer-policy
                   :initform (lambda (&key old new)
                               (declare (ignorable old))
                               new)
                   :initarg :referer-policy)
   (redirect-policy :accessor redirect-policy
                    :initform
                    (lambda (&key code header old new)
                      (declare (ignorable code header old new))
                      nil)
                    :initarg :redirect-policy)
   (basic-auth-policy :accessor basic-auth-policy
                      :initform (lambda (&key url)
                                  (declare (ignorable url)) nil)
                      :initarg :basic-auth-policy)
   (user-agent-policy :accessor user-agent
               :initform (lambda (&key url) (declare (ignorable url))
                           *default-user-agent*)
               :initarg :user-agent)
   (decode-bytes-policy :accessor decode-bytes-policy
                        :initform (lambda (&key content content-type
                                                url headers)
                                    (declare (ignorable url headers))
                                    (let* ((decompressed (ignore-errors
                                                           (chipz:decompress
                                                             nil 'chipz:gzip content))))
                                      (decode-guessed-encoding
                                        :content (or decompressed content)
                                        :content-type content-type)))
                        :initarg :decode-bytes-policy)
   (parsing-policy
     :accessor parsing-policy
     :initform (lambda (&key content-type content url
                             headers code)
                 (declare (ignorable url headers code))
                 (cond ((cl-ppcre:scan "^text/html(;|$)" content-type)
                        (ignore-errors (html5-parser:parse-html5 content)))
56
57
                       ((cl-ppcre:scan "^text/xhtml(;|$)" content-type)
                        (ignore-errors (html5-parser:parse-html5 content)))
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
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
                       ((cl-ppcre:scan "^(text|application)/(x-)?json(;|$)" 
                                       content-type)
                        (ignore-errors (cl-json:decode-json-from-string
                                         content)))
                       (t (let* ((document (html5-parser:make-document))
                                 (pre (html5-parser:make-element document "pre" nil))
                                 (text (html5-parser:make-text-node document content)))
                            (html5-parser:node-append-child pre text)
                            (html5-parser:node-append-child document pre)
                            document))))
     :initarg :parsing-policy)
   (proxy :accessor proxy :initform drakma:*default-http-proxy*
          :initarg :proxy)
   ))

(defgeneric parse-obtained-content (fetcher))

(defmethod parse-obtained-content ((fetcher http-fetcher))
  (setf (current-content fetcher)
        (funcall (decode-bytes-policy fetcher)
                 :allow-other-keys t
                 :url (current-url fetcher)
                 :content-type (cdr (assoc :content-type (current-headers fetcher)))
                 :headers (current-headers fetcher)
                 :content (current-content-bytes fetcher)))
  (if (current-content fetcher)
    (multiple-value-bind (parsed warnings)
      (funcall (parsing-policy fetcher)
               :allow-other-keys t
               :content (current-content fetcher)
               :url (current-url fetcher) :code (current-status-code fetcher)
               :content-type (cdr (assoc :content-type (current-headers fetcher)))
               :headers (current-headers fetcher))
      (setf (parsed-content fetcher) parsed
            (parser-warnings fetcher) warnings))
    (setf (parsed-content fetcher) nil
          (parser-warnings fetcher) "Content is binary")))

(defgeneric navigate (fetcher url &rest drakma-args))

(defmethod navigate ((fetcher http-fetcher) (url string) &rest drakma-args)
  (when (and (not (cl-ppcre:scan "^[a-z]+:" (string-downcase url)))
             (cl-ppcre:scan "^[a-z]+[%]3a" (string-downcase url)))
    (setf url (urldecode url :latin-1)))
  (setf url (cl-ppcre:regex-replace "#.*" url ""))
  (setf url (urlencode-unsafe url :utf-8))
  (multiple-value-bind
    (content
      status-code server-headers
      reply-url
      reply-stream reply-stream-needs-closing-p
      status-line)
    (handler-case
      (apply 'drakma:http-request url
           (append
             (let* ((additional-headers
                      (getf drakma-args :additional-headers)))
               (list
               :additional-headers
               (append
                 additional-headers
                 (unless (assoc "Referer" additional-headers :test 'equalp)
                   `(("Referer" . ,(funcall (referer-policy fetcher)
                                            :old (current-url fetcher)
                                            :new url
                                            :allow-other-keys t)))))))
             drakma-args
             (list
               :cookie-jar (cookie-jar fetcher)
               :user-agent (funcall (user-agent fetcher)
                                    :allow-other-keys t
                                    :url url)
               :proxy (proxy fetcher)
               :redirect nil
               :force-binary t
               )))
      (error (e)
             (values
               (babel:string-to-octets (format nil "~a" e) :encoding :utf-8)
               503
               `((:content-type . "text/plain; charset=utf-8"))
               nil nil nil
               "Fetching failed")))
    (when reply-stream-needs-closing-p (close reply-stream))
    (when (getf drakma-args :cookie-jar)
      (setf (cookie-jar fetcher) (getf drakma-args :cookie-jar)))
    (setf
      (current-content-bytes fetcher) content
      (current-status-code fetcher) status-code
      (current-status-line fetcher) status-line
      (current-url fetcher) reply-url
      (current-intended-url fetcher) url
      (current-headers fetcher) server-headers
      )
    (parse-obtained-content fetcher)
    (or
      (and (= status-code 401)
           (null (getf drakma-args :basic-authorization))
           (let* ((auth-data (funcall (basic-auth-policy fetcher)
                                      :url url
                                      :allow-other-keys t)))
             (when auth-data
               (apply 'navigate fetcher url
                      :basic-authorization auth-data
                      drakma-args))))
      (and
        (or (<= 300 status-code 399)
            (assoc :location server-headers)
            (assoc :refresh server-headers))
        (let* ((location (cdr (assoc :location server-headers)))
               (refresh (cl-ppcre:regex-replace
                          "^ *[0-9]+ *; *"
                          (cdr (assoc :refresh server-headers)) ""))
               (policy-url
                 (funcall (redirect-policy fetcher)
                          :status-code status-code
                          :header (cond (location :location)
                                (refresh :refresh)
                                (t nil))
                          :old url
                          :new (or location refresh reply-url url)
                          :content content
                          :allow-other-keys t)))
          (when policy-url (apply 'navigate fetcher policy-url drakma-args))))
      (current-content fetcher))))