Coverage report: /home/ellis/comp/core/lib/obj/uri/uri.lisp

Kind	Covered	All	%
expression	49	282	17.4
branch	3	26	11.5

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

;;; lib/obj/uri.lisp --- URIs -*- mode: common-lisp; -*-

2

3

;; URI/IRI/URN support based on Franz's URI support library for

4

;; Allegro.

5

6

;; For general URI information see RFC 3986.

7

8

;; For general IRI information see RFC 3987.

9

10

;; For general URN information see RFC 8141.

11

12

;; For IPv6 changes see RFC 6874.

13

14

;; examples of URIs:

15

#|

16

ftp://ftp.is.co.za/rfc/rfc1808.txt

17

https://www.ietf.org/rfc/rfc2396.txt

18

ldap://[2001:db8::7]/c=GB?objectClass?one

19

mailto:John.Doe@example.com

20

news:comp.infosystems.www.servers.unix

21

tel:+1-816-555-1212

22

telnet://192.0.2.16:80/

23

urn:oasis:names:specification:docbook:dtd:xml:4.1.2

24

|#

25

26

;;; Code:

27

(in-package :obj/uri)

28

(eval-when (:load-toplevel)

29

(pushnew :rfc3986 *features*)

30

(pushnew :rfc6874 *features*)

31

(pushnew :rfc8141 *features*))

32

33

;; This does not persist past the end of compile-file

34

(eval-when (:compile-toplevel) (declaim (optimize (speed 3))))

35

36

(eval-always

37

(defvar *strict-parse* t))

38

39

40

(defclass uri ()

41

(

42

;;;; external:

43

;; uri-host is computed and cached. See the hand-written method below.

44

;; uri-ipv6 and uri-zone-id are read-only by users, so they are in the

45

;; internal section below.

46

47

;;;; These slots are special: when they are changed, the string and

48

;;;; hashcode slots need to be set to nil. For path, parsed-path also

49

;;;; needs to be set to nil. See define-special-uri-slot-setters below.

50

(scheme :initarg :scheme :initform nil :accessor uri-scheme)

51

(userinfo :initarg :userinfo :initform nil :accessor uri-userinfo)

52

(port :initarg :port :initform nil :accessor uri-port)

53

(path :initarg :path :initform nil :accessor uri-path)

54

(query :initarg :query :initform nil :accessor uri-query)

55

(fragment :initarg :fragment :initform nil :accessor uri-fragment)

56

;;;; ...end special slots.

57

(plist :initarg :plist :initform nil :accessor uri-plist)

58

;;;; internal:

59

(%host ;; where part of the value for uri-host is stored

60

;; The values stored here are for URIs with names or IPv4 addresses.

61

;; IPv6 addresses are stored in the .ipv6 and .zone-id slots.

62

;; NOTE:

63

;; I'm conflicted over the fact that .host is both computed and NOT

64

;; computed. It is computed for IPv6, but it holds the actual values

65

;; from the parse for names or IPv4 addresses. It might be a tiny bit

66

;; more clear to have a separate slot for the computed value, but

67

;; would that extra clarity be worth the extra space at runtime?

68

:initarg :host :initform nil :accessor %uri-host)

69

(%ipv6 ;; the pure IPv6 portion of the uri-host, nil otherwise

70

;; This value is the actual IPv6 address that would be suitable for use

71

;; in networking functions. It does NOT include the zone-id or the

72

;; URI [] syntax.

73

:initarg :ipv6 :initform nil :accessor %uri-ipv6)

74

(%zone-id ;; used if IPv6 has a zone ID

75

:initarg :zone-id :initform nil :accessor %uri-zone-id)

76

(escaped ;; non-nil if parsed input contained pct encoded characters

77

:initarg :escaped :initform nil :accessor uri-escaped)

78

(string ;; the cached printable representation of the URI

79

;; It might be different than the original string, because of percent

80

;; encoding. Use of slot setf methods may reset this slot to nil,

81

;; causing it to be recomputed when needed.

82

:initarg :string :initform nil :accessor uri-string)

83

(parsed-path ;; the cached parsed representation of the URI path

84

:initarg :parsed-path

85

:initform nil

86

:accessor %uri-parsed-path)

87

(hashcode ;; cached sxhash, so we don't have to compute it more than once

88

:initarg :hashcode :initform nil :accessor uri-hashcode)))

89

90

#+has-clos-fixed-index-feature (:metaclass fixed-index-class)

91

92

;;; IRI

93

;; - The grammar for IRIs is identical to that of URIs, except the allowed

94

;; character set for URIs is limited to ASCII, while IRIs characters can

95

;; be from the sequence of characters from the Universal Character Set

96

;; (Unicode/ISO 10646).

97

;; - The actual grammar differences are:

98

;; - `unreserved' is now `iunreserved', which adds the alternation case

99

;; `ucschar' (see ucscharp below).

100

;; - `query' is now `iquery', which adds the alternation case

101

;; `iprivate' (see iprivatep below).

102

;; - The IRI parser, string-to-iri, uses the URI parser, but it binds

103

;; .iri-mode. to T, which changes how character validation is done. In

104

;; IRI mode, ucscharp and iprivatep are used in the appropriate places.

105

;;

106

;; See the comments for make-char-bitvector for more details.

107

108

(defclass iri (uri) ())

109

110

(defvar %iri-mode

111

;; Bound to T when we are parsing in IRI mode

112

nil)

113

114

(defmethod uri-host ((uri uri))

115

;; Return the computed host for URI. It is the value which could be used

116

;; by networking functions or programs to perform communication with the

117

;; resource designated by URI.

118

(let ((host (%uri-host uri))

119

ipv6 zone-id)

120

;; If HOST has a value, then use that. Otherwise, if IPV6 has a value,

121

;; then return the IPv6 address, which will include the zone-id, if

122

;; non-nil. Otherwise, return nil.

123

(if* host

124

thenret

125

elseif (setq ipv6 (%uri-ipv6 uri))

126

then ;; This setf clears the cached printed value (string slot)

127

(setf (%uri-host uri)

128

(if* (setq zone-id (%uri-zone-id uri))

129

then (concatenate 'string ipv6 "%" zone-id)

130

else ipv6)))))

131

132

;; It is by design there are no public setf methods for these

133

(defmethod uri-ipv6 ((uri uri)) (%uri-ipv6 uri))

134

(defmethod uri-zone-id ((uri uri)) (%uri-zone-id uri))

135

136

;; The .HOST slot is computed, for IPv6, or the actual name or IPv4

137

;; address. To ensure all three slots are kept consistent, define a

138

;; function to set them.

139

(defun set-host (uri name-or-ipv4 ipv6 zone-id)

140

(when (and name-or-ipv4 ipv6)

141

(error "Both the IPv4/name and IPv6 values cannot be non-nil: ~s, ~s."

142

name-or-ipv4 ipv6))

143

(setf (%uri-host uri) name-or-ipv4

144

(%uri-ipv6 uri) ipv6

145

(%uri-zone-id uri) zone-id))

146

147

(defmethod (setf uri-host) (v (uri uri))

148

(prog1

149

(if* (null v)

150

then (set-host uri nil nil nil)

151

elseif (stringp v)

152

then (multiple-value-bind (found whole ipv6 zone-id)

153

;; This embodies knowledge of the URI IPv6 syntax

154

(cl-ppcre:scan "^(.*:.*?)(%.*)?$" v)

155

(declare (ignore whole))

156

(if* found

157

then (set-host uri nil ipv6 zone-id)

158

else (set-host uri v nil nil))

159

v)

160

else (error "host value must be a string: ~s." v))

161

;; This slot doesn't use clear-computed-uri-slots, so we must do this

162

;; manually:

163

(setf (uri-string uri) nil)

164

(setf (uri-hashcode uri) nil)))

165

166

(defclass urn (uri)

167

;; NOTE: the q-component is stored in the `query' slot and the

168

;; f-component is stored in the `fragment' slot of the of the

169

;; parent class (uri).

170

;; The slots below have no place in the parent class.

171

((nid :initarg :nid :initform nil :accessor urn-nid)

172

(nss :initarg :nss :initform nil :accessor urn-nss)

173

;; q-component is stored in the `query'

174

;; f-component is stored in the `fragment'

175

(r-component ;; ignored in comparisons

176

:initarg :r-component :initform nil :accessor urn-r-component)))

177

178

#+has-clos-fixed-index-feature (:metaclass fixed-index-class)

179

180

(defmethod make-load-form ((self uri) &optional env)

181

(declare (ignore env))

182

`(make-instance ',(class-name (class-of self))

183

:scheme ,(uri-scheme self)

184

:host ,(%uri-host self)

185

:ipv6 ,(%uri-ipv6 self)

186

:zone-id ,(%uri-zone-id self)

187

:userinfo ,(uri-userinfo self)

188

:port ,(uri-port self)

189

:path ',(uri-path self)

190

:query ,(uri-query self)

191

:fragment ,(uri-fragment self)

192

:plist ',(uri-plist self)

193

:string ,(uri-string self)

194

:parsed-path ',(%uri-parsed-path self)))

195

196

(defmethod make-load-form ((self urn) &optional env)

197

(declare (ignore env))

198

`(make-instance ',(class-name (class-of self))

199

:scheme ,(uri-scheme self)

200

:host ,(%uri-host self)

201

:ipv6 ,(%uri-ipv6 self)

202

:zone-id ,(%uri-zone-id self)

203

:userinfo ,(uri-userinfo self)

204

:port ,(uri-port self)

205

:path ',(uri-path self)

206

:query ,(uri-query self) ; q-component

207

:fragment ,(uri-fragment self) ; f-component

208

:plist ',(uri-plist self)

209

:string ,(uri-string self)

210

:parsed-path ',(%uri-parsed-path self)

211

;;; URN-specific:

212

:nid ,(urn-nid self)

213

:nss ,(urn-nss self)

214

:r-component ,(urn-r-component self)))

215

216

(define-condition uri-condition () ())

217

(define-condition uri-error (uri-condition error) ())

218

(define-condition uri-parse-error (parse-error uri-error)

219

((string :initarg :string :reader uri-parse-error-string)))

220

221

(defmethod uri-p ((thing uri)) t)

222

(defmethod uri-p ((thing t)) nil)

223

224

(defmethod iri-p ((thing iri)) t)

225

(defmethod iri-p ((thing t)) nil)

226

227

(defun copy-uri (uri

228

&key place

229

(scheme (when uri (uri-scheme uri)))

230

(host (when uri (%uri-host uri)))

231

(ipv6 (when uri (%uri-ipv6 uri)))

232

(zone-id (when uri (%uri-zone-id uri)))

233

(userinfo (when uri (uri-userinfo uri)))

234

(port (when uri (uri-port uri)))

235

(path (when uri (uri-path uri)))

236

(parsed-path

237

(when uri (copy-list (%uri-parsed-path uri))))

238

(query (when uri (uri-query uri)))

239

(fragment (when uri (uri-fragment uri)))

240

(plist (when uri (copy-list (uri-plist uri))))

241

(class (when uri (class-of uri)))

242

&aux (escaped (when uri (uri-escaped uri))))

243

(if* place

244

then (setf (uri-scheme place) scheme)

245

(set-host place host ipv6 zone-id)

246

(setf (uri-userinfo place) userinfo)

247

(setf (uri-port place) port)

248

(setf (uri-path place) path)

249

(setf (%uri-parsed-path place) parsed-path)

250

(setf (uri-query place) query)

251

(setf (uri-fragment place) fragment)

252

(setf (uri-plist place) plist)

253

(setf (uri-escaped place) escaped)

254

(setf (uri-hashcode place) nil)

255

place

256

elseif (eq 'uri class)

257

then ;; allow the compiler to optimize the call to make-instance:

258

(make-instance 'uri

259

:scheme scheme :host host :ipv6 ipv6 :zone-id zone-id

260

:userinfo userinfo :port port

261

:path path :parsed-path parsed-path

262

:query query :fragment fragment :plist plist

263

:escaped escaped :string nil :hashcode nil)

264

else (make-instance class

265

:scheme scheme :host host :ipv6 ipv6 :zone-id zone-id

266

:userinfo userinfo :port port

267

:path path :parsed-path parsed-path

268

:query query :fragment fragment :plist plist

269

:escaped escaped :string nil :hashcode nil)))

270

271

(defmethod uri-parsed-path ((uri uri))

272

(let ((p (uri-path uri)))

273

(when p

274

(if* (%uri-parsed-path uri)

275

thenret

276

else (setf (%uri-parsed-path uri)

277

(parse-path (uri-path uri) (uri-escaped uri)))))))

278

279

(defmethod (setf uri-parsed-path) (path-list (uri uri))

280

(if* (null path-list)

281

then (setf (uri-path uri) nil)

282

(setf (%uri-parsed-path uri) nil)

283

path-list

284

else (when (not (and (consp path-list)

285

(or (member (car path-list) '(:absolute :relative)

286

:test #'eq))))

287

(error "internal error: path-list is ~s." path-list))

288

(setf (uri-path uri) (render-parsed-path path-list t))

289

(setf (%uri-parsed-path uri) path-list)

290

path-list))

291

292

(defun uri-authority (uri)

293

(when (uri-host uri)

294

(let ((*print-pretty* nil))

295

(format nil "~@[~a@~]~a~@[:~a~]" (uri-userinfo uri)

296

(uri-host uri) (uri-port uri)))))

297

298

(defun uri-nid (uri)

299

(if* (equalp "urn" (uri-scheme uri))

300

then ;; Intentionally did not use .uri-host:

301

(uri-host uri)

302

else (error "URI is not a URN: ~s." uri)))

303

304

(defun uri-nss (uri)

305

(if* (equalp "urn" (uri-scheme uri))

306

then (uri-path uri)

307

else (error "URI is not a URN: ~s." uri)))

308

309

(defmethod urn-q-component ((urn urn)) (uri-query urn))

310

(defmethod urn-f-component ((urn urn)) (uri-fragment urn))

311

312

(defmethod uri ((thing uri)) thing)

313

(defmethod uri ((thing string)) (parse-uri thing))

314

(defmethod uri ((thing t)) (error "Cannot coerce ~s to a uri." thing))

315

316

;; (parse-uri-string-rfc3986 "https://test.com")

317

318

;; TODO

319

;; (defmacro do-all-uris ((var &optional uri-space result-form)

320

;; &rest forms

321

;; &environment env)

322

;; "do-all-uris (var [[uri-space] result-form])

323

;; {declaration}* {tag | statement}*

324

;; Executes the forms once for each uri with var bound to the current uri"

325

;; (let ((f (gensym))

326

;; (g-ignore (gensym))

327

;; (g-uri-space (gensym))

328

;; (body (third (excl::parse-body forms env))))

329

;; `(let ((,g-uri-space (or ,uri-space *uris*)))

330

;; (prog nil

331

;; (flet ((,f (,var &optional ,g-ignore)

332

;; (declare (ignorable ,var ,g-ignore))

333

;; (tagbody ,@body)))

334

;; (maphash #',f ,g-uri-space))

335

;; (return ,result-form)))))