branch: externals/llm
commit 1f3b018dcb9870667ed92c5d9c14190701cb3dfb
Merge: 9c33eb4a91 a9cd296cd8
Author: Andrew Hyatt <ahy...@gmail.com>
Commit: GitHub <nore...@github.com>
Merge pull request #26 from r0man/plz
Add Plz
---
llm-request-plz.el | 146 +++++++++
plz-event-source.el | 458 ++++++++++++++++++++++++++
plz-media-type.el | 341 ++++++++++++++++++++
plz.el | 912 ++++++++++++++++++++++++++++++++++++++++++++++++++++
4 files changed, 1857 insertions(+)
diff --git a/llm-request-plz.el b/llm-request-plz.el
new file mode 100644
index 0000000000..d103f10448
--- /dev/null
+++ b/llm-request-plz.el
@@ -0,0 +1,146 @@
+;;; llm-request-plz.el --- Curl request handling code -*- lexical-binding: t;
package-lint-main-file: "llm.el"; -*-
+
+;; Copyright (c) 2023 Free Software Foundation, Inc.
+
+;; This program is free software; you can redistribute it and/or
+;; modify it under the terms of the GNU General Public License as
+;; published by the Free Software Foundation; either version 3 of the
+;; License, or (at your option) any later version.
+;;
+;; This program is distributed in the hope that it will be useful, but
+;; WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
+;; General Public License for more details.
+;;
+;; You should have received a copy of the GNU General Public License
+;; along with GNU Emacs. If not, see <http://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;; This file provides basic functions for providers who need to request data.
It
+;; assumes the server is using json.
+
+;;; Code:
+(require 'cl-macs)
+(require 'json)
+(require 'plz-event-source)
+(require 'plz-media-type)
+(require 'rx)
+(require 'url-http)
+
+(defcustom llm-request-plz-timeout 60
+ "The number of seconds to wait for a response from a HTTP server.
+
+Request timings are depending on the request. Requests that need
+more output may take more time, and there is other processing
+besides just token generation that can take a while. Sometimes
+the LLM can get stuck, and you don't want it to take too long.
+This should be balanced to be good enough for hard requests but
+not very long so that we can end stuck requests."
+ :type 'integer
+ :group 'llm)
+
+(cl-defun llm-request-plz-sync-raw-output (url &key headers data timeout)
+ "Make a request to URL. The raw text response will be returned.
+
+HEADERS will be added in the Authorization header, in addition to
+standard json header. This is optional.
+
+DATA will be jsonified and sent as the request body.
+This is required.
+
+TIMEOUT is the number of seconds to wait for a response."
+ (condition-case error
+ (plz-media-type-request
+ 'post url
+ :as `(media-types ,plz-media-types)
+ :body (when data
+ (encode-coding-string (json-encode data) 'utf-8))
+ :headers (append headers '(("Content-Type" . "application/json")))
+ :timeout (or timeout llm-request-plz-timeout))
+ (plz-error
+ (seq-let [error-sym message data] error
+ (cond
+ ((eq 'plz-http-error error-sym)
+ (let ((response (plz-error-response data)))
+ (error "LLM request failed with code %d: %s (additional
information: %s)"
+ (plz-response-status response)
+ (nth 2 (assq (plz-response-status response) url-http-codes))
+ (plz-response-body response))))
+ ((and (eq 'plz-curl-error error-sym)
+ (eq 28 (car (plz-error-curl-error data))))
+ (error "LLM request timed out"))
+ (t (signal error-sym (list message data))))))))
+
+(cl-defun llm-request-plz-sync (url &key headers data timeout)
+ "Make a request to URL. The parsed response will be returned.
+
+HEADERS will be added in the Authorization header, in addition to
+standard json header. This is optional.
+
+DATA will be jsonified and sent as the request body.
+This is required.
+
+TIMEOUT is the number of seconds to wait for a response."
+ (llm-request-plz-sync-raw-output url
+ :headers headers
+ :data data
+ :timeout timeout))
+
+(cl-defun llm-request-plz-async (url &key headers data on-success
on-success-raw on-error _on-partial event-stream-handlers timeout)
+ "Make a request to URL.
+Nothing will be returned.
+
+HEADERS will be added in the Authorization header, in addition to
+standard json header. This is optional.
+
+DATA will be jsonified and sent as the request body.
+This is required.
+
+ON-SUCCESS will be called with the response body as a json
+object. This is optional in the case that ON-SUCCESS-DATA is set,
+and required otherwise.
+
+ON-ERROR will be called with the error code and a response-body.
+This is required.
+
+ON-PARTIAL will be called with the potentially incomplete response
+body as a string. This is an optional argument.
+
+ON-SUCCESS-RAW, if set, will be called in the buffer with the
+response body, and expect the response content. This is an
+optional argument, and mostly useful for streaming. If not set,
+the buffer is turned into JSON and passed to ON-SUCCESS."
+ (plz-media-type-request
+ 'post url
+ :as `(media-types ,(cons (cons "text/event-stream"
+ (plz-media-type:text/event-stream
+ :events event-stream-handlers))
+ plz-media-types))
+ :body (when data
+ (encode-coding-string (json-encode data) 'utf-8))
+ :headers (append headers
+ '(("Accept-encoding" . "identity")
+ ("Content-Type" . "application/json")))
+ :then (lambda (response)
+ (when on-success-raw
+ (user-error "Not supported yet: on-success-raw"))
+ (when on-success
+ (funcall on-success response)))
+ :else (lambda (error)
+ (when on-error
+ (funcall on-error error)))
+ :timeout (or timeout llm-request-plz-timeout)))
+
+;; This is a useful method for getting out of the request buffer when it's time
+;; to make callbacks.
+(defun llm-request-plz-callback-in-buffer (buf f &rest args)
+ "Run F with ARSG in the context of BUF.
+But if BUF has been killed, use a temporary buffer instead.
+If F is nil, nothing is done."
+ (when f
+ (if (buffer-live-p buf)
+ (with-current-buffer buf (apply f args))
+ (with-temp-buffer (apply f args)))))
+
+(provide 'llm-request-plz)
+;;; llm-request-plz.el ends here
diff --git a/plz-event-source.el b/plz-event-source.el
new file mode 100644
index 0000000000..c72e7bb7fa
--- /dev/null
+++ b/plz-event-source.el
@@ -0,0 +1,458 @@
+;;; plz-event-source.el --- Server Sent Event Source -*- lexical-binding: t;
-*-
+
+;; Copyright (C) 2019-2023 Free Software Foundation, Inc.
+
+;; Author: r0man <ro...@burningswell.com>
+;; Maintainer: r0man <ro...@burningswell.com>
+
+;; This file is part of GNU Emacs.
+
+;;; License:
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This library provides a parser and an event source implementation
+;; for the Server Sent Event (SSE) protocol.
+
+;; See:
https://html.spec.whatwg.org/multipage/server-sent-events.html#server-sent-events
+
+;;; Code:
+
+(require 'cl-lib)
+(require 'eieio)
+(require 'pcase)
+(require 'plz)
+(require 'plz-media-type)
+(require 'rx)
+
+;; Event
+
+(defclass plz-event-source-event ()
+ ((data
+ :accessor plz-event-source-event-data
+ :initarg :data
+ :initform nil
+ :documentation "The event data.")
+ (last-event-id
+ :accessor plz-event-source-event-last-event-id
+ :initarg :last-event-id
+ :initform nil
+ :documentation "The last event id."
+ :type (or null string))
+ (origin
+ :accessor plz-event-source-event-origin
+ :initarg :origin
+ :initform nil
+ :documentation "The event origin."
+ :type (or null string))
+ (type
+ :accessor plz-event-source-event-type
+ :initarg :type
+ :initform "message"
+ :documentation "The event type."
+ :type string))
+ "The server sent event class.")
+
+;; Parser
+
+(defclass plz-event-source-parser ()
+ ((buffer
+ :documentation "The name of the buffer to read events from."
+ :initarg :buffer
+ :type string)
+ (events
+ :initarg :events
+ :initform nil
+ :documentation "The queue of events to dispatch."
+ :type (list-of plz-event-source-event))
+ (data-buffer
+ :initarg :data-buffer
+ :initform ""
+ :documentation "Data buffer."
+ :type string)
+ (event-type-buffer
+ :initarg :event-type-buffer
+ :initform ""
+ :documentation "Event type buffer."
+ :type string)
+ (last-event-id
+ :initarg :last-event-id
+ :initform ""
+ :documentation "Last event id."
+ :type string)
+ (last-event-id-buffer
+ :initarg :last-event-id-buffer
+ :initform ""
+ :documentation "Last event id buffer."
+ :type string)
+ (position
+ :initarg :position
+ :initform 0
+ :type integer
+ :documentation "The position in the buffer."
+ :type integer))
+ "The server sent event stream parser.")
+
+(defconst plz-event-source--end-of-line-regexp
+ (rx (or "\r\n" "\n" "\r"))
+ "Regular expression matching the end of a line.")
+
+(defconst plz-event-source--line-regexp
+ (rx (* not-newline) (or "\r\n" "\n" "\r"))
+ "Regular expression matching a line of the event source stream.")
+
+(defun plz-event-source--parse-bom (line)
+ "Parse the Byte Order Mark (BOM) from LINE."
+ (if (string-prefix-p "\uFEFF" line)
+ (substring line 1)
+ line))
+
+(defun plz-event-source--looking-at-line-p ()
+ "Return non-nil if the current line matches the event source line regexp."
+ (looking-at plz-event-source--line-regexp))
+
+(defun plz-event-source--parse-line ()
+ "Return non-nil if the current line matches the event source line regexp."
+ (when (looking-at plz-event-source--line-regexp)
+ (string-trim-right (delete-and-extract-region (match-beginning 0)
(match-end 0))
+ plz-event-source--end-of-line-regexp)))
+
+(defun plz-event-source--dispatch-event (parser)
+ "Dispatch an event from PARSER to registered listeners."
+ (with-slots (data-buffer event-type-buffer events last-event-id
last-event-id-buffer) parser
+ (setf last-event-id last-event-id-buffer)
+ (if (string-empty-p data-buffer)
+ (setf data-buffer ""
+ event-type-buffer "")
+ (progn
+ (setf data-buffer (string-trim-right data-buffer "\n"))
+ (let ((event (plz-event-source-event
+ :data data-buffer
+ :last-event-id (unless (string-blank-p last-event-id)
+ last-event-id)
+ :origin (buffer-name)
+ :type (if (string-blank-p event-type-buffer)
+ "message"
+ event-type-buffer))))
+ (setf data-buffer ""
+ event-type-buffer "")
+ (setf events (cons event events))
+ event)))))
+
+(defun plz-event-source--process-event (parser field value)
+ "Process the FIELD and VALUE from PARSER as a event."
+ (ignore field)
+ (with-slots (event-type-buffer) parser
+ (setf event-type-buffer value)))
+
+(defun plz-event-source--process-data (parser field value)
+ "Process the FIELD and VALUE from PARSER as data."
+ (ignore field)
+ (with-slots (data-buffer) parser
+ (setf data-buffer (concat data-buffer value "\n"))))
+
+(defun plz-event-source--process-id (parser field value)
+ "Process the FIELD and VALUE from PARSER as event id."
+ (ignore field)
+ (unless (string-match "\u0000" value)
+ (with-slots (last-event-id-buffer) parser
+ (setf last-event-id-buffer value))))
+
+(defun plz-event-source--process-retry (parser field value)
+ "Process the FIELD and VALUE from PARSER as event id."
+ (ignore parser)
+ (message "TODO: Process retry for field %s and value %s." field value))
+
+(defun plz-event-source--process-field (parser field value)
+ "Process the FIELD and VALUE from PARSER."
+ (cond ((equal "event" field)
+ (plz-event-source--process-event parser field value))
+ ((equal "data" field)
+ (plz-event-source--process-data parser field value))
+ ((equal "id" field)
+ (plz-event-source--process-id parser field value))
+ ((equal "retry" field)
+ (plz-event-source--process-retry parser field value))))
+
+(defun plz-event-source--process-line (parser line)
+ "Parse a LINE of the event stream PARSER and dispatch events."
+ (cond ((string-prefix-p ":" line))
+ ((string-blank-p line)
+ (plz-event-source--dispatch-event parser))
+ ((string-match ":" line)
+ (let ((field (substring line 0 (match-beginning 0)))
+ (value (substring line (match-end 0))))
+ (plz-event-source--process-field parser field
+ (if (string-prefix-p " " value)
+ (substring value 1)
+ value))))
+ (t (plz-event-source--process-field parser line ""))))
+
+(defun plz-event-source-parse-line (parser)
+ "Parse a line from the event stream in the PARSER buffer."
+ (with-slots (buffer position) parser
+ (with-current-buffer buffer
+ (save-excursion
+ (goto-char position)
+ (when-let (line (plz-event-source--parse-line))
+ (setf position (point))
+ (plz-event-source--process-line parser line)
+ line)))))
+
+(defun plz-event-source-parse-stream (parser)
+ "Parse the event stream in the the PARSER buffer."
+ (with-slots (buffer handlers) parser
+ (with-current-buffer (get-buffer buffer)
+ (goto-char (point-min))
+ (while (not (eobp))
+ (when-let (line (plz-event-source--parse-line))
+ (plz-event-source--process-line parser line))))))
+
+(defun plz-event-source-parser-insert (parser string)
+ "Insert STRING into the buffer of the event PARSER."
+ (with-slots (buffer events position) parser
+ (with-current-buffer (get-buffer buffer)
+ (insert string)
+ (while (plz-event-source-parse-line parser))
+ events)))
+
+;; Event Source
+
+(defclass plz-event-source ()
+ ((errors
+ :initarg :errors
+ :documentation "The errors of the event source.")
+ (handlers
+ :initarg :handlers
+ :initform nil
+ :documentation "Registered event handlers.")
+ (last-event-id
+ :initarg :last-event-id
+ :initform ""
+ :documentation "Last event id.")
+ (options
+ :initarg :options
+ :documentation "The url of the event source."
+ :type list)
+ (ready-state
+ :documentation "The ready state of the event source."
+ :initarg :ready-state
+ :initform 'closed
+ :type (member closed connecting open))
+ (url
+ :initarg :url
+ :documentation "The url of the event source."
+ :type (or null string)))
+ "The server sent event source class.")
+
+(cl-defgeneric plz-event-source-open (source)
+ "Open the event SOURCE.")
+
+(cl-defgeneric plz-event-source-close (source)
+ "Close the event SOURCE.")
+
+(cl-defgeneric plz-event-source-insert (source data)
+ "Insert DATA into the event SOURCE buffer, parse and dispatch events.")
+
+(defun plz-event-source-add-listener (source type listener)
+ "Add an event LISTENER for event TYPE to the event SOURCE."
+ (with-slots (handlers) source
+ (setf handlers (append handlers (list (cons type listener))))
+ source))
+
+(defun plz-event-source-remove-listener (source type listener)
+ "Remove an event LISTENER for event TYPE from the event SOURCE."
+ (with-slots (handlers) source
+ (setf handlers (cl-remove-if (lambda (pair)
+ (and (eq (car pair) type)
+ (eq (cdr pair) listener)))
+ handlers))
+ source))
+
+(defun plz-event-source-dispatch-event (source event)
+ "Dispatch the EVENT to the listeners of event SOURCE."
+ (with-slots (handlers) source
+ (dolist (pair handlers)
+ (when (equal (car pair) (oref event type))
+ (funcall (cdr pair) source event)))))
+
+(defun plz-event-source-dispatch-events (source events)
+ "Dispatch the EVENTS to the listeners of event SOURCE."
+ (dolist (event (reverse events))
+ (plz-event-source-dispatch-event source event)))
+
+(defun plz-event-source--response-in-buffer-p ()
+ "Return non-nil the if point is looking at a HTTP response."
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward plz-http-end-of-headers-regexp nil t)))
+
+(defun plz-event-source-parser--end-of-headers ()
+ "Return the end of headers position in the current buffer."
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward plz-http-end-of-headers-regexp nil t)
+ (point)))
+
+;; Buffer event source
+
+(defclass plz-buffer-event-source (plz-event-source)
+ ((buffer
+ :initarg :buffer
+ :documentation "The event source buffer."
+ :type string)
+ (parser
+ :initarg :parser
+ :documentation "The event source parser."
+ :type (or null plz-event-source-parser)))
+ "A server sent event source using curl for HTTP.")
+
+(cl-defmethod plz-event-source-insert ((source plz-buffer-event-source) data)
+ "Insert DATA into the event SOURCE buffer, parse and dispatch events."
+ (with-slots (parser) source
+ (plz-event-source-parser-insert parser data)
+ (with-slots (events) parser
+ (plz-event-source-dispatch-events source events)
+ (setf events nil))))
+
+(defun plz-event-source--buffer-start-position ()
+ "Return the start position of the current buffer."
+ (save-excursion
+ (goto-char (point-min))
+ (re-search-forward plz-http-end-of-headers-regexp nil t)
+ (point)))
+
+(cl-defmethod plz-event-source-open ((source plz-buffer-event-source))
+ "Open a connection to the URL of the event SOURCE."
+ (with-slots (buffer errors options ready-state parser) source
+ (with-current-buffer (get-buffer-create buffer)
+ (let ((event (plz-event-source-event :type "open")))
+ (setf ready-state 'connecting)
+ (setf parser (plz-event-source-parser
+ :buffer buffer
+ :position (plz-event-source--buffer-start-position)))
+ (setf ready-state 'open)
+ (plz-event-source-dispatch-event source event)
+ source))))
+
+(cl-defmethod plz-event-source-close ((source plz-buffer-event-source))
+ "Close the connection of the event SOURCE."
+ (with-slots (buffer ready-state) source
+ (let ((event (plz-event-source-event :type "close")))
+ (setf ready-state 'closed)
+ (plz-event-source-dispatch-event source event)
+ source)))
+
+(defclass plz-http-event-source (plz-event-source)
+ ((process
+ :initarg :process
+ :documentation "The process of the event source."
+ :type (or null process))
+ (response
+ :initarg :response
+ :documentation "The plz HTTP response."
+ :type (or null plz-response)))
+ "A server sent event source using curl for HTTP.")
+
+(defun plz-event-source--media-types (source)
+ "Return the media types of the event SOURCE."
+ (with-slots (handlers) source
+ (let ((media-type (plz-media-type:text/event-stream :events handlers)))
+ (cons (cons "text/event-stream" media-type) plz-media-types))))
+
+(cl-defmethod plz-event-source-open ((source plz-http-event-source))
+ "Open a connection to the URL of the event SOURCE."
+ (with-slots (errors options process ready-state response url) source
+ (setf ready-state 'connecting)
+ (setf response nil)
+ (setf process (plz-media-type-request
+ (or (alist-get 'method options) 'get) url
+ :as `(media-types ,(plz-event-source--media-types source))
+ :body (alist-get 'body options)
+ :headers (alist-get 'headers options)
+ :then (lambda (object)
+ (setf response object))
+ :else (lambda (object)
+ (setf errors (push object errors))
+ (setf response (plz-error-response object)))
+ :finally (lambda ()
+ (setf ready-state 'closed))))
+ source))
+
+(cl-defmethod plz-event-source-close ((source plz-http-event-source))
+ "Close the connection of the event SOURCE."
+ (with-slots (process ready-state) source
+ (delete-process process)
+ (setf ready-state 'closed)))
+
+;; Content Type: text/event-stream
+
+(defclass plz-media-type:text/event-stream
(plz-media-type:application/octet-stream)
+ ((name :initform "text/event-stream")
+ (events :documentation "Association list from event type to handler."
+ :initarg :events)))
+
+(defun plz-media-type:text/event-stream--event-source (response)
+ "Return the event source of the RESPONSE."
+ (process-get (plz-response-process response) :plz-event-source))
+
+(cl-defmethod plz-media-type-else ((_ plz-media-type:text/event-stream) error)
+ "Transform the ERROR into a format suitable for MEDIA-TYPE."
+ (let* ((response (plz-error-response error))
+ (source (plz-media-type:text/event-stream--event-source response))
+ (event (plz-event-source-event :type "error" :data error)))
+ (plz-event-source-close source)
+ (plz-event-source-dispatch-event source event)
+ error))
+
+(cl-defmethod plz-media-type-process ((media-type
plz-media-type:text/event-stream) process chunk)
+ "Process the CHUNK according to MEDIA-TYPE using PROCESS."
+ (when (buffer-live-p (process-buffer process))
+ (with-current-buffer (process-buffer process)
+ (unless (process-get process :plz-event-source)
+ (let* ((response (make-plz-response
+ :status (plz-response-status chunk)
+ :headers (plz-response-headers chunk)))
+ (source (plz-event-source-open
+ (plz-buffer-event-source
+ :buffer (buffer-name (process-buffer process))
+ :handlers (seq-map
+ (lambda (pair)
+ (let ((type (car pair))
+ (handler (cdr pair)))
+ (cond
+ ((equal "open" type)
+ (cons type (lambda (source event)
+ (setf (oref event data)
response)
+ (funcall handler source
event))))
+ ((equal "close" type)
+ (cons type (lambda (source event)
+ (setf (oref event data)
response)
+ (funcall handler source
event))))
+ (t pair))))
+ (oref media-type events))))))
+ (process-put process :plz-event-source source)))
+ (plz-event-source-insert (process-get process :plz-event-source)
+ (plz-response-body chunk)))))
+
+(cl-defmethod plz-media-type-then ((_ plz-media-type:text/event-stream)
response)
+ "Transform the RESPONSE into a format suitable for MEDIA-TYPE."
+ (let ((source (plz-media-type:text/event-stream--event-source response)))
+ (plz-event-source-close source)
+ response))
+
+(provide 'plz-event-source)
+;;; plz-event-source.el ends here
diff --git a/plz-media-type.el b/plz-media-type.el
new file mode 100644
index 0000000000..af498ce87f
--- /dev/null
+++ b/plz-media-type.el
@@ -0,0 +1,341 @@
+;;; plz-media-type.el --- plz content types -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2019-2023 Free Software Foundation, Inc.
+
+;; Author: r0man <ro...@burningswell.com>
+;; Maintainer: r0man <ro...@burningswell.com>
+
+;; This file is part of GNU Emacs.
+
+;;; License:
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+
+;; This file handles content type.
+
+;;; Code:
+
+;;;; Requirements
+
+(require 'cl-lib)
+(require 'eieio)
+(require 'plz)
+
+(defclass plz:media-type ()
+ ((name
+ :documentation "The MIME Type of the handler."
+ :initarg :name
+ :initform "application/octet-stream"
+ :type string)))
+
+(cl-defgeneric plz-media-type-else (media-type error)
+ "Transform the ERROR into a format suitable for MEDIA-TYPE.")
+
+(cl-defgeneric plz-media-type-then (media-type response)
+ "Transform the RESPONSE into a format suitable for MEDIA-TYPE.")
+
+(cl-defgeneric plz-media-type-process (media-type process chunk)
+ "Process the CHUNK according to MEDIA-TYPE using PROCESS.")
+
+(defun plz-media-type--content-type (response)
+ "Return the content type header of RESPONSE, or nil if it's not set."
+ (let ((headers (plz-response-headers response)))
+ (when-let (header (cdr (assoc 'content-type headers)))
+ (replace-regexp-in-string "\s*\\(;.*\\)?" "" header))))
+
+(defun plz-media--type-find (media-types media-type)
+ "Lookup the MEDIA-TYPE in MEDIA-TYPES."
+ (or (alist-get media-type media-types nil nil #'equal)
+ (alist-get t media-types)
+ (plz-media-type:application/octet-stream)))
+
+(defun plz-media-type--of-response (media-types response)
+ "Lookup the content type of RESPONSE in MEDIA-TYPES."
+ (let ((media-type (plz-media-type--content-type response)))
+ (plz-media--type-find media-types media-type)))
+
+(defun plz-media-type-process-filter (process media-types chunk)
+ "The process filter that handles different content types.
+
+PROCESS is the process.
+
+MEDIA-TYPES is an association list from media type to an
+instance of a content type class.
+
+CHUNK is a part of the HTTP body."
+ (when (buffer-live-p (process-buffer process))
+ (with-current-buffer (process-buffer process)
+ (let ((moving (= (point) (process-mark process))))
+ (if-let (media-type (process-get process :plz-media-type))
+ (let ((response (process-get process :plz-media-type-response)))
+ (setf (plz-response-body response) chunk)
+ (plz-media-type-process media-type process response))
+ (progn
+ (save-excursion
+ (goto-char (process-mark process))
+ (insert chunk)
+ (set-marker (process-mark process) (point)))
+ (goto-char (point-min))
+ (when (re-search-forward plz-http-end-of-headers-regexp nil t)
+ (let ((body-start (point)))
+ (goto-char (point-min))
+ (let* ((response (prog1 (plz--response) (widen)))
+ (media-type (plz-media-type--of-response media-types
response)))
+ (process-put process :plz-media-type media-type)
+ (when-let (body (plz-response-body response))
+ (when (> (length body) 0)
+ (delete-region body-start (point-max))
+ (set-marker (process-mark process) (point))
+ (plz-media-type-process media-type process response)))
+ (setf (plz-response-body response) nil)
+ (process-put process :plz-media-type-response response))))))
+ (when moving
+ (goto-char (process-mark process)))))))
+
+;; Content Type: application/octet-stream
+
+(defclass plz-media-type:application/octet-stream (plz:media-type)
+ ((name :initform "application/octet-stream")))
+
+(cl-defmethod plz-media-type-else ((media-type
plz-media-type:application/octet-stream) error)
+ "Transform the ERROR into a format suitable for MEDIA-TYPE."
+ (let ((response (plz-error-response error)))
+ (setf (plz-error-response error) (plz-media-type-then media-type response))
+ error))
+
+(cl-defmethod plz-media-type-then ((media-type
plz-media-type:application/octet-stream) response)
+ "Transform the RESPONSE into a format suitable for MEDIA-TYPE."
+ (ignore media-type)
+ response)
+
+(cl-defmethod plz-media-type-process ((media-type
plz-media-type:application/octet-stream) process chunk)
+ "Process the CHUNK according to MEDIA-TYPE using PROCESS."
+ (ignore media-type)
+ (when (buffer-live-p (process-buffer process))
+ (with-current-buffer (process-buffer process)
+ (let ((moving (= (point) (process-mark process))))
+ (save-excursion
+ (goto-char (process-mark process))
+ (insert (plz-response-body chunk))
+ (set-marker (process-mark process) (point)))
+ (when moving
+ (goto-char (process-mark process)))))))
+
+;; Content Type: application/json
+
+(defclass plz-media-type:application/json
(plz-media-type:application/octet-stream)
+ ((name :initform "application/json")
+ (array-type :initform 'array)
+ (false-object :initform :json-false)
+ (null-object :initform nil)
+ (object-type :initform 'alist)))
+
+(cl-defmethod plz-media-type-then ((media-type
plz-media-type:application/json) response)
+ "Transform the RESPONSE into a format suitable for MEDIA-TYPE."
+ (with-slots (array-type false-object null-object object-type) media-type
+ (setf (plz-response-body response)
+ (with-temp-buffer
+ (insert (plz-response-body response))
+ (goto-char (point-min))
+ (json-parse-buffer :array-type array-type
+ :false-object false-object
+ :null-object null-object
+ :object-type object-type)))
+ response))
+
+;; Content Type: application/xml
+
+(defclass plz-media-type:application/xml
(plz-media-type:application/octet-stream)
+ ((name :initform "application/xml")))
+
+(cl-defmethod plz-media-type-then ((media-type plz-media-type:application/xml)
response)
+ "Transform the RESPONSE into a format suitable for MEDIA-TYPE."
+ (with-slots (array-type false-object null-object object-type) media-type
+ (setf (plz-response-body response)
+ (with-temp-buffer
+ (insert (plz-response-body response))
+ (libxml-parse-html-region)))
+ response))
+
+;; Content Type: text/html
+
+(defclass plz-media-type:text/html (plz-media-type:application/octet-stream)
+ ((name :initform "text/html")))
+
+(cl-defmethod plz-media-type-then ((media-type plz-media-type:text/html)
response)
+ "Transform the RESPONSE into a format suitable for MEDIA-TYPE."
+ (with-slots (array-type false-object null-object object-type) media-type
+ (setf (plz-response-body response)
+ (with-temp-buffer
+ (insert (plz-response-body response))
+ (libxml-parse-html-region)))
+ response))
+
+(defvar plz-media-types
+ `(("application/json" . ,(plz-media-type:application/json))
+ ("application/octet-stream" . ,(plz-media-type:application/json))
+ ("application/xml" . ,(plz-media-type:application/xml))
+ ("text/html" . ,(plz-media-type:text/html))
+ (t . ,(plz-media-type:application/octet-stream)))
+ "Alist from media type to content type.")
+
+(cl-defun plz-media-type-request
+ (method
+ url
+ &rest rest &key headers body else finally noquery
+ (as 'string)
+ (body-type 'text)
+ (connect-timeout plz-connect-timeout)
+ (decode t decode-s)
+ (then 'sync)
+ (timeout plz-timeout))
+ "Request METHOD from URL with curl.
+Return the curl process object or, for a synchronous request, the
+selected result.
+
+HEADERS may be an alist of extra headers to send with the
+request.
+
+BODY may be a string, a buffer, or a list like `(file FILENAME)'
+to upload a file from disk.
+
+BODY-TYPE may be `text' to send BODY as text, or `binary' to send
+it as binary.
+
+AS selects the kind of result to pass to the callback function
+THEN, or the kind of result to return for synchronous requests.
+It may be:
+
+- `buffer' to pass the response buffer, which will be narrowed to
+ the response body and decoded according to DECODE.
+
+- `binary' to pass the response body as an un-decoded string.
+
+- `string' to pass the response body as a decoded string.
+
+- `response' to pass a `plz-response' structure.
+
+- `file' to pass a temporary filename to which the response body
+ has been saved without decoding.
+
+- `(file FILENAME)' to pass FILENAME after having saved the
+ response body to it without decoding. FILENAME must be a
+ non-existent file; if it exists, it will not be overwritten,
+ and an error will be signaled.
+
+- `(stream :through PROCESS-FILTER)' to asynchronously stream the
+ HTTP response. PROCESS-FILTER is an Emacs process filter
+ function, and must accept two arguments: the curl process
+ sending the request and a chunk of the HTTP body, which was
+ just received.
+
+- A function, which is called in the response buffer with it
+ narrowed to the response body (suitable for, e.g. `json-read').
+
+If DECODE is non-nil, the response body is decoded automatically.
+For binary content, it should be nil. When AS is `binary',
+DECODE is automatically set to nil.
+
+THEN is a callback function, whose sole argument is selected
+above with AS; if the request fails and no ELSE function is
+given (see below), the argument will be a `plz-error' structure
+describing the error. Or THEN may be `sync' to make a
+synchronous request, in which case the result is returned
+directly from this function.
+
+ELSE is an optional callback function called when the request
+fails (i.e. if curl fails, or if the HTTP response has a non-2xx
+status code). It is called with one argument, a `plz-error'
+structure. If ELSE is nil, a `plz-curl-error' or
+`plz-http-error' is signaled when the request fails, with a
+`plz-error' structure as the error data. For synchronous
+requests, this argument is ignored.
+
+NOTE: In v0.8 of `plz', only one error will be signaled:
+`plz-error'. The existing errors, `plz-curl-error' and
+`plz-http-error', inherit from `plz-error' to allow applications
+to update their code while using v0.7 (i.e. any `condition-case'
+forms should now handle only `plz-error', not the other two).
+
+FINALLY is an optional function called without argument after
+THEN or ELSE, as appropriate. For synchronous requests, this
+argument is ignored.
+
+CONNECT-TIMEOUT and TIMEOUT are a number of seconds that limit
+how long it takes to connect to a host and to receive a response
+from a host, respectively.
+
+NOQUERY is passed to `make-process', which see.
+
+When the HTTP response is streamed, the buffering in the curl
+output stream is turned off and the PROCESS-FILTER may be called
+multiple times, depending on the size of the HTTP body. It is
+the user's responsibility to understand and process each chunk,
+and to construct the finalized response if necessary. There are
+no guarantees regarding the chunk, such as being line-based or
+not.
+\(To silence checkdoc, we mention the internal argument REST.)"
+ ;; FIXME(v0.8): Remove the note about error changes from the docstring.
+ ;; FIXME(v0.8): Update error signals in docstring.
+ (declare (indent defun))
+ (ignore as) ;; TODO: Handle as?
+ (if-let (media-types (pcase as
+ (`(media-types ,media-types)
+ media-types)))
+ (let* ((plz-curl-default-args (cons "--no-buffer" plz-curl-default-args))
+ (result (plz method url
+ :as 'response
+ :body body
+ :body-type body-type
+ :connect-timeout connect-timeout
+ :decode decode
+ :else (when (functionp else)
+ (lambda (object)
+ (let* ((media-type
(plz-media-type--of-response media-types (plz-error-response object)))
+ (object (plz-media-type-else
media-type object)))
+ (funcall else object))))
+ :finally (when (functionp finally)
+ (lambda () (funcall finally)))
+ :headers headers
+ :noquery noquery
+ :process-filter (lambda (process chunk)
+ (plz-media-type-process-filter
process media-types chunk))
+ :timeout timeout
+ :then (cond
+ ((symbolp then) then)
+ ((functionp then)
+ (lambda (object)
+ (let* ((media-type
(plz-media-type--of-response media-types object))
+ (object (plz-media-type-then
media-type object)))
+ (funcall then object))))))))
+ ;; TODO: Handle sync event stream
+ (cond
+ ((processp result)
+ result)
+ ((plz-response-p result)
+ (let ((media-type (plz-media-type--of-response media-types result)))
+ (plz-media-type-then media-type result)))
+ ((plz-error-p result)
+ (let ((media-type (plz-media-type--of-response media-types
(plz-error-response result))))
+ (plz-media-type-else media-type result)))
+ (t result)))
+ (apply #'plz (append (list method url) rest))))
+
+;;;; Footer
+
+(provide 'plz-media-type)
+
+;;; plz-media-type.el ends here
diff --git a/plz.el b/plz.el
new file mode 100644
index 0000000000..0739a20b04
--- /dev/null
+++ b/plz.el
@@ -0,0 +1,912 @@
+;;; plz.el --- HTTP library -*- lexical-binding: t; -*-
+
+;; Copyright (C) 2019-2023 Free Software Foundation, Inc.
+
+;; Author: Adam Porter <a...@alphapapa.net>
+;; Maintainer: Adam Porter <a...@alphapapa.net>
+;; URL: https://github.com/alphapapa/plz.el
+;; Version: 0.8-pre
+;; Package-Requires: ((emacs "26.3"))
+;; Keywords: comm, network, http
+
+;; This file is part of GNU Emacs.
+
+;;; License:
+
+;; This program is free software; you can redistribute it and/or modify
+;; it under the terms of the GNU General Public License as published by
+;; the Free Software Foundation, either version 3 of the License, or
+;; (at your option) any later version.
+
+;; This program is distributed in the hope that it will be useful,
+;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+;; GNU General Public License for more details.
+
+;; You should have received a copy of the GNU General Public License
+;; along with this program. If not, see <https://www.gnu.org/licenses/>.
+
+;;; Commentary:
+;;
+;; An HTTP library that uses curl as a backend. Inspired by, and some
+;; code copied from, Christopher Wellons's library, elfeed-curl.el.
+;;
+;; Why this package?
+;;
+;; 1. `url' works well for many things, but it has some issues.
+;; 2. `request' works well for many things, but it has some issues.
+;; 3. Chris Wellons doesn't have time to factor his excellent
+;; elfeed-curl.el library out of Elfeed. This will have to do.
+;;
+;; Why is it called `plz'?
+;;
+;; 1. There's already a package called `http'.
+;; 2. There's already a package called `request'.
+;; 3. Naming things is hard.
+
+;;;; Usage:
+
+;; FIXME(v0.8): Remove the following note.
+
+;; NOTE: In v0.8 of plz, only one error will be signaled: `plz-error'.
+;; The existing errors, `plz-curl-error' and `plz-http-error', inherit
+;; from `plz-error' to allow applications to update their code while
+;; using v0.7 (i.e. any `condition-case' forms should now handle only
+;; `plz-error', not the other two).
+
+;; Call function `plz' to make an HTTP request. Its docstring
+;; explains its arguments. `plz' also supports other HTTP methods,
+;; uploading and downloading binary files, sending URL parameters and
+;; HTTP headers, configurable timeouts, error-handling "else" and
+;; always-called "finally" functions, and more.
+
+;; Basic usage is simple. For example, to make a synchronous request
+;; and return the HTTP response body as a string:
+;;
+;; (plz 'get "https://httpbin.org/get";)
+;;
+;; Which returns the JSON object as a string:
+;;
+;; "{
+;; \"args\": {},
+;; \"headers\": {
+;; \"Accept\": \"*/*\",
+;; \"Accept-Encoding\": \"deflate, gzip\",
+;; \"Host\": \"httpbin.org\",
+;; \"User-Agent\": \"curl/7.35.0\"
+;; },
+;; \"origin\": \"xxx.xxx.xxx.xxx\",
+;; \"url\": \"https://httpbin.org/get\";
+;; }"
+;;
+;; To make the same request asynchronously, decoding the JSON and
+;; printing a message with a value from it:
+;;
+;; (plz 'get "https://httpbin.org/get"; :as #'json-read
+;; :then (lambda (alist) (message "URL: %s" (alist-get 'url alist))))
+;;
+;; Which, after the request returns, prints:
+;;
+;; URL: https://httpbin.org/get
+
+;;;; Credits:
+
+;; Thanks to Chris Wellons for inspiration, encouragement, and advice.
+
+;;; Code:
+
+;;;; Requirements
+
+(require 'cl-lib)
+(require 'rx)
+(require 'subr-x)
+
+;;;; Errors
+
+(define-error 'plz-error "plz error")
+(define-error 'plz-curl-error "plz: Curl error" 'plz-error)
+(define-error 'plz-http-error "plz: HTTP error" 'plz-error)
+
+;;;; Structs
+
+(cl-defstruct plz-response
+ version status headers body process)
+
+(cl-defstruct plz-error
+ curl-error response message)
+
+;;;; Constants
+
+(defconst plz-http-response-status-line-regexp
+ (rx "HTTP/" (group (or "1.0" "1.1" "2")) " "
+ ;; Status code
+ (group (1+ digit)) " "
+ ;; Reason phrase
+ (optional (group (1+ (not (any "\r\n")))))
+ (or
+ ;; HTTP 1
+ "\r\n"
+ ;; HTTP 2
+ "\n"))
+ "Regular expression matching HTTP response status line.")
+
+(defconst plz-http-end-of-headers-regexp
+ (rx (or "\r\n\r\n" "\n\n"))
+ "Regular expression matching the end of HTTP headers.
+This must work with both HTTP/1 (using CRLF) and HTTP/2 (using
+only LF).")
+
+(defconst plz-curl-errors
+ ;; Copied from elfeed-curl.el.
+ '((1 . "Unsupported protocol.")
+ (2 . "Failed to initialize.")
+ (3 . "URL malformed. The syntax was not correct.")
+ (4 . "A feature or option that was needed to perform the desired request
was not enabled or was explicitly disabled at build-time.")
+ (5 . "Couldn't resolve proxy. The given proxy host could not be resolved.")
+ (6 . "Couldn't resolve host. The given remote host was not resolved.")
+ (7 . "Failed to connect to host.")
+ (8 . "FTP weird server reply. The server sent data curl couldn't parse.")
+ (9 . "FTP access denied.")
+ (11 . "FTP weird PASS reply.")
+ (13 . "FTP weird PASV reply.")
+ (14 . "FTP weird 227 format.")
+ (15 . "FTP can't get host.")
+ (17 . "FTP couldn't set binary.")
+ (18 . "Partial file. Only a part of the file was transferred.")
+ (19 . "FTP couldn't download/access the given file, the RETR (or similar)
command failed.")
+ (21 . "FTP quote error. A quote command returned error from the server.")
+ (22 . "HTTP page not retrieved.")
+ (23 . "Write error.")
+ (25 . "FTP couldn't STOR file.")
+ (26 . "Read error. Various reading problems.")
+ (27 . "Out of memory. A memory allocation request failed.")
+ (28 . "Operation timeout.")
+ (30 . "FTP PORT failed.")
+ (31 . "FTP couldn't use REST.")
+ (33 . "HTTP range error. The range \"command\" didn't work.")
+ (34 . "HTTP post error. Internal post-request generation error.")
+ (35 . "SSL connect error. The SSL handshaking failed.")
+ (36 . "FTP bad download resume.")
+ (37 . "FILE couldn't read file.")
+ (38 . "LDAP bind operation failed.")
+ (39 . "LDAP search failed.")
+ (41 . "Function not found. A required LDAP function was not found.")
+ (42 . "Aborted by callback.")
+ (43 . "Internal error. A function was called with a bad parameter.")
+ (45 . "Interface error. A specified outgoing interface could not be used.")
+ (47 . "Too many redirects.")
+ (48 . "Unknown option specified to libcurl.")
+ (49 . "Malformed telnet option.")
+ (51 . "The peer's SSL certificate or SSH MD5 fingerprint was not OK.")
+ (52 . "The server didn't reply anything, which here is considered an
error.")
+ (53 . "SSL crypto engine not found.")
+ (54 . "Cannot set SSL crypto engine as default.")
+ (55 . "Failed sending network data.")
+ (56 . "Failure in receiving network data.")
+ (58 . "Problem with the local certificate.")
+ (59 . "Couldn't use specified SSL cipher.")
+ (60 . "Peer certificate cannot be authenticated with known CA
certificates.")
+ (61 . "Unrecognized transfer encoding.")
+ (62 . "Invalid LDAP URL.")
+ (63 . "Maximum file size exceeded.")
+ (64 . "Requested FTP SSL level failed.")
+ (65 . "Sending the data requires a rewind that failed.")
+ (66 . "Failed to initialise SSL Engine.")
+ (67 . "The user name, password, or similar was not accepted and curl
failed to log in.")
+ (68 . "File not found on TFTP server.")
+ (69 . "Permission problem on TFTP server.")
+ (70 . "Out of disk space on TFTP server.")
+ (71 . "Illegal TFTP operation.")
+ (72 . "Unknown TFTP transfer ID.")
+ (73 . "File already exists (TFTP).")
+ (74 . "No such user (TFTP).")
+ (75 . "Character conversion failed.")
+ (76 . "Character conversion functions required.")
+ (77 . "Problem with reading the SSL CA cert (path? access rights?).")
+ (78 . "The resource referenced in the URL does not exist.")
+ (79 . "An unspecified error occurred during the SSH session.")
+ (80 . "Failed to shut down the SSL connection.")
+ (82 . "Could not load CRL file, missing or wrong format (added in
7.19.0).")
+ (83 . "Issuer check failed (added in 7.19.0).")
+ (84 . "The FTP PRET command failed")
+ (85 . "RTSP: mismatch of CSeq numbers")
+ (86 . "RTSP: mismatch of Session Identifiers")
+ (87 . "unable to parse FTP file list")
+ (88 . "FTP chunk callback reported error")
+ (89 . "No connection available, the session will be queued")
+ (90 . "SSL public key does not matched pinned public key"))
+ "Alist mapping curl error code integers to helpful error messages.")
+
+;;;; Customization
+
+(defgroup plz nil
+ "Options for `plz'."
+ :group 'network
+ :link '(url-link "https://github.com/alphapapa/plz.el";))
+
+(defcustom plz-curl-program "curl"
+ "Name of curl program to call."
+ :type 'string)
+
+(defcustom plz-curl-default-args
+ '("--silent"
+ "--compressed"
+ "--location")
+ "Default arguments to curl.
+Note that these arguments are passed on the command line, which
+may be visible to other users on the local system."
+ :type '(repeat string))
+
+(defcustom plz-connect-timeout 5
+ "Default connection timeout in seconds.
+This limits how long the connection phase may last (the
+\"--connect-timeout\" argument to curl)."
+ :type 'number)
+
+(defcustom plz-timeout 60
+ "Default request timeout in seconds.
+This limits how long an entire request may take, including the
+connection phase and waiting to receive the response (the
+\"--max-time\" argument to curl)."
+ :type 'number)
+
+;;;; Functions
+
+;;;;; Public
+
+(cl-defun plz (method url &rest rest &key headers body else finally noquery
process-filter
+ (as 'string) (then 'sync)
+ (body-type 'text) (decode t decode-s)
+ (connect-timeout plz-connect-timeout) (timeout
plz-timeout))
+ "Request METHOD from URL with curl.
+Return the curl process object or, for a synchronous request, the
+selected result.
+
+HEADERS may be an alist of extra headers to send with the
+request.
+
+BODY may be a string, a buffer, or a list like `(file FILENAME)'
+to upload a file from disk.
+
+BODY-TYPE may be `text' to send BODY as text, or `binary' to send
+it as binary.
+
+AS selects the kind of result to pass to the callback function
+THEN, or the kind of result to return for synchronous requests.
+It may be:
+
+- `buffer' to pass the response buffer, which will be narrowed to
+ the response body and decoded according to DECODE.
+
+- `binary' to pass the response body as an un-decoded string.
+
+- `string' to pass the response body as a decoded string.
+
+- `response' to pass a `plz-response' structure.
+
+- `file' to pass a temporary filename to which the response body
+ has been saved without decoding.
+
+- `(file FILENAME)' to pass FILENAME after having saved the
+ response body to it without decoding. FILENAME must be a
+ non-existent file; if it exists, it will not be overwritten,
+ and an error will be signaled.
+
+- A function, which is called in the response buffer with it
+ narrowed to the response body (suitable for, e.g. `json-read').
+
+If DECODE is non-nil, the response body is decoded automatically.
+For binary content, it should be nil. When AS is `binary',
+DECODE is automatically set to nil.
+
+THEN is a callback function, whose sole argument is selected
+above with AS; if the request fails and no ELSE function is
+given (see below), the argument will be a `plz-error' structure
+describing the error. Or THEN may be `sync' to make a
+synchronous request, in which case the result is returned
+directly from this function.
+
+ELSE is an optional callback function called when the request
+fails (i.e. if curl fails, or if the HTTP response has a non-2xx
+status code). It is called with one argument, a `plz-error'
+structure. If ELSE is nil, a `plz-curl-error' or
+`plz-http-error' is signaled when the request fails, with a
+`plz-error' structure as the error data. For synchronous
+requests, this argument is ignored.
+
+NOTE: In v0.8 of `plz', only one error will be signaled:
+`plz-error'. The existing errors, `plz-curl-error' and
+`plz-http-error', inherit from `plz-error' to allow applications
+to update their code while using v0.7 (i.e. any `condition-case'
+forms should now handle only `plz-error', not the other two).
+
+FINALLY is an optional function called without argument after
+THEN or ELSE, as appropriate. For synchronous requests, this
+argument is ignored.
+
+CONNECT-TIMEOUT and TIMEOUT are a number of seconds that limit
+how long it takes to connect to a host and to receive a response
+from a host, respectively.
+
+NOQUERY is passed to `make-process', which see.
+
+\(To silence checkdoc, we mention the internal argument REST.)"
+ ;; FIXME(v0.8): Remove the note about error changes from the docstring.
+ ;; FIXME(v0.8): Update error signals in docstring.
+ (declare (indent defun))
+ (setf decode (if (and decode-s (not decode))
+ nil decode))
+ ;; NOTE: By default, for PUT requests and POST requests >1KB, curl sends an
+ ;; "Expect:" header, which causes servers to send a "100 Continue" response,
which
+ ;; we don't want to have to deal with, so we disable it by setting the
header to
+ ;; the empty string. See <https://gms.tf/when-curl-sends-100-continue.html>.
+ ;; TODO: Handle "100 Continue" responses and remove this workaround.
+ (push (cons "Expect" "") headers)
+ (let* ((data-arg (pcase-exhaustive body-type
+ ('binary "--data-binary")
+ ('text "--data")))
+ (curl-command-line-args (append plz-curl-default-args
+ (list "--config" "-")))
+ (curl-config-header-args (cl-loop for (key . value) in headers
+ collect (cons "--header" (format
"%s: %s" key value))))
+ (curl-config-args (append curl-config-header-args
+ (list (cons "--url" url))
+ (when connect-timeout
+ (list (cons "--connect-timeout"
+ (number-to-string
connect-timeout))))
+ (when timeout
+ (list (cons "--max-time"
(number-to-string timeout))))
+ ;; NOTE: To make a HEAD request
+ ;; requires using the "--head"
+ ;; option rather than "--request
+ ;; HEAD", and doing so with
+ ;; "--dump-header" duplicates the
+ ;; headers, so we must instead
+ ;; specify that for each other
+ ;; method.
+ (pcase method
+ ('get
+ (list (cons "--dump-header" "-")))
+ ((or 'put 'post)
+ (list (cons "--dump-header" "-")
+ (cons "--request" (upcase
(symbol-name method)))
+ ;; It appears that this must be
the last argument
+ ;; in order to pass data on the
rest of STDIN.
+ (pcase body
+ (`(file ,filename)
+ ;; Use `expand-file-name'
because curl doesn't
+ ;; expand, e.g. "~" into
"/home/...".
+ (cons "--upload-file"
(expand-file-name filename)))
+ (_ (cons data-arg "@-")))))
+ ('delete
+ (list (cons "--dump-header" "-")
+ (cons "--request" (upcase
(symbol-name method)))))
+ ('head
+ (list (cons "--head" "")
+ (cons "--request" "HEAD"))))))
+ (curl-config (cl-loop for (key . value) in curl-config-args
+ concat (format "%s \"%s\"\n" key value)))
+ (decode (pcase as
+ ('binary nil)
+ (_ decode)))
+ (default-directory
+ ;; Avoid making process in a nonexistent directory (in case the
current
+ ;; default-directory has since been removed). It's unclear what the
best
+ ;; directory is, but this seems to make sense, and it should still
exist.
+ temporary-file-directory)
+ (process-buffer (generate-new-buffer " *plz-request-curl*"))
+ (stderr-process (make-pipe-process :name "plz-request-curl-stderr"
+ :buffer (generate-new-buffer "
*plz-request-curl-stderr*")
+ :noquery t
+ :sentinel #'plz--stderr-sentinel))
+ (process (make-process :name "plz-request-curl"
+ :buffer process-buffer
+ :coding 'binary
+ :command (append (list plz-curl-program)
curl-command-line-args)
+ :connection-type 'pipe
+ :filter process-filter
+ :sentinel #'plz--sentinel
+ :stderr stderr-process
+ :noquery noquery))
+ sync-p)
+ (when (eq 'sync then)
+ (setf sync-p t
+ then (lambda (result)
+ (process-put process :plz-result result))
+ else nil))
+ (setf
+ ;; Set the callbacks, etc. as process properties.
+ (process-get process :plz-then)
+ (pcase-exhaustive as
+ ((or 'binary 'string)
+ (lambda ()
+ (let ((coding-system (or (plz--coding-system) 'utf-8)))
+ (pcase as
+ ('binary (set-buffer-multibyte nil)))
+ (plz--narrow-to-body)
+ (when decode
+ (decode-coding-region (point) (point-max) coding-system))
+ (funcall then (or (buffer-string)
+ (make-plz-error :message (format "buffer-string
is nil in buffer:%S" process-buffer)))))))
+ ('buffer (progn
+ (setf (process-get process :plz-as) 'buffer)
+ (lambda ()
+ (let ((coding-system (or (plz--coding-system) 'utf-8)))
+ (pcase as
+ ('binary (set-buffer-multibyte nil)))
+ (plz--narrow-to-body)
+ (when decode
+ (decode-coding-region (point) (point-max)
coding-system)))
+ (funcall then (current-buffer)))))
+ ('response (lambda ()
+ (funcall then (or (plz--response :decode-p decode :process
process)
+ (make-plz-error :message (format
"response is nil for buffer:%S buffer-string:%S"
+
process-buffer (buffer-string)))))))
+ ('file (lambda ()
+ (set-buffer-multibyte nil)
+ (plz--narrow-to-body)
+ (let ((filename (make-temp-file "plz-")))
+ (condition-case err
+ (progn
+ (write-region (point-min) (point-max) filename)
+ (funcall then filename))
+ (file-already-exists
+ (funcall then (make-plz-error :message (format "error
while writing to file %S: %S" filename err))))
+ ;; In case of an error writing to the file, delete the
temp file
+ ;; and signal the error. Ignore any errors encountered
while
+ ;; deleting the file, which would obscure the original
error.
+ (error (ignore-errors
+ (delete-file filename))
+ (funcall then (make-plz-error :message (format
"error while writing to file %S: %S" filename err))))))))
+ (`(file ,(and (pred stringp) filename))
+ (lambda ()
+ (set-buffer-multibyte nil)
+ (plz--narrow-to-body)
+ (condition-case err
+ (progn
+ (write-region (point-min) (point-max) filename nil nil nil
'excl)
+ (funcall then filename))
+ (file-already-exists
+ (funcall then (make-plz-error :message (format "error while
writing to file %S: %S" filename err))))
+ ;; Since we are creating the file, it seems sensible to delete it
in case of an
+ ;; error while writing to it (e.g. a disk-full error). And we
ignore any errors
+ ;; encountered while deleting the file, which would obscure the
original error.
+ (error (ignore-errors
+ (when (file-exists-p filename)
+ (delete-file filename)))
+ (funcall then (make-plz-error :message (format "error while
writing to file %S: %S" filename err)))))))
+ ((pred functionp) (lambda ()
+ (let ((coding-system (or (plz--coding-system)
'utf-8)))
+ (plz--narrow-to-body)
+ (when decode
+ (decode-coding-region (point) (point-max)
coding-system))
+ (funcall then (funcall as))))))
+ (process-get process :plz-else) else
+ (process-get process :plz-finally) finally
+ (process-get process :plz-sync) sync-p
+ ;; Record list of arguments for debugging purposes (e.g. when
+ ;; using Edebug in a process buffer, this allows determining
+ ;; which request the buffer is for).
+ (process-get process :plz-args) (apply #'list method url rest)
+ ;; HACK: We set the result to a sentinel value so that any other
+ ;; value, even nil, means that the response was processed, and
+ ;; the sentinel does not need to be called again (see below).
+ (process-get process :plz-result) :plz-result)
+ ;; Send --config arguments.
+ (process-send-string process curl-config)
+ (when body
+ (cl-typecase body
+ (string (process-send-string process body))
+ (buffer (with-current-buffer body
+ (process-send-region process (point-min) (point-max))))))
+ (process-send-eof process)
+ (if sync-p
+ (unwind-protect
+ (with-local-quit
+ ;; See Info node `(elisp)Accepting Output'.
+ (unless (and process stderr-process)
+ (error "Process unexpectedly nil"))
+ (while (accept-process-output process))
+ (while (accept-process-output stderr-process))
+ (when (eq :plz-result (process-get process :plz-result))
+ ;; HACK: Sentinel seems to not have been called: call it
again. (Although
+ ;; this is a hack, it seems to be a necessary one due to
Emacs's process
+ ;; handling.) See
<https://github.com/alphapapa/plz.el/issues/3> and
+ ;; <https://debbugs.gnu.org/cgi/bugreport.cgi?bug=50166>.
+ (plz--sentinel process "finished\n")
+ (when (eq :plz-result (process-get process :plz-result))
+ (error "Plz: NO RESULT FROM PROCESS:%S ARGS:%S"
+ process rest)))
+ ;; Sentinel seems to have been called: check the result.
+ (pcase (process-get process :plz-result)
+ ((and (pred plz-error-p) data)
+ ;; The AS function signaled an error, which was collected
+ ;; into a `plz-error' struct: re-signal the error here,
+ ;; outside of the sentinel.
+ (if (plz-error-response data)
+ ;; FIXME(v0.8): Signal only plz-error.
+ (signal 'plz-http-error (list "HTTP error" data))
+ (signal 'plz-curl-error (list "Curl error" data))))
+ (else
+ ;; The AS function returned a value: return it.
+ else)))
+ (unless (eq as 'buffer)
+ (kill-buffer process-buffer))
+ (kill-buffer (process-buffer stderr-process)))
+ ;; Async request: return the process object.
+ process)))
+
+;;;;; Queue
+
+;; A simple queue system.
+
+(cl-defstruct plz-queued-request
+ "Structure representing a queued `plz' HTTP request.
+For more details on these slots, see arguments to the function
+`plz'."
+ method url headers body else finally noquery
+ as then body-type decode
+ connect-timeout timeout
+ next previous process)
+
+(cl-defstruct plz-queue
+ "Structure forming a queue for `plz' requests.
+The queue may be appended to (the default) and pre-pended to, and
+items may be removed from the front of the queue (i.e. by
+default, it's FIFO). Use functions `plz-queue', `plz-run', and
+`plz-clear' to queue, run, and clear requests, respectively."
+ (limit 1
+ :documentation "Number of simultaneous requests.")
+ (active nil
+ :documentation "Active requests.")
+ (requests nil
+ :documentation "Queued requests.")
+ (canceled-p nil
+ :documentation "Non-nil when queue has been canceled.")
+ first-active last-active
+ first-request last-request
+ (finally nil
+ :documentation "Function called with no arguments after queue has
been emptied or canceled."))
+
+(defun plz-queue (queue &rest args)
+ "Queue request for ARGS on QUEUE and return QUEUE.
+To pre-pend to QUEUE rather than append, it may be a list of the
+form (`prepend' QUEUE). QUEUE is a `plz-request' queue. ARGS
+are those passed to `plz', which see. Use `plz-run' to start
+making QUEUE's requests."
+ (declare (indent defun))
+ (cl-assert (not (equal 'sync (plist-get (cddr args) :then))) nil
+ "Only async requests may be queued")
+ (pcase-let* ((`(,method ,url . ,rest) args)
+ (args `(:method ,method :url ,url ,@rest))
+ (request (apply #'make-plz-queued-request args)))
+ (pcase queue
+ (`(prepend ,queue) (plz--queue-prepend request queue))
+ (_ (plz--queue-append request queue))))
+ queue)
+
+(defun plz--queue-append (request queue)
+ "Add REQUEST to end of QUEUE and return QUEUE."
+ (cl-check-type request plz-queued-request
+ "REQUEST must be a `plz-queued-request' structure.")
+ (cl-check-type queue plz-queue
+ "QUEUE must be a `plz-queue' structure.")
+ (when (plz-queue-last-request queue)
+ (setf (plz-queued-request-next (plz-queue-last-request queue)) request))
+ (setf (plz-queued-request-previous request) (plz-queue-last-request queue)
+ (plz-queue-last-request queue) request)
+ (unless (plz-queue-first-request queue)
+ (setf (plz-queue-first-request queue) request))
+ (unless (plz-queue-last-request queue)
+ (setf (plz-queue-last-request queue) request))
+ (push request (plz-queue-requests queue))
+ queue)
+
+(defun plz--queue-prepend (request queue)
+ "Add REQUEST to front of QUEUE and return QUEUE."
+ (cl-check-type request plz-queued-request
+ "REQUEST must be a `plz-queued-request' structure.")
+ (cl-check-type queue plz-queue
+ "QUEUE must be a `plz-queue' structure.")
+ (when (plz-queue-requests queue)
+ (setf (plz-queued-request-next request) (car (plz-queue-requests queue))
+ (plz-queued-request-previous (plz-queued-request-next request))
request))
+ (setf (plz-queue-first-request queue) request)
+ (unless (plz-queue-first-request queue)
+ (setf (plz-queue-first-request queue) request))
+ (unless (plz-queue-last-request queue)
+ (setf (plz-queue-last-request queue) request))
+ (push request (plz-queue-requests queue))
+ queue)
+
+(defun plz--queue-pop (queue)
+ "Return the first queued request on QUEUE and remove it from QUEUE."
+ (let* ((request (plz-queue-first-request queue))
+ (next (plz-queued-request-next request)))
+ (when next
+ (setf (plz-queued-request-previous next) nil))
+ (setf (plz-queue-first-request queue) next
+ (plz-queue-requests queue) (delq request (plz-queue-requests queue)))
+ (when (eq request (plz-queue-last-request queue))
+ (setf (plz-queue-last-request queue) nil))
+ request))
+
+(defun plz-run (queue)
+ "Process requests in QUEUE and return QUEUE.
+Return when QUEUE is at limit or has no more queued requests.
+
+QUEUE should be a `plz-queue' structure."
+ (cl-labels ((readyp (queue)
+ (and (not (plz-queue-canceled-p queue))
+ (plz-queue-requests queue)
+ ;; With apologies to skeeto...
+ (< (length (plz-queue-active queue)) (plz-queue-limit
queue)))))
+ (while (readyp queue)
+ (pcase-let* ((request (plz--queue-pop queue))
+ ((cl-struct plz-queued-request method url
+ headers body finally noquery as body-type
decode connect-timeout timeout
+ (else orig-else) (then orig-then))
+ request)
+ (then (lambda (response)
+ (unwind-protect
+ ;; Ensure any errors in the THEN function don't
abort the queue.
+ (funcall orig-then response)
+ (setf (plz-queue-active queue) (delq request
(plz-queue-active queue)))
+ (plz-run queue))))
+ (else (lambda (arg)
+ ;; FIXME(v0.8): This should be done in `plz-queue'
because
+ ;; `plz-clear' will call the second
queued-request's ELSE
+ ;; before it can be set by `plz-run'.
+ (unwind-protect
+ ;; Ensure any errors in the THEN function don't
abort the queue.
+ (when orig-else
+ (funcall orig-else arg))
+ (setf (plz-queue-active queue) (delq request
(plz-queue-active queue)))
+ (plz-run queue))))
+ (args (list method url
+ ;; Omit arguments for which `plz' has defaults
so as not to nil them.
+ :headers headers :body body :finally finally
:noquery noquery
+ :connect-timeout connect-timeout :timeout
timeout)))
+ ;; Add arguments which override defaults.
+ (when as
+ (setf args (plist-put args :as as)))
+ (when else
+ (setf args (plist-put args :else else)))
+ (when then
+ (setf args (plist-put args :then then)))
+ (when decode
+ (setf args (plist-put args :decode decode)))
+ (when body-type
+ (setf args (plist-put args :body-type body-type)))
+ (when connect-timeout
+ (setf args (plist-put args :connect-timeout connect-timeout)))
+ (when timeout
+ (setf args (plist-put args :timeout timeout)))
+ (setf (plz-queued-request-process request) (apply #'plz args))
+ (push request (plz-queue-active queue))))
+ (when (and (plz-queue-finally queue)
+ (zerop (length (plz-queue-active queue)))
+ (zerop (length (plz-queue-requests queue))))
+ (funcall (plz-queue-finally queue)))
+ queue))
+
+(defun plz-clear (queue)
+ "Clear QUEUE and return it.
+Cancels any active or pending requests and calls the queue's
+FINALLY function. For pending requests, their ELSE functions
+will be called with a `plz-error' structure with the message,
+\"`plz' queue cleared; request canceled.\"; active requests will
+have their curl processes killed and their ELSE functions called
+with the corresponding data."
+ (setf (plz-queue-canceled-p queue) t)
+ (dolist (request (plz-queue-active queue))
+ (when (process-live-p (plz-queued-request-process request))
+ (kill-process (plz-queued-request-process request)))
+ (setf (plz-queue-active queue) (delq request (plz-queue-active queue))))
+ (dolist (request (plz-queue-requests queue))
+ (funcall (plz-queued-request-else request)
+ (make-plz-error :message "`plz' queue cleared; request
canceled."))
+ (setf (plz-queue-requests queue) (delq request (plz-queue-requests
queue))))
+ (when (plz-queue-finally queue)
+ (funcall (plz-queue-finally queue)))
+ (setf (plz-queue-first-active queue) nil
+ (plz-queue-last-active queue) nil
+ (plz-queue-first-request queue) nil
+ (plz-queue-last-request queue) nil
+ (plz-queue-canceled-p queue) nil)
+ queue)
+
+(defun plz-length (queue)
+ "Return number of of QUEUE's outstanding requests.
+Includes active and queued requests."
+ (+ (length (plz-queue-active queue))
+ (length (plz-queue-requests queue))))
+
+;;;;; Private
+
+(defun plz--sentinel (process status)
+ "Sentinel for curl PROCESS.
+STATUS should be the process's event string (see info
+node `(elisp) Sentinels'). Calls `plz--respond' to process the
+HTTP response (directly for synchronous requests, or from a timer
+for asynchronous ones)."
+ (pcase status
+ ((or "finished\n" "killed\n" "interrupt\n"
+ (pred numberp)
+ (rx "exited abnormally with code " (group (1+ digit))))
+ (let ((buffer (process-buffer process)))
+ (if (process-get process :plz-sync)
+ (plz--respond process buffer status)
+ (run-at-time 0 nil #'plz--respond process buffer status))))))
+
+(defun plz--respond (process buffer status)
+ "Respond to HTTP response from PROCESS in BUFFER.
+Parses the response and calls the THEN/ELSE callbacks
+accordingly. To be called from `plz--sentinel'. STATUS is the
+argument passed to `plz--sentinel', which see."
+ ;; Is it silly to call this function "please respond"? Perhaps, but
+ ;; naming things is hard. The term "process" has another meaning in
+ ;; this context, and the old standby, "handle," is much overused.
+ ;; "Respond" also means "to react to something," which is what this
+ ;; does--react to receiving the HTTP response--and it's an internal
+ ;; name, so why not.
+ (unwind-protect
+ (with-current-buffer buffer
+ (pcase-exhaustive status
+ ((or 0 "finished\n")
+ ;; Curl exited normally: check HTTP status code.
+ (goto-char (point-min))
+ (plz--skip-proxy-headers)
+ (while (plz--skip-redirect-headers))
+ (pcase (plz--http-status)
+ ((and status (guard (<= 200 status 299)))
+ ;; Any 2xx response is considered successful.
+ (ignore status) ; Byte-compiling in Emacs <28 complains without
this.
+ (funcall (process-get process :plz-then)))
+ (_
+ ;; TODO: If using ":as 'response", the HTTP response
+ ;; should be passed to the THEN function, regardless
+ ;; of the status code. Only for curl errors should
+ ;; the ELSE function be called. (Maybe in v0.8.)
+
+ ;; Any other status code is considered unsuccessful
+ ;; (for now, anyway).
+ (let ((err (make-plz-error :response (plz--response :process
process))))
+ (pcase-exhaustive (process-get process :plz-else)
+ (`nil (process-put process :plz-result err))
+ ((and (pred functionp) fn) (funcall fn err)))))))
+
+ ((or (and (pred numberp) code)
+ (rx "exited abnormally with code " (let code (group (1+
digit)))))
+ ;; Curl error.
+ (let* ((curl-exit-code (cl-typecase code
+ (string (string-to-number code))
+ (number code)))
+ (curl-error-message (alist-get curl-exit-code
plz-curl-errors))
+ (err (make-plz-error :curl-error (cons curl-exit-code
curl-error-message))))
+ (pcase-exhaustive (process-get process :plz-else)
+ (`nil (process-put process :plz-result err))
+ ((and (pred functionp) fn) (funcall fn err)))))
+
+ ((and (or "killed\n" "interrupt\n") status)
+ ;; Curl process killed or interrupted.
+ (let* ((message (pcase status
+ ("killed\n" "curl process killed")
+ ("interrupt\n" "curl process interrupted")))
+ (err (make-plz-error :message message)))
+ (pcase-exhaustive (process-get process :plz-else)
+ (`nil (process-put process :plz-result err))
+ ((and (pred functionp) fn) (funcall fn err)))))))
+ (when-let ((finally (process-get process :plz-finally)))
+ (funcall finally))
+ (unless (or (process-get process :plz-sync)
+ (eq 'buffer (process-get process :plz-as)))
+ (kill-buffer buffer))))
+
+(defun plz--stderr-sentinel (process status)
+ "Sentinel for STDERR buffer.
+Arguments are PROCESS and STATUS (ok, checkdoc?)."
+ (pcase status
+ ((or "finished\n" "killed\n" "interrupt\n"
+ (pred numberp)
+ (rx "exited abnormally with code " (1+ digit)))
+ (kill-buffer (process-buffer process)))))
+
+;;;;;; HTTP Responses
+
+;; Functions for parsing HTTP responses.
+
+(defun plz--skip-proxy-headers ()
+ "Skip proxy headers in current buffer."
+ (when (looking-at plz-http-response-status-line-regexp)
+ (let* ((status-code (string-to-number (match-string 2)))
+ (reason-phrase (match-string 3)))
+ (when (and (equal 200 status-code)
+ (equal "Connection established" reason-phrase))
+ ;; Skip proxy headers (curl apparently offers no way to omit
+ ;; them).
+ (unless (re-search-forward "\r\n\r\n" nil t)
+ (signal 'plz-http-error '("plz--response: End of proxy headers not
found")))))))
+
+(defun plz--skip-redirect-headers ()
+ "Skip HTTP redirect headers in current buffer."
+ (when (and (looking-at plz-http-response-status-line-regexp)
+ (member (string-to-number (match-string 2)) '(301 302 303 307
308)))
+ ;; Skip redirect headers ("--dump-header" forces redirect headers to be
included
+ ;; even when used with "--location").
+ (or (re-search-forward "\r\n\r\n" nil t)
+ (signal 'plz-http-error '("plz--response: End of redirect headers not
found")))))
+
+(cl-defun plz--response (&key (decode-p t) process)
+ "Return response structure for HTTP response in current buffer.
+When DECODE-P is non-nil, decode the response body automatically
+according to the apparent coding system.
+
+PROCESS is the curl process object that made the request.
+
+Assumes that point is at beginning of HTTP response."
+ (save-excursion
+ ;; Parse HTTP version and status code.
+ (unless (looking-at plz-http-response-status-line-regexp)
+ (signal 'plz-http-error
+ (list "plz--response: Unable to parse HTTP response status line"
+ (buffer-substring (point) (line-end-position)))))
+ (let* ((http-version (string-to-number (match-string 1)))
+ (status-code (string-to-number (match-string 2)))
+ (headers (plz--headers))
+ (coding-system (or (plz--coding-system headers) 'utf-8)))
+ (plz--narrow-to-body)
+ (when decode-p
+ (decode-coding-region (point) (point-max) coding-system))
+ (make-plz-response
+ :version http-version
+ :status status-code
+ :headers headers
+ :body (buffer-string)
+ :process process))))
+
+(defun plz--coding-system (&optional headers)
+ "Return coding system for HTTP response in current buffer.
+HEADERS may optionally be an alist of parsed HTTP headers to
+refer to rather than the current buffer's un-parsed headers."
+ (let* ((headers (or headers (plz--headers)))
+ (content-type (alist-get 'content-type headers)))
+ (when content-type
+ (coding-system-from-name content-type))))
+
+(defun plz--http-status ()
+ "Return HTTP status code for HTTP response in current buffer.
+Assumes point is at start of HTTP response."
+ (when (looking-at plz-http-response-status-line-regexp)
+ (string-to-number (match-string 2))))
+
+(defun plz--headers ()
+ "Return headers alist for HTTP response in current buffer.
+Assumes point is at start of HTTP response."
+ (save-excursion
+ (forward-line 1)
+ (let ((limit (save-excursion
+ (re-search-forward plz-http-end-of-headers-regexp nil)
+ (point))))
+ (cl-loop while (re-search-forward (rx bol (group (1+ (not (in ":"))))
":" (1+ blank)
+ (group (1+ (not (in "\r\n")))))
+ limit t)
+ ;; NOTE: Some HTTP servers send all-lowercase header keys,
which means an alist
+ ;; lookup with `equal' or `string=' fails when the case
differs. We don't want
+ ;; users to have to worry about this, so for consistency, we
downcase the
+ ;; header name. And while we're at it, we might as well intern
it so we can
+ ;; use `alist-get' without having to add "nil nil #'equal"
every time.
+ collect (cons (intern (downcase (match-string 1)))
(match-string 2))))))
+
+(defun plz--narrow-to-body ()
+ "Narrow to body of HTTP response in current buffer.
+Assumes point is at start of HTTP response."
+ (unless (re-search-forward plz-http-end-of-headers-regexp nil t)
+ (signal 'plz-http-error '("plz--narrow-to-body: Unable to find end of
headers")))
+ (narrow-to-region (point) (point-max)))
+
+;;;; Footer
+
+(provide 'plz)
+
+;;; plz.el ends here
