Coverage report: /development/source/library/org/datagraph/spocq-shard/src/spocq-server/utilities.lisp

Kind	Covered	All	%
expression	64	679	9.4
branch	3	38	7.9

Key

Not instrumented

Conditionalized out

Executed

Not executed

Both branches taken

One branch taken

Neither branch taken

1

 ;;; -*- Mode: lisp; Syntax: ansi-common-lisp; Base: 10; Package: org.datagraph.spocq.server.implementation; -*-

2

3

(in-package :org.datagraph.spocq.server.implementation)

4

5

(defgeneric request-configuration-list (request)

6

   (:documentation "Combine the request query arguments, post arguments and headers, in that order of precedence.

7

remove duplicates from the end")

8

(:method ((request http:request))

9

(remove-duplicates (append (http:request-argument-list request)

10

(http:request-headers request))

11

:from-end t

12

:key #'first)))

13

14

15

(defun uri (lexical-form)

16

(handler-case (puri:uri lexical-form)

17

(error (c)

18

(log-warn "uri: ~a")

19

(http:bad-request "uri: invalid lexical form: ~a: ~a"

20

lexical-form

21

c))))

22

23

(defun parse-iri-parameter (parameter)

24

(typecase parameter

25

(null

26

|urn:dydra|:|default|)

27

(spocq.i::iri

28

parameter)

29

(string

30

(cond ((or (string-equal parameter "null")

31

(string-equal parameter "")

32

(string-equal parameter "<urn:dydra:default>")

33

(string-equal parameter "default"))

34

|urn:dydra|:|default|)

35

((case (char parameter 0) ((#\_ #\<) t) (t nil))

36

(or (dydra:parse-term parameter :default nil)

37

(http:bad-request "invalid iri: ~s" parameter)))

38

(t

39

(spocq.i::intern-iri parameter))))

40

(t

41

(http:bad-request "invalid iri: ~s" parameter))))

42

 ;;; (mapcar #'parse-iri-parameter '("_:node" "<http://example.org>" "http://example.org" "" "urn:dydra:default"))

43

44

(defun is-absolute-iri-string (lexical-form)

45

(and (stringp lexical-form)

46

(when (cl-ppcre:scan spocq.i::*iri-prefix-scanner* lexical-form) t)))

47

(deftype absolute-iri-string () '(satisfies is-absolute-iri-string))

48

49

(defgeneric compute-member-iri (container-identifier &key slug container-p)

50

(:documentation "compute an iri for a member given that for a container itself and

51

an optional key")

52

(:method ((resource identified-object) &rest args)

53

(declare (dynamic-extent args))

54

(apply #'compute-member-iri (instance-identifier resource) args))

55

(:method ((container-identifier spocq:iri) &rest args)

56

(declare (dynamic-extent args))

57

(apply #'compute-member-iri (spocq:iri-lexical-form container-identifier) args))

58

(:method ((base string) &key (slug (make-v1-uuid-string)) (container-p nil))

59

(assert-argument-type compute-member-iri base absolute-iri-string)

60

(let* ((separator (case (char base (1- (length base)))

61

((#\/ #\#) "")

62

(t "/"))))

63

(intern-iri (concatenate 'string base separator slug

64

(when container-p "/"))))))

65

66

(defgeneric parse-replication-disposition-regex (disposition)

67

(:method ((disposition null))

68

())

69

(:method ((disposition string))

70

(multiple-value-bind (indicator pattern)

71

(parse-replication-disposition disposition)

72

(when indicator

73

(values indicator

74

(cl-ppcre:create-scanner pattern)

75

pattern)))))

76

;;; (parse-replication-disposition-regex "replicate=.*")

77

78

(defgeneric parse-replication-disposition (disposition)

79

(:method ((disposition null))

80

())

81

(:method ((disposition string))

82

(multiple-value-bind (total parts)

83

(#~"^([^=]+)(?:=(.*))?$" disposition)

84

(when total

85

(values (aref parts 0)

86

(aref parts 1))))))

87

;;; (parse-replication-disposition "replicate=.*")

88

;;; (parse-replication-disposition "replicate=")

89

;;; (parse-replication-disposition "replicate")

90

91

#+(or)

92

(defgeneric tmp-import-pathname (account repository)

93

(:method ((account dydra:account) repository)

94

(tmp-import-pathname (spocq.i::account-name account)

95

repository))

96

(:method ((account t) (repository dydra:repository))

97

(tmp-import-pathname account

98

(spocq.i::repository-name repository)))

99

(:method ((account-name string) (repository-name string))

100

(or (loop for pathname = (make-pathname :directory '(:absolute "tmp")

101

                                             :name (format nil "import-~a-~a-~6,'0d"

102

                                                           account-name

103

                                                           repository-name

104

                                                           (random 1000000)))

105

for i from 0 below 10

106

unless (probe-file pathname)

107

return pathname)

108

(error "Failed to generate a temporary pathname."))))

109

110

(defgeneric call-with-file-stream (function location)

111

(:method ((function t) (location pathname))

112

(with-open-file (stream location :direction :input)

113

(funcall stream)))

114

(:method ((function t) (location string))

115

(if (is-file-url-namestring location)

116

(call-with-file-stream function (construct-iri location))

117

(call-with-file-stream function (pathname location))))

118

(:method ((function t) (location spocq:file-url))

119

(multiple-value-bind (hostname path)

120

(parse-file-url-host-and-path location)

121

(declare (ignore hostname))

122

(call-with-file-stream function (pathname path)))))

123

124

;;; (time (dotimes (x 10000) (uuid:make-v1-uuid))) ;; 8+ seconds

125

;;; (time (dotimes (x 10000) (let ((x -1)) (assert (not (= x (random 100000))))))) ;; << 1 second

126

127

(defgeneric set-memento-response-headers (response revision &key modification-time rfc1123-modification-time)

128

(:method ((response http:response) (revision dydra:repository-revision)

129

&key (modification-time (dydra:repository-write-date revision))

130

(rfc1123-modification-time (http:encode-rfc1123 modification-time)))

131

(unless (search "Accept-Datetime" (http:response-vary response) :test #'char-equal)

132

(setf (http:response-vary response)

133

(format nil "Accept-Datetime~@[, ~a~]" (http:response-vary response))))

134

     (push (format nil "~a; rel=timemap" (dydra:repository-timemap-uri revision)) (http:response-header response :link))

135

     (push (format nil "~a; rel=timegate" (dydra:repository-uri revision)) (http:response-header response :link))

136

(setf (http:response-header response :memento-datetime) rfc1123-modification-time)

137

(unless (dydra:repository-revision-mutable-p revision)

138

;; when the revision is not the head, add a link to the generic

139

       (push (format nil "~a; rel=original" (dydra:repository-uri revision)) (http:response-header response :link)))))

140

141

(defgeneric request-prefer-header (request)

142

(:documentation

143

    "if a prefer header is present, then if the prefer concerns a return, then extract and return the preference")

144

(:method ((request http:request))

145

(request-prefer-header (http:request-header request "Prefer")))

146

(:method ((header null))

147

nil)

148

(:method ((header string))

149

(loop for argument in (split-string header #\;)

150

for (name value) = (split-string argument #\=)

151

for key = (cons-symbol :keyword (trim-string-whitespace name))

152

collect key

153

collect (case key

154

((:include :exclude)

155

                  (unless (and (> (length value) 2) (eql (char value 0) #\") (eql (char value (1- (length value))) #\"))

156

(http:bad-request "invalid prefer header: ~s" header))

157

                  (loop for iri in (split-string (subseq value 1 (1- (length value))) #\space)

158

collect (spocq.i::intern-iri iri)))

159

(t value)))))

160

;;; (request-prefer-header "return=representation; include=\"http://www.w3.org/ns/ldp#PreferMinimalContainer\"")

161

162

(defmethod DE.SETF.HTTP:ENCODE-RFC1123 ((time spocq:date-time) &optional (stream nil))

163

(DE.SETF.HTTP:ENCODE-RFC1123 (spocq.i::date-time-universal-time time) stream))

164

165

(defun compute-ui-component-pathname (component)

166

(make-pathname :name component :defaults *ui-component-root-pathname*))

167

168

(defun first-line (string)

169

(let ((eol-pos (position-if #'(lambda (c) (or (char= c #\return) (char= c #\linefeed))) string)))

170

(if eol-pos

171

(subseq string 0 eol-pos)

172

string)))

173

174

(defgeneric cli-content-type (content-type)

175

(:method ((type mime:mime-type)) (string-downcase (type-of type)))

176

(:method ((type mime:text/vnd.graphviz))

177

;; suppress the binary result form and

178

;; canonicalize to the type which the export program accepts

179

*export-graphviz-content-type*))

180

181

(defgeneric cli-content-encoding (content-encoding)

182

(:method ((type (eql :gzip))) "gzip")

183

(:method ((type (eql :bzip2))) "bzip2")

184

(:method ((type (eql :x-bzip2))) "bzip2"))

185

186

(defun cli-term-identifier (term)

187

"Given a term return its designator for use as subject, predicate or object for a graph match.

188

This apparently used to be either its sha-1 or a special wild-card marker.

189

202103: the iri should be the lexical form

190

In the case of blank nodes and iri, they may already have been interned"

191

(etypecase term

192

(null "-")

193

(rdf:blank-node

194

#+(or) (dydra:make-sha1-digest (concatenate 'string "_:" (rdf:blank-node-label term)))

195

(concatenate 'string "_:" (rdf:blank-node-label term)))

196

(spocq:iri

197

#+(or) (dydra:iri-sha1 term)

198

(iri-lexical-form term))

199

(string

200

#+(or)(dydra:make-sha1-digest term)

201

(if (and (>= (length term) 2) (char= (char term 0) #\<))

202

(subseq term 1 (1- (length term)))

203

(lookup-object-term-number term))

204

)))

205

206

(defun cli-context-identifier (term)

207

"Given a term return its designator for use as context for a graph match.

208

This is either its sha-1 or a special wild-card marker.

209

The term should have been interned in the process of instantiating the request resource."

210

(case term

211

((nil |urn:dydra|:|all|) "-")

212

(|urn:dydra|:|default| "+")

213

(t

214

(etypecase term

215

(rdf:blank-node

216

#+(or) (dydra:make-sha1-digest (concatenate 'string "_:" (rdf:blank-node-label term)))

217

(concatenate 'string "_:" (rdf:blank-node-label term)))

218

(spocq:iri

219

#+(or) (dydra:iri-sha1 term)

220

(iri-lexical-form term))

221

(string

222

#+(or)(dydra:make-sha1-digest term)

223

(if (and (>= (length term) 2) (char= (char term 0) #\<))

224

(subseq term 1 (1- (length term)))

225

term))))))

226

227

228

;;; requests

229

230

(defmethod http:decode-request (resource request (content-type mime:application/json))

231

(let* ((length (http:request-content-length request))

232

(buffer (make-array (or length 128) :element-type 'character :adjustable t)))

233

(http:copy-stream (http:request-content-stream request) buffer :length length)

234

(spocq.i::parse-json buffer)))

235

236

;;;

237

;;; responses

238

239

(defmethod http:encode-response ((field spocq.i::solution-field) (response http:response) (mime-type t))

240

(spocq.i::send-response-message t field (http:response-content-stream response) mime-type))

241

242

 (defmethod http:encode-response ((expression list) (response http:response) (mime-type mime:application/vnd.dydra.sparql-query-algebra))

243

(let ((stream (http:response-content-stream response)))

244

(spocq.i::pprint-sse expression stream)

245

(terpri stream)))

246

247

 (defmethod http:encode-response ((expression list) (response http:response) (mime-type mime:application/sparql-query))

248

(spocq.i::send-response-message :query expression (http:response-content-stream response) mime-type))

249

250

 (defmethod http:encode-response ((query dydra:query) (response http:response) (mime-type mime:application/sparql-query))

251

"In general, encode any query as its symbolic expression in term of the respective media type"

252

(http:encode-response (dydra:query-sse-expression query) response mime-type))

253

254

(defmethod http:encode-response ((query dydra:query) (response http:response) (mime-type mime:*/vnd.graphviz))

255

"Given a query which has been executed, encode the per-node statistics in graphviz dot form."

256

(spocq.i::send-response-message t query (http:response-content-stream response) mime-type))

257

258

259

#+(or) ;;; superceded by native implementation

260

 (defmethod http:encode-response ((field spocq.i::solution-field) (response http:response) (mime-type mime:application/ld+json))

261

(let* ((process (run-program dydra:*executable-pathname.jsonld* `("--input-format=ntriples" "--quiet")

262

:input :stream

263

:output (http:response-content-stream response)

264

:wait nil))

265

(ntriples-stream (spocq.i::run-program-input process)))

266

(prog1 (spocq.i::send-response-message t field ntriples-stream mime:application/n-triples)

267

(close ntriples-stream)

268

(sb-ext:process-wait process)

269

(sb-ext:process-close process))))

270

271

272

;;;

273

;;; logging

274

275

(defmethod http:log (level (acceptor spocq-acceptor) format-control &rest arguments)

276

(apply #'spocq.i::write-log level format-control arguments)

277

(when (and (streamp *terminal-io*)(interactive-stream-p *terminal-io*))

278

(call-next-method)))

279

280

281

;;; rails' x-www-form-urlencoded data

282

283

(defun decode-x-www-form-urlencoded (form-alist &key (package (find-package :keyword)))

284

(let ((result ()))

285

(labels ((intern-property (result key value)

286

(destructuring-bind (first-key . rest-key) key

287

(let* ((keyed-entry (assoc first-key result))

288

(keyed-value (rest keyed-entry)))

289

(if keyed-entry

290

(if rest-key

291

(setf (rest keyed-entry) (intern-property keyed-value rest-key value))

292

(typecase keyed-value

293

                        (cons (setf (rest keyed-entry) (append keyed-value (list value))))

294

(t (setf (rest keyed-entry) (list keyed-value value)))))

295

(if rest-key

296

                      (setf result (acons first-key (intern-property keyed-value rest-key value) result))

297

(setf result (acons first-key value result))))))

298

result))

299

(loop for (key . value) in form-alist

300

for parsed-key = (loop for name in (split-string key "[]")

301

collect (cons-symbol package name))

302

do (setf result (intern-property result parsed-key value)))

303

result)))

304

 ;;;(decode-x-www-form-urlencoded '(("repository[name]" . "asdf") ("repository[acl]" . "read") ("repository[acl]" . "write")))

305

306

(defgeneric compute-plist-field (context plist)

307

(:documentation "Given a class and a property-list, compute the equivalent solution field.")

308

309

(:method ((resource spocq.i::persistent-object) (plist list))

310

(flet ((slot-definition-keyword (sd)

311

(let ((property (spocq.i::slot-definition-decode-presentation-property sd)))

312

(typecase property

313

(null nil)

314

(symbol (symbol-name property))

315

(t (dydra:iri-lexical-form property))))))

316

(let* ((class (class-of resource))

317

(slot-definitions (spocq.i::class-persistent-slots class))

318

(sd-map (loop for sd in slot-definitions

319

for key = (slot-definition-keyword sd)

320

when key

321

collect (cons key sd)))

322

(id (dydra:instance-identifier resource)))

323

(loop for (key . value) in plist

324

for sd = (rest (assoc key sd-map :test #'string-equal))

325

               when sd collect `(,id ,(spocq.i::slot-definition-decode-presentation-property sd) ,value))))))

326

327

328

(defgeneric transcode-field (resource value from to)

329

(:documentation "Given a graph, expressed as a field, and an indicator each for the

330

original and intended result form, translate the given field from the source to the

331

destination form and return it.")

332

333

   (:method ((resource spocq.i::persistent-object) form-alist (from mime:application/x-www-form-urlencoded) (to mime:application/json))

334

(let ((result ()))

335

(labels ((intern-property (result key value)

336

(destructuring-bind (first-key . rest-key) key

337

(let* ((keyed-entry (assoc first-key result :test #'string-equal))

338

(keyed-value (rest keyed-entry)))

339

(if keyed-entry

340

(if rest-key

341

                          (setf (rest keyed-entry) (intern-property keyed-value rest-key value))

342

(typecase keyed-value

343

                            (cons (setf (rest keyed-entry) (append keyed-value (list value))))

344

(t (setf (rest keyed-entry) (list keyed-value value)))))

345

(if rest-key

346

                          (setf result (acons first-key (intern-property keyed-value rest-key value) result))

347

(setf result (acons first-key value result))))))

348

result))

349

(loop for (key . value) in form-alist

350

for parsed-key = (split-string key "[]")

351

do (setf result (intern-property result parsed-key value)))

352

result)))

353

354

   (:method ((resource spocq.i::persistent-object) form-alist (from mime:application/x-www-form-urlencoded) (to mime:application/n-triples))

355

(transcode-field (transcode-field resource from mime:application/json) mime:application/json to))

356

357

   (:method ((resource spocq.i::persistent-object) field (from mime:application/json) (to mime:application/n-triples))

358

     "GIven a json field, compute the equivalent as a list of ntriples. The json field allows three things

359

- atomic values: strings or numbers

360

- vectors : a sequence of other objects

361

      - association lists : always with string keys and with values which are either atomic, encoded types, or vectors of values

362

that is a possibly nested p-list, which is intended to

363

      represent the state of the given resource, collate the property references, flatten them into individual

364

statement and intern value as rdf model terms."

365

(spocq.i::decode-json-object resource field)))

366

367

368

(:documentation "cgi ui support:

369

- http/cgi/api entities to manage request procesing : request

370

- service entities from which the process is composed : agent, operation, account, repository, etc

371

- individual operations

372

")

373

374

(eval-when (:compile-toplevel :execute)

375

(enable-table-reader))

376

377

(defparameter *matched-templates* (make-hash-table :test 'equal))

378

379

(defparameter *interpolation-scanner* (cl-ppcre:create-scanner "(?:\\${|{\\$)[^}]+}"))

380

;;; (cl-ppcre:all-matches *interpolation-scanner* "test {$xxx} qwer {$one} two ${three}")

381

382

383

(defstruct interpolation-template

384

matches

385

string)

386

387

(defgeneric interpolate-presentation (stream table template)

388

(:method (stream table (template string))

389

(multiple-value-bind (matched-template present)

390

(gethash template *matched-templates*)

391

(if present

392

(if matched-template

393

(interpolate-presentation stream table matched-template)

394

(write-string template stream))

395

(let ((matches (cl-ppcre:all-matches *interpolation-scanner* template)))

396

(cond (matches

397

                  (interpolate-presentation stream table (setf (gethash template *matched-templates*)

398

                                                               (make-interpolation-template :string template :matches matches))))

399

(t

400

(setf (gethash template *matched-templates*) nil)

401

(write-string template stream)))))))

402

(:method (stream table (template interpolation-template))

403

(loop with start = 0

404

with string = (interpolation-template-string template)

405

for (match-start match-end) on (interpolation-template-matches template) by #'cddr

406

for substitution = (gethash (subseq string (+ match-start 2) (1- match-end)) table)

407

when (> match-start start)

408

do (write-string string stream :start start :end match-start)

409

when substitution

410

do (interpolate-presentation stream table substitution)

411

do (setf start match-end)

412

finally (when (< match-end (length string))

413

(write-string string stream :start start)))))

414

 ;;; (let ((table #{"asdf" "test{$x}ing" "x" "1"})) (interpolate-presentation t table "this is ${asdf}..."))

415

416

417

418

(defun ui-component-string (component-path)

419

(let ((pathname (compute-ui-component-pathname component-path)))

420

(or (gethash pathname *ui-components*)

421

(setf (gethash pathname *ui-components*)

422

(dydra:read-file pathname)))))

423

424

(defun generate-workspace-presentation (resource request response)

425

(generate-ui-component resource request response (http:request-agent request) "workspace"))

426

427

(defun generate-ui-component (resource request response agent component-path)

428

(declare (ignore agent))

429

(let* ((component-string (ui-component-string component-path))

430

(bindings (table :authToken (http:request-auth-token request)

431

:siteName (dydra:site-name)

432

:accountName (dydra:account-name (resource-account resource))

433

:header (ui-component-string "header")

434

:footer (ui-component-string "footer"))))

435

(interpolate-presentation response bindings component-string)))

436

437

438

(defgeneric call-with-import-file-stream (operator location)

439

(:documentation "accept a file url, map it into the import directory tree,

440

open the file for inport and invoke the operations on the stream.")

441

442

(:method ((operator t) (location pathname))

443

(with-open-file (stream location :direction :input)

444

(funcall operator stream)))

445

(:method ((operator t) (location spocq:file-url))

446

(multiple-value-bind (host path)

447

                          (spocq.i::parse-file-url-host-and-path (spocq:iri-lexical-form location))

448

(assert (and (null host) (stringp path) (plusp (length path))) ()

449

"Invalid file url: ~s" location)

450

(let ((pathname (pathname path)))

451

(assert (eq (first (pathname-directory pathname)) :relative) ()

452

"File url must be relative: ~s" location)

453

(setf pathname (merge-pathnames pathname *import-root-pathname*))

454

(call-with-import-file-stream operator (pathname path))))))