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))))