Blame


1 6b4d9ef2 2020-11-09 op (in-package #:phos/gemini)
2 6b4d9ef2 2020-11-09 op
3 6b4d9ef2 2020-11-09 op (defparameter *default-port* 1965
4 6b4d9ef2 2020-11-09 op "The default port for gemini URL.")
5 6b4d9ef2 2020-11-09 op
6 6b4d9ef2 2020-11-09 op (defparameter *code-to-keyword* '((10 :input)
7 6b4d9ef2 2020-11-09 op (11 :sensitive-input)
8 6b4d9ef2 2020-11-09 op (20 :success)
9 6b4d9ef2 2020-11-09 op (30 :redirect)
10 6b4d9ef2 2020-11-09 op (31 :permanent-redirect)
11 6b4d9ef2 2020-11-09 op (40 :temporary-failure)
12 6b4d9ef2 2020-11-09 op (41 :server-unavailable)
13 6b4d9ef2 2020-11-09 op (42 :cgi-error)
14 6b4d9ef2 2020-11-09 op (43 :proxy-error)
15 6b4d9ef2 2020-11-09 op (44 :slow-down)
16 6b4d9ef2 2020-11-09 op (50 :permanent-failure)
17 6b4d9ef2 2020-11-09 op (51 :not-found)
18 6b4d9ef2 2020-11-09 op (52 :gone)
19 6b4d9ef2 2020-11-09 op (53 :proxy-request-refused)
20 6b4d9ef2 2020-11-09 op (59 :bad-request)
21 6b4d9ef2 2020-11-09 op (60 :client-certificate-required)
22 6b4d9ef2 2020-11-09 op (61 :certificate-not-authorised)
23 6b4d9ef2 2020-11-09 op (62 :certificate-not-valid))
24 6b4d9ef2 2020-11-09 op "Maps status code to keyword name.")
25 6b4d9ef2 2020-11-09 op
26 6b4d9ef2 2020-11-09 op (define-condition malformed-response (error)
27 6b4d9ef2 2020-11-09 op ((reason :initarg :reason :reader reason)))
28 6b4d9ef2 2020-11-09 op
29 6b4d9ef2 2020-11-09 op (defun parse-status (s)
30 6b4d9ef2 2020-11-09 op (let* ((n (parse-integer s))
31 6b4d9ef2 2020-11-09 op (x (cadr (assoc n *code-to-keyword*))))
32 6b4d9ef2 2020-11-09 op (when x
33 6b4d9ef2 2020-11-09 op (return-from parse-status x))
34 6b4d9ef2 2020-11-09 op (let* ((l (* (floor (/ n 10))
35 6b4d9ef2 2020-11-09 op 10))
36 6b4d9ef2 2020-11-09 op (x (cadr (assoc l *code-to-keyword*))))
37 6b4d9ef2 2020-11-09 op (if x
38 6b4d9ef2 2020-11-09 op x
39 6b4d9ef2 2020-11-09 op (error 'malformed-response :reason (format nil "unknown response number ~a" s))))))
40 6b4d9ef2 2020-11-09 op
41 6b4d9ef2 2020-11-09 op (defun parse-response (res)
42 6b4d9ef2 2020-11-09 op (unless (uiop:string-suffix-p res (format nil "~c~c" #\return #\newline))
43 6b4d9ef2 2020-11-09 op (error 'malformed-response :reason "response doesn't and with CRLF"))
44 6b4d9ef2 2020-11-09 op (unless (< (length res) 1024)
45 6b4d9ef2 2020-11-09 op (error 'malformed-response :reason "response is longer than 1024 bytes"))
46 6b4d9ef2 2020-11-09 op (setf res (string-trim '(#\return #\newline) res))
47 6b4d9ef2 2020-11-09 op (destructuring-bind (status &optional meta) (cl-ppcre:split "\\s+" res :limit 2)
48 eecee47c 2022-01-14 op (when (and (< (parse-integer status) 40) (not meta))
49 6b4d9ef2 2020-11-09 op (error 'malformed-response :reason "missing meta"))
50 6b4d9ef2 2020-11-09 op (list (parse-status status) meta)))
51 6b4d9ef2 2020-11-09 op
52 3d6bb343 2022-01-15 noreply (defun read-all-string (in)
53 6b4d9ef2 2020-11-09 op (with-output-to-string (out)
54 6b4d9ef2 2020-11-09 op (loop with buffer = (make-array 1024 :element-type 'character)
55 6b4d9ef2 2020-11-09 op for n-chars = (read-sequence buffer in)
56 6b4d9ef2 2020-11-09 op while (< 0 n-chars)
57 6b4d9ef2 2020-11-09 op do (write-sequence buffer out :start 0
58 6b4d9ef2 2020-11-09 op :end n-chars))))
59 6b4d9ef2 2020-11-09 op
60 3d6bb343 2022-01-15 noreply (defun read-all-bytes (in)
61 3d6bb343 2022-01-15 noreply (let ((data (make-array 0 :element-type '(unsigned-byte 8) :adjustable t :fill-pointer 0)))
62 3d6bb343 2022-01-15 noreply (loop with buffer = (make-array 1024 :element-type '(unsigned-byte 8))
63 3d6bb343 2022-01-15 noreply for n-bytes = (read-sequence buffer in)
64 3d6bb343 2022-01-15 noreply for data-size = (array-dimension data 0)
65 3d6bb343 2022-01-15 noreply while (< 0 n-bytes)
66 3d6bb343 2022-01-15 noreply do (adjust-array data (+ data-size n-bytes))
67 3d6bb343 2022-01-15 noreply do (incf (fill-pointer data) n-bytes)
68 3d6bb343 2022-01-15 noreply do (replace data buffer :start1 data-size :end2 n-bytes))
69 3d6bb343 2022-01-15 noreply data))
70 3d6bb343 2022-01-15 noreply
71 6b4d9ef2 2020-11-09 op (defun read-until (in char)
72 6b4d9ef2 2020-11-09 op (with-output-to-string (out)
73 6b4d9ef2 2020-11-09 op (loop for ch = (read-char in)
74 6b4d9ef2 2020-11-09 op when (char= ch char)
75 6b4d9ef2 2020-11-09 op return nil
76 6b4d9ef2 2020-11-09 op do (write-char ch out))
77 6b4d9ef2 2020-11-09 op (write-char char out)))
78 6b4d9ef2 2020-11-09 op
79 6b4d9ef2 2020-11-09 op (defun do-request (host port req)
80 6b4d9ef2 2020-11-09 op "Perform the request REQ to HOST on PORT, blocking until the
81 6b4d9ef2 2020-11-09 op response is fetched, then return the meta and the (decoded) body."
82 6b4d9ef2 2020-11-09 op (usocket:with-client-socket (socket stream host port)
83 6b4d9ef2 2020-11-09 op (let ((ssl-stream (cl+ssl:make-ssl-client-stream
84 6b4d9ef2 2020-11-09 op stream :unwrap-stream-p t
85 6b4d9ef2 2020-11-09 op :external-format '(:utf8 :eol-style :lf)
86 6b4d9ef2 2020-11-09 op :verify nil
87 6b4d9ef2 2020-11-09 op :hostname host)))
88 6b4d9ef2 2020-11-09 op (format ssl-stream "~a~c~c" req #\return #\newline)
89 6b4d9ef2 2020-11-09 op (force-output ssl-stream)
90 6b4d9ef2 2020-11-09 op (let ((resp (parse-response (read-until ssl-stream #\newline))))
91 3d6bb343 2022-01-15 noreply (values resp (if (and (eq (first resp) :success)
92 3d6bb343 2022-01-15 noreply (second resp)
93 3d6bb343 2022-01-15 noreply (string= (subseq (second resp) 0 5) "text/"))
94 3d6bb343 2022-01-15 noreply (read-all-string ssl-stream)
95 3d6bb343 2022-01-15 noreply (read-all-bytes ssl-stream)))))))
96 6b4d9ef2 2020-11-09 op
97 073b25eb 2020-11-09 op (defgeneric request (url)
98 073b25eb 2020-11-09 op (:documentation "Perform a request for the URL"))
99 073b25eb 2020-11-09 op
100 073b25eb 2020-11-09 op (defmethod request ((url string))
101 073b25eb 2020-11-09 op (request (quri:uri url)))
102 073b25eb 2020-11-09 op
103 073b25eb 2020-11-09 op (defmethod request ((url quri:uri))
104 6b4d9ef2 2020-11-09 op (let* ((u (quri:uri url))
105 6b4d9ef2 2020-11-09 op (port (or (quri:uri-port u) 1965))
106 6b4d9ef2 2020-11-09 op (host (quri:uri-host u)))
107 6b4d9ef2 2020-11-09 op (do-request host port url)))