Commit e11b5e49 authored by Eric Timmons's avatar Eric Timmons
Browse files

Rework HTTP interface to better mirror drakma's

parent 693c8315
......@@ -15,12 +15,54 @@
(:export #:ensure-file-fetched
(in-package #:clpm/http-client)
(defun day-name (day-of-week)
(ecase day-of-week
(defun month-name (month)
(ecase month
(1 "Jan")
(2 "Feb")
(3 "Mar")
(4 "Apr")
(5 "May")
(6 "Jun")
(7 "Jul")
(8 "Aug")
(9 "Sep")
(10 "Oct")
(11 "Nov")
(12 "Dec")))
(defun universal-time-to-http-date (universal-time)
"Given a universal-time return the same date as a string suitable for HTTP
(multiple-value-bind (second minute hour date month year day-of-week)
;; Times in HTTP Headers are always GMT
(decode-universal-time universal-time 0)
(format nil "~A, ~2,'0D ~A ~A ~2,'0D:~2,'0D:~2,'0D GMT"
(day-name day-of-week) date (month-name month) year hour minute second)))
(defgeneric canonicalize-header-value (header-value)
(:documentation "Given a ~header-value~ from a config file, return a string
that contains the value of the header that should be sent as part of the HTTP
......@@ -70,36 +112,55 @@ the request."
(let ((url (puri:parse-uri url)))
(log:debug "Fetching ~A" url)
(flexi-streams:with-output-to-sequence (s :element-type '(unsigned-byte 8))
(fetch-url-to-stream url s
:headers (get-additional-headers-for-hostname (puri:uri-host url)
(puri:uri-scheme url)))))))
(http-request url :additional-headers (get-additional-headers-for-hostname
(puri:uri-host url)
(puri:uri-scheme url))))))
(defun ensure-file-fetched (pathname url &key refresh-time)
(defun ensure-file-fetched (pathname url &key force)
"Given a pathname, make sure it exists. If it does not exist, fetch it from
URL (string or puri URI).
If refresh-time is non-NIL, fetches the file if it already exists and it is
older than refresh-time in seconds."
If force is non-NIL, fetches the file without sending an If-Modified-Since
Returns T if the contents of PATHNAME were modified, NIL otherwise."
(setf url (puri:parse-uri url))
(log:debug "Fetching ~A" url)
(when (or (not (probe-file pathname))
(and refresh-time
(> (- (get-universal-time) (file-write-date pathname))
;; Base the tmp pathname off the pathname pathname to try and ensure that
;; they are on the same filesystem.
(let ((tmp-pathname (uiop:tmpize-pathname pathname)))
(ensure-directories-exist pathname)
(with-open-file (file-stream tmp-pathname :direction :output
:if-exists :supersede
:element-type '(unsigned-byte 8))
(fetch-url-to-stream url file-stream
:headers (get-additional-headers-for-hostname
(puri:uri-host url)
(puri:uri-scheme url))))
(rename-file tmp-pathname pathname))
(when (probe-file tmp-pathname)
(delete-file tmp-pathname))))))
;; Base the tmp pathname off the pathname pathname to try and ensure that
;; they are on the same filesystem.
(let ((tmp-pathname (uiop:tmpize-pathname pathname))
(additional-headers nil))
(when (and (not force)
(probe-file pathname))
(push (cons :if-modified-since (universal-time-to-http-date (file-write-date pathname)))
(ensure-directories-exist pathname)
(multiple-value-bind (http-stream status-code)
(http-request url
:want-stream t
:additional-headers (append
(puri:uri-host url)
(puri:uri-scheme url))
(log:debug "Status code: ~S" status-code)
(case status-code
(with-open-file (file-stream tmp-pathname :direction :output
:if-exists :supersede
:element-type '(unsigned-byte 8))
;; Save the data to the file.
(copy-stream http-stream file-stream
:element-type '(unsigned-byte 8)
:buffer-size 8192))
(rename-file tmp-pathname pathname)
;; No changes
(error "Can't handle HTTP code ~A" status-code)))))
(when (probe-file tmp-pathname)
(delete-file tmp-pathname)))))
......@@ -8,6 +8,7 @@
(:import-from #:fast-http)
(:export #:curl-client))
(in-package #:clpm/http-client/curl)
......@@ -18,7 +19,13 @@
:initform "curl"
:accessor curl-path
"The path to the curl program."))
"The path to the curl program.")
:initarg :buffer-size
:initform 8192
:accessor curl-buffer-size
"How many bytes to read at once from curl's output."))
"Describes an HTTP client that uses a curl executable.")
......@@ -46,21 +53,78 @@ its version can be successfully queried."
(check-type value string)
(format nil "~A: ~A" name value)))
(defmethod %fetch-url-to-stream ((client curl-client) url out-stream
&key headers)
(flet ((write-headers-to-stream (stream)
(defun make-curl-thread (client proc response additional-headers lock cv stream-callback)
"Given a process info object representing a curl process, an http response
object, an alist of additional headers, a lock, a condition variable, and a
callback, return a lambda function that manages the curl process.
When invoked, the lambda first prints all additional headers to proc's stdin
and closes it. Then, it begins reading proc's stdout, feeding it into an HTTP
parser for the provided response object. After all the headers are processed,
the callback is called with a single argument, NIL if there is no body to the
response or a stream that can be read to get the response. After that, the
condition variable is notified."
(lambda ()
(let* ((out-stream (uiop:process-info-output proc))
(in-stream (uiop:process-info-input proc))
(body-started nil)
(parser (fast-http:make-parser
(lambda (data start end)
;; There is a body to the response. Unfrotunately
;; we've read part of it, so we can't just hand the
;; current stream to the callback... Instead, we
;; make a concatenated stream that starts with the
;; chunk we've read and then continues with the
;; process' stdout.
(funcall stream-callback
(flexi-streams:make-in-memory-input-stream data :start start :end end)
(setf body-started t)
(bt:with-lock-held (lock)
(bt:condition-notify cv))))))
;; Write all additional headers to curl's stdin
:for (key . value) :in headers
:for name := (string-capitalize (symbol-name key))
:do (format stream "~A: ~A~%" name value))
(unless headers
:for (key . value) :in additional-headers
:for name := (string-downcase (symbol-name key))
:do (format in-stream "~A: ~A~%" name value))
(unless additional-headers
;; Curl on Windows seems to get rather upset if the stream is just
;; closed without anything being written to it, so just send a
;; blank line to make it happy.
(format stream "~%"))
(close stream)))
(multiple-value-bind (out err exit-code)
(uiop:run-program `(,(curl-path client)
(format in-stream "~%"))
;; Close the stream to let curl know we're finished giving it headers.
(close in-stream)
;; Now start pumping the output.
:with buffer := (make-array (curl-buffer-size client) :element-type '(unsigned-byte 8))
:for pos := (read-sequence buffer out-stream)
:unless (zerop pos)
:do (funcall parser buffer :start 0 :end pos)
:while (and (not (zerop pos))
(not body-started)))
(unless body-started
;; If we get here, there's no body.
(funcall stream-callback nil))
(bt:with-lock-held (lock)
(bt:condition-notify cv)))
(uiop:wait-process proc))))
(defmethod %http-request ((client curl-client) url
&key additional-headers
(let* ((lock (bt:make-lock))
(cv (bt:make-condition-variable))
(stream nil)
(response (fast-http:make-http-response))
(thread-lambda (make-curl-thread
`(,(curl-path client)
;; Add the requested headers. Pass them in on stdin
;; to prevent them from being visible in the process
;; list (in case any of them are authentication
......@@ -68,25 +132,43 @@ its version can be successfully queried."
"-H" "@-"
;; Follow any redirects
;; Include headers in the output
;; Set the user agent
,(format nil "CLPM/~A Curl"
;; Don't read any user config files
;; Bail out on non-200s
;; fast-http wasn't designed for HTTP 2, so force 1.1.
;; Be quiet, but still show the error (if one occurs)
,(uri-to-string url))
:input #'write-headers-to-stream
:output `(,out-stream :element-type (unsigned-byte 8))
:error-output '(:string :stripped t)
:ignore-error-status t)
(declare (ignore out))
(unless (zerop exit-code)
(error 'http-simple-fetch-error
:format-control "Exit code ~S from curl.~%Stderr:~%~%~A"
:format-arguments (list exit-code err)))
:output :stream
:error-output :stream
:input :stream
:element-type '(unsigned-byte 8))
(lambda (s)
(setf stream s)))))
(bt:make-thread thread-lambda)
(bt:with-lock-held (lock)
(unless stream
(bt:condition-wait cv lock)))
(if want-stream
(if stream
(flexi-streams:make-in-memory-input-stream (make-array 0 :element-type '(unsigned-byte 8))))
(if stream
(flexi-streams:with-output-to-sequence (s :element-type '(unsigned-byte 8))
(uiop:copy-stream-to-stream stream s
:element-type '(unsigned-byte 8)
:buffer-size 8192))
(fast-http:http-status response))))
......@@ -9,12 +9,12 @@
(:export #:fetch-url-to-stream
(:export #:http-client
......@@ -105,15 +105,14 @@ resource over HTTP."))
(define-condition http-simple-fetch-error (http-fetch-error simple-error)
(defgeneric %fetch-url-to-stream (client url stream &key headers)
(:documentation "Using ~client~, GET the resource located at ~url~ and send it
to ~stream~. ~headers~ is an alist of header name (keyword)/value pairs to send
with the request."))
(defgeneric %http-request (client url &key additional-headers want-stream))
;; * GETing URLs
(defun fetch-url-to-stream (url stream &key headers)
"Given a ~url~, GET it and put its contents into ~stream~. ~headers~ is an
alist of header name (keyword)/value pairs to send with the request."
(%fetch-url-to-stream (get-preferred-http-client url) url stream :headers headers))
(defun http-request (url
&key additional-headers
(%http-request (get-preferred-http-client url) url
:additional-headers additional-headers
:want-stream want-stream))
......@@ -13,6 +13,8 @@
(:shadowing-import-from #:drakma
(:export #:drakma-client))
(in-package #:clpm/http-client/drakma)
......@@ -38,15 +40,13 @@
(or (not (featurep :drakma-no-ssl))
(eql (uri-scheme url) :http)))
(defmethod %fetch-url-to-stream ((client drakma-client) url out-stream
&key headers)
(multiple-value-bind (http-stream status-code)
(http-request url :want-stream t
:verify #+:drakma-no-ssl nil #-:drakma-no-ssl :required
:additional-headers headers
:user-agent (format nil "CLPM/~A Drakma/~A"
(assert (= 200 status-code))
(copy-stream http-stream out-stream :element-type '(unsigned-byte 8) :buffer-size 8192)
(close http-stream)))
(defmethod %http-request ((client drakma-client) url
&key additional-headers
(http-request url :additional-headers additional-headers
:want-stream want-stream
:force-binary t
:verify #+:drakma-no-ssl nil #-:drakma-no-ssl :required
:user-agent (format nil "CLPM/~A Drakma/~A"
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