Commit 098d1250 authored by Michael Raskin's avatar Michael Raskin
Browse files

Syncing from Monotone at 20210330-024647. Last commit message was Allow to...

Syncing from Monotone at 20210330-024647. Last commit message was Allow to send more headers by default
parent fc4de43e
......@@ -8,6 +8,7 @@
:initform (make-instance 'drakma:cookie-jar))
(pending-redirect :accessor pending-redirect :initform nil)
(current-url :accessor current-url :initform nil)
(current-decoded-url :accessor current-decoded-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)
......@@ -35,6 +36,10 @@
:initform (lambda (&key url) (declare (ignorable url))
*default-user-agent*)
:initarg :user-agent)
(headers-policy :accessor headers-policy
:initform (lambda (&key)
`(("Cache-Control" . "none")))
:initarg :headers-policy)
(url-preprocessing-policy :accessor url-preprocessing-policy
:initform (lambda (&key url) url)
:initarg :url-preprocessing-policy)
......@@ -111,9 +116,9 @@
(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 (urldecode url :utf-8)))
(setf url (cl-ppcre:regex-replace "#.*" url ""))
(setf url (urlencode-unsafe url :utf-8))
(setf url (funcall (url-encoder-policy fetcher) url :utf-8))
(multiple-value-bind
(content
status-code server-headers
......@@ -131,6 +136,10 @@
:additional-headers
(append
additional-headers
(funcall (or (headers-policy fetcher) (constantly nil))
:fetcher fetcher :new url :old (current-url fetcher)
:url url
:allow-other-keys t)
(unless (assoc "Referer" additional-headers :test 'equalp)
`(("Referer" . ,(funcall (referer-policy fetcher)
:old (current-url fetcher)
......@@ -140,6 +149,7 @@
(when (url-encoder-policy fetcher)
(list :url-encoder (url-encoder-policy fetcher)))
(list
:preserve-uri t
:cookie-jar (cookie-jar fetcher)
:user-agent (funcall (user-agent fetcher)
:allow-other-keys t
......@@ -162,7 +172,8 @@
(current-content-bytes fetcher) content
(current-status-code fetcher) status-code
(current-status-line fetcher) status-line
(current-url fetcher) reply-url
(current-url fetcher) (urlencode-unsafe (puri:render-uri reply-url nil) :latin-1)
(current-decoded-url fetcher) (maybe-urldecode (current-url fetcher) (list :utf-8 :latin-1))
(current-intended-url fetcher) url
(current-headers fetcher) server-headers
)
......
......@@ -2,7 +2,7 @@
cd "$(dirname "$0")"
NO_RLWRAP=1 ./nix-load-lisp.sh --eval '
NO_RLWRAP=1 ./nix-load-lisp.sh --non-interactive --eval '
(progn
(setf cffi:*foreign-library-directories*
(cffi::explode-path-environment-variable
......
......@@ -155,13 +155,28 @@
(urls (loop for a in attributes
for v := (html5-parser:element-attribute element a)
when v collect (real-url v)))
(urls (loop for u in urls
for du := (ignore-errors (urldecode u :utf-8))
collect u
when (and du (not (equal u du)))
collect du))
(seen-urls (make-hash-table :test 'equal))
(uniq-urls nil)
(text (call-next-method)))
(if urls (format nil "{ ~a }~{→[ ~a ]~}" text urls) text)))
(loop with stack := urls
while stack
for u := (pop stack)
when u
unless (gethash u seen-urls)
do
(progn
(setf (gethash u seen-urls) t)
(push u uniq-urls)
(push (ignore-errors (urldecode u :utf-8)) stack)
(loop with query-params := (second (cl-ppcre:split "[?]" u))
with params := (cl-ppcre:split "[&]" u)
for p in params
for v := (second (cl-ppcre:split "[=]" p))
for dv := (ignore-errors (urldecode v :utf-8))
when dv
when (cl-ppcre:scan "^https?://" dv)
do (push dv stack))))
(if urls (format nil "{ ~a }~{→[ ~a ]~}" text (reverse uniq-urls)) text)))
(defmethod html-element-to-text-dispatch
((protocol show-urls-mixin) (type (eql :element)) (tag (eql :meta)) element)
......
......@@ -7,6 +7,7 @@
(urldecode object nil)
:encoding
(gethash (string encoding) *babel-encodings* :utf-8)))
(:method ((object null) encoding) nil)
(:method ((object string) encoding)
(urldecode
(babel:string-to-octets
......@@ -36,6 +37,12 @@
(defmethod urldecode ((object puri:uri) encoding)
(urldecode (format nil "~a" object) encoding))
(defmethod maybe-urldecode (object encodings)
(loop for e in encodings
for d := (ignore-errors (urldecode object e))
when d return d
finally (return object)))
(defparameter *base16-digits*
(map 'vector 'char-code "0123456789ABCDEF"))
......
......@@ -20,8 +20,8 @@
(format out "~a~%" (current-content f)))
(with-open-file (out (format nil "~a/~a.html.txt" target basename)
:direction :output)
(format out "→[ ~a ]~%→[ ~a ]~%~a~%~a~%~{~%(~{~s~%~})~%~%~}~{~S~%#.~S~%~}~%~a~%"
url (current-url f)
(format out "→[ ~a ]~%→[ ~a ]~%→[ ~a ]~%~a~%~a~%~{~%(~{~s~%~})~%~%~}~{~S~%#.~S~%~}~%~a~%"
url (current-url f) (current-decoded-url f)
(or
(ignore-errors
(html-element-to-text
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment