1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
|
(defpackage :trivial-https
(:use :cl :trivial-sockets)
(:export :http-get :http-post :escape-url-query))
(in-package :trivial-https)
(defun url-scheme (url)
(assert (or (string-equal url "http://" :end1 7)
(string-equal url "https://" :end1 8)))
(subseq url 0 (position #\: url)))
(defun url-port (url)
(let* ((scheme (url-scheme url))
(host-start (+ (length scheme) 3))
(path-start (position #\/ url :start host-start)))
(let ((port-start (position #\: url :start host-start :end path-start)))
(if port-start
(parse-integer url :start (1+ port-start) :junk-allowed t)
(if (equal scheme "https") 443 80)))))
(defun url-host (url)
(let* ((host-start (+ (length (url-scheme url)) 3))
(port-start (position #\: url :start host-start))
(host-end (min (or (position #\/ url :start host-start) (length url))
(or port-start (length url)))))
(subseq url host-start host-end)))
(defconstant +crlf+
(if (boundp '+crlf+)
(symbol-value '+crlf+)
(concatenate 'string
(string (code-char 13))
(string (code-char 10)))))
(defun response-read-code (stream)
(let* ((l (read-line stream))
(space (position #\Space l)))
(parse-integer l :start (1+ space) :junk-allowed t)))
(defun response-read-headers (stream)
(loop for line = (read-line stream nil nil)
until (or (eql (length line) 0)
(eql (elt line 0) (code-char 13))
(eql (elt line 0) (code-char 10)))
collect
(let ((colon (position #\: line)))
(cons (intern (string-upcase (subseq line 0 colon)) :keyword)
(string-trim (list #\Space (code-char 13) (code-char 10))
(subseq line (1+ colon)))))))
(defun http-get (url &optional headers)
(let* ((host (url-host url))
(port (url-port url))
(stream
(if (equal (url-scheme url) "https")
(cl+ssl:make-ssl-client-stream
(open-stream host port :element-type '(unsigned-byte 8))
:external-format :iso-8859-1)
(open-stream host port))))
(format stream "GET ~A HTTP/1.0~AHost: ~A~AUser-Agent: Trivial HTTP for Common Lisp~A"
url +crlf+ host +crlf+ +crlf+)
(loop for (name . value) in headers do
(format stream "~A: ~A~A" name value +crlf+))
(write-string +crlf+ stream)
(force-output stream)
(list
(response-read-code stream)
(response-read-headers stream)
stream)))
(defun http-post (url content-type content)
(let* ((host (url-host url))
(port (url-port url))
(stream
(if (equal (url-scheme url) "https")
(cl+ssl:make-ssl-client-stream
(open-stream host port :element-type '(unsigned-byte 8))
:external-format :iso-8859-1)
(open-stream host port))))
(format stream "POST ~A HTTP/1.0~AHost: ~A~AUser-Agent: Trivial HTTP for Common Lisp~AContent-Type: ~A~AContent-Length: ~D~A~A~A" url +crlf+ host +crlf+ +crlf+ content-type +crlf+ (length content) +crlf+ +crlf+ content)
(force-output stream)
(list
(response-read-code stream)
(response-read-headers stream)
stream)))
;; this next method stolen from Araneida
(defun url-reserved-character-p (c)
(not (or (member c '(#\- #\_ #\. #\! #\~ #\* #\' #\( #\) ))
(alphanumericp c))))
(defun escape-url-query (query)
(apply #'concatenate 'string
(loop for c across query
if (url-reserved-character-p c)
collect (format nil "%~2,'0X" (char-code c))
else
collect (string c))))
|
